@@ -1,12 +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 #-}
4+{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE LambdaCase #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
@@ -14,27 +11,43 @@
14{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE RankNTypes #-}
15{-# LANGUAGE RecursiveDo #-}
12{-# LANGUAGE RecursiveDo #-}
16{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
17{-# LANGUAGE TemplateHaskell #-}
15{-# LANGUAGE TemplateHaskell #-}
18{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TupleSections #-}
19{-# LANGUAGE TypeApplications #-}
17{-# LANGUAGE TypeApplications #-}
20{-# 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.
31+import Prelude hiding (fail)
22import Control.Concurrent
32import Control.Concurrent
33+import qualified Control.Concurrent.Async as Async
34+import Control.Lens.Operators
23−import Control.Monad
35+import Control.Monad hiding (fail)
24import Control.Monad.Catch
36import Control.Monad.Catch
37+import Control.Monad.Fail
25import Control.Monad.Fix
38import Control.Monad.Fix
26import Control.Monad.IO.Class
39import Control.Monad.IO.Class
27import Control.Monad.Ref
40import Control.Monad.Ref
28import Data.Constraint.Extras
41import Data.Constraint.Extras
29import Data.Constraint.Extras.TH
42import Data.Constraint.Extras.TH
30import Data.Dependent.Map (DMap)
43import Data.Dependent.Map (DMap)
31−import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
44+import Data.Dependent.Sum (DSum(..), (==>))
32−--import Data.Foldable (traverse_)
33import Data.Functor.Identity
45import Data.Functor.Identity
34import Data.Functor.Misc
46import Data.Functor.Misc
35import Data.GADT.Compare.TH
47import Data.GADT.Compare.TH
36import Data.GADT.Show.TH
48import Data.GADT.Show.TH
37import Data.IORef (IORef)
49import Data.IORef (IORef)
50+import Data.List (sort)
38import Data.Maybe
51import Data.Maybe
39import Data.Proxy
52import Data.Proxy
40import Data.Text (Text)
53import Data.Text (Text)
@@ -45,6 +58,7 @@ import Network.Socket
45import Network.Wai
58import Network.Wai
46import Network.WebSockets
59import Network.WebSockets
47import Reflex.Dom.Core
60import Reflex.Dom.Core
61+import Reflex.Dom.Widget.Input (dropdown)
48import Reflex.Patch.DMapWithMove
62import Reflex.Patch.DMapWithMove
49import System.Directory
63import System.Directory
50import System.Environment
64import System.Environment
@@ -52,12 +66,14 @@ import System.IO (stderr)
52import System.IO.Silently
66import System.IO.Silently
53import System.IO.Temp
67import System.IO.Temp
54import System.Process
68import System.Process
69+import System.Which (staticWhich)
55−import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
70+import qualified Test.HUnit as HUnit
56import qualified Test.Hspec as H
71import qualified Test.Hspec as H
72+import qualified Test.Hspec.Core.Spec as H
57import Test.Hspec (xit)
73import Test.Hspec (xit)
58−import Test.Hspec.WebDriver hiding (runWD, click, uploadFile)
74+import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
59import qualified Test.Hspec.WebDriver as WD
75import qualified Test.Hspec.WebDriver as WD
60−import Test.WebDriver (WD)
76+import Test.WebDriver (WD(..))
62import qualified Data.ByteString.Lazy as LBS
78import qualified Data.ByteString.Lazy as LBS
63import qualified Data.Dependent.Map as DMap
79import qualified Data.Dependent.Map as DMap
@@ -73,19 +89,32 @@ import qualified Test.WebDriver.Capabilities as WD
73import Test.Util.ChromeFlags
89import Test.Util.ChromeFlags
74import 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")
76seleniumPort, jsaddlePort :: PortNumber
98seleniumPort, jsaddlePort :: PortNumber
77seleniumPort = 8000
99seleniumPort = 8000
78jsaddlePort = 8001
100jsaddlePort = 8001
80-- TODO Remove orphan
102-- TODO Remove orphan
81−deriving instance MonadRef WD
103+instance MonadRef WD where
104+ type Ref WD = Ref IO
105+ newRef = WD . newRef
106+ readRef = WD . readRef
107+ writeRef r = WD . writeRef r
83assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
109assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
84−assertEqual a b = liftIO . HUnit.assertEqual a b
110+assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
86assertFailure :: MonadIO m => String -> m ()
112assertFailure :: MonadIO m => String -> m ()
87assertFailure = liftIO . HUnit.assertFailure
113assertFailure = liftIO . HUnit.assertFailure
115+assertBool :: (MonadIO m) => String -> Bool -> m ()
116+assertBool msg bool = liftIO $ HUnit.assertBool msg bool
89chromeConfig :: Text -> [Text] -> WD.WDConfig
118chromeConfig :: Text -> [Text] -> WD.WDConfig
90chromeConfig 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
@@ -112,35 +141,26 @@ deriveGEq ''DKey
112deriveGCompare ''DKey
141deriveGCompare ''DKey
113deriveGShow ''DKey
142deriveGShow ''DKey
115−instance ShowTag DKey Identity where
144+deriving instance MonadFail WD
116− showTaggedPrec = \case
117− Key_Int -> showsPrec
118− Key_Char -> showsPrec
119− Key_Bool -> showsPrec
121−instance EqTag DKey Identity where
122− eqTagged Key_Int Key_Int = (==)
123− eqTagged Key_Char Key_Char = (==)
124− eqTagged Key_Bool Key_Bool = (==)
126main :: IO ()
146main :: IO ()
128− unshareNetork
148+ unshareNetwork
129 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
149 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
130 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
150 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
131 withSeleniumServer $ \selenium -> do
151 withSeleniumServer $ \selenium -> do
132− browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
152+ let browserPath = T.strip $ T.pack chromium
133 when (T.null browserPath) $ fail "No browser found"
153 when (T.null browserPath) $ fail "No browser found"
134− withDebugging <- isJust <$> lookupEnv "DEBUG"
154+ withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
135 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
155 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
136 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
156 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
137− hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
157+ hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
139−tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
159+tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
140tests withDebugging wdConfig caps _selenium = do
160tests withDebugging wdConfig caps _selenium = do
141 let putStrLnDebug :: MonadIO m => Text -> m ()
161 let putStrLnDebug :: MonadIO m => Text -> m ()
142 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
162 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
143− session' = sessionWith wdConfig "" . using (map (,"") caps)
163+ session' t = sessionWith wdConfig t . using caps
144 runWD m = runWDOptions (WdOptions False) $ do
164 runWD m = runWDOptions (WdOptions False) $ do
145 putStrLnDebug "before"
165 putStrLnDebug "before"
@@ -149,10 +169,10 @@ tests withDebugging wdConfig caps _selenium = do
149 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
150 testWidgetStatic = testWidgetStaticDebug withDebugging
170 testWidgetStatic = testWidgetStaticDebug withDebugging
151 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
152− testWidget = testWidgetDebug withDebugging
172+ testWidget = testWidgetDebug True withDebugging
153 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
154− testWidget' = testWidgetDebug' withDebugging
174+ testWidget' = testWidgetDebug' True withDebugging
155− describe "text" $ session' $ do
175+ session' "text" $ do
156 it "works" $ runWD $ do
176 it "works" $ runWD $ do
157 testWidgetStatic (checkBodyText "hello world") $ do
177 testWidgetStatic (checkBodyText "hello world") $ do
158 text "hello world"
178 text "hello world"
@@ -213,7 +233,7 @@ tests withDebugging wdConfig caps _selenium = do
213 click <- button ""
233 click <- button ""
214 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
234 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
216− describe "element" $ session' $ do
236+ session' "element" $ do
217 it "works with domEvent Click" $ runWD $ do
237 it "works with domEvent Click" $ runWD $ do
218 clickedRef <- liftIO $ newRef False
238 clickedRef <- liftIO $ newRef False
219 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
239 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
@@ -276,36 +296,86 @@ tests withDebugging wdConfig caps _selenium = do
276 (e, ()) <- element "div" conf $ text "hello world"
296 (e, ()) <- element "div" conf $ text "hello world"
277 let click = domEvent Click e
297 let click = domEvent Click e
278 return ()
298 return ()
279− -- TODO check this is the correct solution
280− it "has ssr attribute, removes ssr attribute" $ runWD $ do
281− let checkSSRAttr = do
282− e <- findElemWithRetry $ WD.ByTag "div"
283− assertAttr e "data-ssr" (Just "")
285− testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world"
287− 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)
288− describe "hydration" $ session' $ do
358+ describe "hydration" $ do
289 it "doesn't wipe user input when switching over" $ runWD $ do
359 it "doesn't wipe user input when switching over" $ runWD $ do
290− inputRef <- newRef ("" :: Text)
360+ inputRef <- newRef ("hello " :: Text)
291 testWidget'
361 testWidget'
293 e <- findElemWithRetry $ WD.ByTag "input"
363 e <- findElemWithRetry $ WD.ByTag "input"
294− WD.sendKeys "hello world" e
364+ WD.sendKeys "world" e
296 (\e -> do
366 (\e -> do
297 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
367 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
298− WD.click =<< (findElemWithRetry $ WD.ByTag "button")
368+ WD.click =<< findElemWithRetry (WD.ByTag "button")
299 readRef inputRef `shouldBeWithRetryM` "hello world"
369 readRef inputRef `shouldBeWithRetryM` "hello world"
301− e <- inputElement def
371+ e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
302 click <- button "save"
372 click <- button "save"
303 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
373 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
304 it "captures user input after switchover" $ runWD $ do
374 it "captures user input after switchover" $ runWD $ do
305 inputRef <- newRef ("" :: Text)
375 inputRef <- newRef ("" :: Text)
306 let checkValue = do
376 let checkValue = do
307− WD.sendKeys "hello world" =<< (findElemWithRetry $ WD.ByTag "input")
377+ WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
308− WD.click =<< (findElemWithRetry $ WD.ByTag "button")
378+ WD.click =<< findElemWithRetry (WD.ByTag "button")
309 readRef inputRef `shouldBeWithRetryM` "hello world"
379 readRef inputRef `shouldBeWithRetryM` "hello world"
310 testWidget (pure ()) checkValue $ do
380 testWidget (pure ()) checkValue $ do
311 e <- inputElement def
381 e <- inputElement def
@@ -355,31 +425,56 @@ tests withDebugging wdConfig caps _selenium = do
355 checkedByUIRef <- newRef False
425 checkedByUIRef <- newRef False
356 checkedRef <- newRef False
426 checkedRef <- newRef False
357 setCheckedChan <- liftIO newChan
427 setCheckedChan <- liftIO newChan
428+ let checkStatic = do
429+ e <- findElemWithRetry $ WD.ByTag "input"
430+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
358− let checkValue = do
432+ checkValue e = do
359 readRef checkedByUIRef `shouldBeWithRetryM` False
433 readRef checkedByUIRef `shouldBeWithRetryM` False
360 readRef checkedRef `shouldBeWithRetryM` False
434 readRef checkedRef `shouldBeWithRetryM` False
361− e <- findElemWithRetry $ WD.ByTag "input"
435+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
362 WD.moveToCenter e
436 WD.moveToCenter e
363 WD.click e
437 WD.click e
364 readRef checkedByUIRef `shouldBeWithRetryM` True
438 readRef checkedByUIRef `shouldBeWithRetryM` True
365 readRef checkedRef `shouldBeWithRetryM` True
439 readRef checkedRef `shouldBeWithRetryM` True
440+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
366 liftIO $ writeChan setCheckedChan False
441 liftIO $ writeChan setCheckedChan False
367 readRef checkedByUIRef `shouldBeWithRetryM` True
442 readRef checkedByUIRef `shouldBeWithRetryM` True
368 readRef checkedRef `shouldBeWithRetryM` False
443 readRef checkedRef `shouldBeWithRetryM` False
444+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
369− testWidget (pure ()) checkValue $ do
445+ testWidget' checkStatic checkValue $ do
370 setChecked <- triggerEventWithChan setCheckedChan
446 setChecked <- triggerEventWithChan setCheckedChan
371 e <- inputElement $ def
447 e <- inputElement $ def
372 & initialAttributes .~ "type" =: "checkbox"
448 & initialAttributes .~ "type" =: "checkbox"
373 & inputElementConfig_setChecked .~ setChecked
449 & inputElementConfig_setChecked .~ setChecked
374 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
450 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
375 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)
376 it "captures file uploads" $ runWD $ do
471 it "captures file uploads" $ runWD $ do
377 filesRef :: IORef [Text] <- newRef []
472 filesRef :: IORef [Text] <- newRef []
378 let uploadFile = do
473 let uploadFile = do
379 e <- findElemWithRetry $ WD.ByTag "input"
474 e <- findElemWithRetry $ WD.ByTag "input"
380 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
475 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
381 WD.sendKeys (T.pack path) e
476 WD.sendKeys (T.pack path) e
382− WD.click =<< (findElemWithRetry $ WD.ByTag "button")
477+ WD.click =<< findElemWithRetry (WD.ByTag "button")
383 liftIO $ removeFile path
478 liftIO $ removeFile path
384 readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
479 readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
385 testWidget (pure ()) uploadFile $ do
480 testWidget (pure ()) uploadFile $ do
@@ -388,13 +483,122 @@ tests withDebugging wdConfig caps _selenium = do
388 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
389 names <- liftJSM $ traverse File.getName fs
484 names <- liftJSM $ traverse File.getName fs
390 liftIO $ writeRef filesRef names
485 liftIO $ writeRef filesRef names
391−
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
392− describe "hydration/immediate" $ session' $ do
596+ describe "hydration/immediate" $ do
393 it "captures user input after switchover" $ runWD $ do
597 it "captures user input after switchover" $ runWD $ do
394 inputRef :: IORef Text <- newRef ""
598 inputRef :: IORef Text <- newRef ""
395 let checkValue = do
599 let checkValue = do
396− WD.sendKeys "hello world" =<< (findElemWithRetry $ WD.ByTag "input")
600+ WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
397− WD.click =<< (findElemWithRetry $ WD.ByTag "button")
601+ WD.click =<< findElemWithRetry (WD.ByTag "button")
398 readRef inputRef `shouldBeWithRetryM` "hello world"
602 readRef inputRef `shouldBeWithRetryM` "hello world"
399 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
603 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
400 e <- inputElement def
604 e <- inputElement def
@@ -411,7 +615,6 @@ tests withDebugging wdConfig caps _selenium = do
411 e <- inputElement def
615 e <- inputElement def
412 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
616 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
413 it "sets value appropriately" $ runWD $ do
617 it "sets value appropriately" $ runWD $ do
414− putStrLnDebug "sets value appropriately"
415 valueByUIRef :: IORef Text <- newRef ""
618 valueByUIRef :: IORef Text <- newRef ""
416 valueRef :: IORef Text <- newRef ""
619 valueRef :: IORef Text <- newRef ""
417 setValueChan :: Chan Text <- liftIO newChan
620 setValueChan :: Chan Text <- liftIO newChan
@@ -432,77 +635,69 @@ tests withDebugging wdConfig caps _selenium = do
432 performEvent_ $ liftIO . writeRef valueByUIRef <$> _inputElement_input e
635 performEvent_ $ liftIO . writeRef valueByUIRef <$> _inputElement_input e
433 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
636 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
434 it "sets checked appropriately" $ runWD $ do
637 it "sets checked appropriately" $ runWD $ do
435− putStrLnDebug "sets checked appropriately"
436 checkedByUIRef <- newRef False
638 checkedByUIRef <- newRef False
437 checkedRef <- newRef False
639 checkedRef <- newRef False
438 setCheckedChan <- liftIO newChan
640 setCheckedChan <- liftIO newChan
439 let checkValue = do
641 let checkValue = do
441 readRef checkedByUIRef `shouldBeWithRetryM` False
642 readRef checkedByUIRef `shouldBeWithRetryM` False
443 readRef checkedRef `shouldBeWithRetryM` False
643 readRef checkedRef `shouldBeWithRetryM` False
445 e <- findElemWithRetry $ WD.ByTag "input"
644 e <- findElemWithRetry $ WD.ByTag "input"
447 WD.moveToCenter e
645 WD.moveToCenter e
449 WD.click e
646 WD.click e
451 readRef checkedByUIRef `shouldBeWithRetryM` True
647 readRef checkedByUIRef `shouldBeWithRetryM` True
453 readRef checkedRef `shouldBeWithRetryM` True
648 readRef checkedRef `shouldBeWithRetryM` True
455 liftIO $ writeChan setCheckedChan False
649 liftIO $ writeChan setCheckedChan False
457 readRef checkedByUIRef `shouldBeWithRetryM` True
650 readRef checkedByUIRef `shouldBeWithRetryM` True
459 readRef checkedRef `shouldBeWithRetryM` False
651 readRef checkedRef `shouldBeWithRetryM` False
461 testWidget (pure ()) checkValue $ do
652 testWidget (pure ()) checkValue $ do
463 setChecked <- triggerEventWithChan setCheckedChan
653 setChecked <- triggerEventWithChan setCheckedChan
465 prerender_ (pure ()) $ do
654 prerender_ (pure ()) $ do
467 e <- inputElement $ def
655 e <- inputElement $ def
468 & initialAttributes .~ "type" =: "checkbox"
656 & initialAttributes .~ "type" =: "checkbox"
469 & inputElementConfig_setChecked .~ setChecked
657 & inputElementConfig_setChecked .~ setChecked
471 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
658 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
473 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
659 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
475 it "captures file uploads" $ runWD $ do
660 it "captures file uploads" $ runWD $ do
476 filesRef :: IORef [Text] <- newRef []
661 filesRef :: IORef [Text] <- newRef []
477 let uploadFile = do
662 let uploadFile = do
479 e <- findElemWithRetry $ WD.ByTag "input"
663 e <- findElemWithRetry $ WD.ByTag "input"
481 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
664 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
483 WD.sendKeys (T.pack path) e
665 WD.sendKeys (T.pack path) e
485− WD.click =<< (findElemWithRetry $ WD.ByTag "button")
666+ WD.click =<< findElemWithRetry (WD.ByTag "button")
487 liftIO $ removeFile path
667 liftIO $ removeFile path
489 readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
668 readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
491 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
669 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
493 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
670 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
495 click <- button "save"
671 click <- button "save"
497 performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
672 performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
499 names <- liftJSM $ traverse File.getName fs
673 names <- liftJSM $ traverse File.getName fs
501 liftIO $ writeRef filesRef names
674 liftIO $ writeRef filesRef names
504− describe "textAreaElement" $ do
676+ session' "textAreaElement" $ do
505− 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
506 it "doesn't wipe user input when switching over" $ runWD $ do
701 it "doesn't wipe user input when switching over" $ runWD $ do
507 inputRef <- newRef ("" :: Text)
702 inputRef <- newRef ("" :: Text)
508 testWidget'
703 testWidget'
@@ -521,8 +716,8 @@ tests withDebugging wdConfig caps _selenium = do
521 it "captures user input after switchover" $ runWD $ do
716 it "captures user input after switchover" $ runWD $ do
522 inputRef <- newRef ("" :: Text)
717 inputRef <- newRef ("" :: Text)
523 let checkValue = do
718 let checkValue = do
524− WD.sendKeys "hello world" =<< (findElemWithRetry $ WD.ByTag "textarea")
719+ WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "textarea")
525− WD.click =<< (findElemWithRetry $ WD.ByTag "button")
720+ WD.click =<< findElemWithRetry (WD.ByTag "button")
526 readRef inputRef `shouldBeWithRetryM` "hello world"
721 readRef inputRef `shouldBeWithRetryM` "hello world"
527 testWidget (pure ()) checkValue $ do
722 testWidget (pure ()) checkValue $ do
528 e <- textAreaElement def
723 e <- textAreaElement def
@@ -568,8 +763,90 @@ tests withDebugging wdConfig caps _selenium = do
568 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
763 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
569 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
764 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
570 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
572− describe "hydration/immediate" $ session' $ do
849+ describe "hydration/immediate" $ do
573 it "captures user input after switchover" $ runWD $ do
850 it "captures user input after switchover" $ runWD $ do
574 inputRef :: IORef Text <- newRef ""
851 inputRef :: IORef Text <- newRef ""
575 let checkValue = do
852 let checkValue = do
@@ -611,24 +888,24 @@ tests withDebugging wdConfig caps _selenium = do
611 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
888 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
612 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
889 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
614− describe "selectElement" $ do
891+ session' "selectElement" $ do
615 let options :: DomBuilder t m => m ()
892 let options :: DomBuilder t m => m ()
616 options = do
893 options = do
617 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
894 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
618 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
895 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
619 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
896 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
620− describe "hydration" $ session' $ do
897+ describe "hydration" $ do
621 it "sets initial value correctly" $ runWD $ do
898 it "sets initial value correctly" $ runWD $ do
622 inputRef <- newRef ("" :: Text)
899 inputRef <- newRef ("" :: Text)
623 let setup = do
900 let setup = do
624 e <- findElemWithRetry $ WD.ByTag "select"
901 e <- findElemWithRetry $ WD.ByTag "select"
625 assertAttr e "value" (Just "three")
902 assertAttr e "value" (Just "three")
626− WD.click =<< (findElemWithRetry $ WD.ById "two")
903+ WD.click =<< findElemWithRetry (WD.ById "two")
628 check e = do
905 check e = do
629 assertAttr e "value" (Just "two")
906 assertAttr e "value" (Just "two")
630 readRef inputRef `shouldBeWithRetryM` "three"
907 readRef inputRef `shouldBeWithRetryM` "three"
631− WD.click =<< (findElemWithRetry $ WD.ByTag "button")
908+ WD.click =<< findElemWithRetry (WD.ByTag "button")
632 assertAttr e "value" (Just "two")
909 assertAttr e "value" (Just "two")
633 readRef inputRef `shouldBeWithRetryM` "two"
910 readRef inputRef `shouldBeWithRetryM` "two"
634 testWidget' setup check $ do
911 testWidget' setup check $ do
@@ -641,9 +918,9 @@ tests withDebugging wdConfig caps _selenium = do
641 let checkValue = do
918 let checkValue = do
642 e <- findElemWithRetry $ WD.ByTag "select"
919 e <- findElemWithRetry $ WD.ByTag "select"
643 assertAttr e "value" (Just "one")
920 assertAttr e "value" (Just "one")
644− WD.click =<< (findElemWithRetry $ WD.ById "two")
921+ WD.click =<< findElemWithRetry (WD.ById "two")
645 assertAttr e "value" (Just "two")
922 assertAttr e "value" (Just "two")
646− WD.click =<< (findElemWithRetry $ WD.ByTag "button")
923+ WD.click =<< findElemWithRetry (WD.ByTag "button")
647 readRef inputRef `shouldBeWithRetryM` "two"
924 readRef inputRef `shouldBeWithRetryM` "two"
648 testWidget (pure ()) checkValue $ do
925 testWidget (pure ()) checkValue $ do
649 (e, ()) <- selectElement def options
926 (e, ()) <- selectElement def options
@@ -691,7 +968,7 @@ tests withDebugging wdConfig caps _selenium = do
691 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
968 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
692 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
969 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
694− describe "hydration/immediate" $ session' $ do
971+ describe "hydration/immediate" $ do
695 it "captures user input after switchover" $ runWD $ do
972 it "captures user input after switchover" $ runWD $ do
696 inputRef :: IORef Text <- newRef ""
973 inputRef :: IORef Text <- newRef ""
697 let checkValue = do
974 let checkValue = do
@@ -737,7 +1014,7 @@ tests withDebugging wdConfig caps _selenium = do
737 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
1014 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
738 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
1015 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
740− describe "prerender" $ session' $ do
1017+ session' "prerender" $ do
741 it "works in simple case" $ runWD $ do
1018 it "works in simple case" $ runWD $ do
742 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
1019 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
743 prerender_ (text "One") (text "Two")
1020 prerender_ (text "One") (text "Two")
@@ -782,9 +1059,9 @@ tests withDebugging wdConfig caps _selenium = do
782 pb <- getPostBuild
1059 pb <- getPostBuild
783 performEvent_ $ liftIO (putMVar lock ()) <$ pb
1060 performEvent_ $ liftIO (putMVar lock ()) <$ pb
784 it "result Dynamic is updated *after* switchover" $ runWD $ do
1061 it "result Dynamic is updated *after* switchover" $ runWD $ do
785− let static = checkBodyText "PostBuild"
1062+ let preSwitchover = checkBodyText "PostBuild"
786 check = checkBodyText "Client"
1063 check = checkBodyText "Client"
787− testWidget static check $ void $ do
1064+ testWidget preSwitchover check $ void $ do
788 d <- prerender (pure "Initial") (pure "Client")
1065 d <- prerender (pure "Initial") (pure "Client")
789 pb <- getPostBuild
1066 pb <- getPostBuild
790 initial <- sample $ current d
1067 initial <- sample $ current d
@@ -792,21 +1069,30 @@ tests withDebugging wdConfig caps _selenium = do
792 -- This essentially checks that the client IO runs *after* switchover/postBuild,
1069 -- This essentially checks that the client IO runs *after* switchover/postBuild,
793 -- thus can't create conflicting DOM
1070 -- thus can't create conflicting DOM
794 it "can't exploit IO to break hydration" $ runWD $ do
1071 it "can't exploit IO to break hydration" $ runWD $ do
795− let static = checkBodyText "Initial"
1072+ let preSwitchover = checkBodyText "Initial"
796− testWidgetStatic static $ void $ do
1073+ testWidgetStatic preSwitchover $ void $ do
797 ref <- liftIO $ newRef "Initial"
1074 ref <- liftIO $ newRef "Initial"
798 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
1075 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
799 text <=< liftIO $ readRef ref
1076 text <=< liftIO $ readRef ref
800 -- As above, so below
1077 -- As above, so below
801 it "can't exploit triggerEvent to break hydration" $ runWD $ do
1078 it "can't exploit triggerEvent to break hydration" $ runWD $ do
802− let static = checkBodyText "Initial"
1079+ let preSwitchover = checkBodyText "Initial"
803 check = checkBodyText "Client"
1080 check = checkBodyText "Client"
804− testWidget static check $ void $ do
1081+ testWidget preSwitchover check $ void $ do
805 (e, trigger) <- newTriggerEvent
1082 (e, trigger) <- newTriggerEvent
806 prerender_ (pure ()) (liftIO $ trigger "Client")
1083 prerender_ (pure ()) (liftIO $ trigger "Client")
807 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 ()
809− describe "runWithReplace" $ session' $ do
1095+ session' "runWithReplace" $ do
810 it "works" $ runWD $ do
1096 it "works" $ runWD $ do
811 replaceChan :: Chan Text <- liftIO newChan
1097 replaceChan :: Chan Text <- liftIO newChan
812 let setup = findElemWithRetry $ WD.ByTag "div"
1098 let setup = findElemWithRetry $ WD.ByTag "div"
@@ -840,7 +1126,7 @@ tests withDebugging wdConfig caps _selenium = do
840 , el "span" . text <$> replace
1126 , el "span" . text <$> replace
842 it "can be nested in postBuild widget" $ runWD $ do
1128 it "can be nested in postBuild widget" $ runWD $ do
843− replaceChan <- liftIO newChan
1129+ replaceChan :: Chan Text <- liftIO newChan
844 let setup = findElemWithRetry $ WD.ByTag "div"
1130 let setup = findElemWithRetry $ WD.ByTag "div"
845 check ssr = do
1131 check ssr = do
846 -- Check that the original element still exists and has the correct text
1132 -- Check that the original element still exists and has the correct text
@@ -873,7 +1159,7 @@ tests withDebugging wdConfig caps _selenium = do
873 replaceChan2 :: Chan Text <- liftIO newChan
1159 replaceChan2 :: Chan Text <- liftIO newChan
874 lock :: MVar () <- liftIO newEmptyMVar
1160 lock :: MVar () <- liftIO newEmptyMVar
875 let check = do
1161 let check = do
876− shouldContainText "" =<< (findElemWithRetry (WD.ByTag "body"))
1162+ shouldContainText "" =<< findElemWithRetry (WD.ByTag "body")
877 liftIO $ do
1163 liftIO $ do
878 writeChan replaceChan1 "one"
1164 writeChan replaceChan1 "one"
879 takeMVar lock
1165 takeMVar lock
@@ -950,7 +1236,61 @@ tests withDebugging wdConfig caps _selenium = do
950 , 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
953− describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1293+ session' "traverseDMapWithKeyWithAdjust" $ do
954 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)
955 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1295 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
956 elClass "span" "key" $ text $ textKey k
1296 elClass "span" "key" $ text $ textKey k
@@ -959,8 +1299,8 @@ tests withDebugging wdConfig caps _selenium = do
959 checkItem :: WD.Element -> Text -> Text -> WD ()
1299 checkItem :: WD.Element -> Text -> Text -> WD ()
960 checkItem li k v = do
1300 checkItem li k v = do
961 putStrLnDebug "checkItem"
1301 putStrLnDebug "checkItem"
962− shouldContainTextNoRetry k =<< (WD.findElemFrom li (WD.ByClass "key"))
1302+ shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
963− shouldContainTextNoRetry v =<< (WD.findElemFrom li (WD.ByClass "value"))
1303+ shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
964 checkInitialItems dm xs = do
1304 checkInitialItems dm xs = do
965 putStrLnDebug "checkInitialItems"
1305 putStrLnDebug "checkInitialItems"
966 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1306 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
@@ -990,26 +1330,26 @@ tests withDebugging wdConfig caps _selenium = do
990 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
1330 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
991 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1331 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
992 chan <- liftIO newChan
1332 chan <- liftIO newChan
993− let static :: WD [WD.Element]
1333+ let preSwitchover :: WD [WD.Element]
994− static = getAndCheckInitialItems keyMap
1334+ preSwitchover = getAndCheckInitialItems keyMap
995 check :: [WD.Element] -> WD ()
1335 check :: [WD.Element] -> WD ()
996 check xs = do
1336 check xs = do
997 checkInitialItems keyMap xs
1337 checkInitialItems keyMap xs
998 checkRemoval chan Key_Int
1338 checkRemoval chan Key_Int
999 checkReplace chan Key_Char 'B'
1339 checkReplace chan Key_Char 'B'
1000 checkInsert chan Key_Bool True
1340 checkInsert chan Key_Bool True
1001− testWidget' static check $ do
1341+ testWidget' preSwitchover check $ do
1002 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1342 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1003 liftIO $ dmap `H.shouldBe` keyMap
1343 liftIO $ dmap `H.shouldBe` keyMap
1004 it "handles postBuild correctly" $ runWD $ do
1344 it "handles postBuild correctly" $ runWD $ do
1005 chan <- liftIO newChan
1345 chan <- liftIO newChan
1006− let static = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1346+ let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1007 check xs = do
1347 check xs = do
1008 withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1348 withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1009 checkRemoval chan Key_Int
1349 checkRemoval chan Key_Int
1010 checkInsert chan Key_Char 'B'
1350 checkInsert chan Key_Char 'B'
1011 checkReplace chan Key_Bool True
1351 checkReplace chan Key_Bool True
1012− testWidget' static check $ void $ do
1352+ testWidget' preSwitchover check $ void $ do
1013 pb <- getPostBuild
1353 pb <- getPostBuild
1014 replace <- triggerEventWithChan chan
1354 replace <- triggerEventWithChan chan
1015 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1355 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1053,7 +1393,7 @@ tests withDebugging wdConfig caps _selenium = do
1053 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1393 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1054 liftIO $ dmap `H.shouldBe` keyMap
1394 liftIO $ dmap `H.shouldBe` keyMap
1056− describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
1396+ session' "traverseIntMapWithKeyWithAdjust" $ do
1057 let textKeyInt k = "key" <> T.pack (show k)
1397 let textKeyInt k = "key" <> T.pack (show k)
1058 intMap = IntMap.fromList
1398 intMap = IntMap.fromList
1059 [ (1, "one")
1399 [ (1, "one")
@@ -1099,24 +1439,24 @@ tests withDebugging wdConfig caps _selenium = do
1099 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1439 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1100 xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1440 xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1101 chan <- liftIO newChan
1441 chan <- liftIO newChan
1102− let static = getAndCheckInitialItems intMap
1442+ let preSwitchover = getAndCheckInitialItems intMap
1103 check xs = do
1443 check xs = do
1104 checkInitialItems intMap xs
1444 checkInitialItems intMap xs
1105 checkRemoval chan 1
1445 checkRemoval chan 1
1106 checkReplace chan 2 "deux"
1446 checkReplace chan 2 "deux"
1107 checkInsert chan 4 "four"
1447 checkInsert chan 4 "four"
1108− testWidget' static check $ void $ do
1448+ testWidget' preSwitchover check $ void $ do
1109 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1449 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1110 liftIO $ im `H.shouldBe` intMap
1450 liftIO $ im `H.shouldBe` intMap
1111 xit "handles postBuild correctly" $ runWD $ do
1451 xit "handles postBuild correctly" $ runWD $ do
1112 chan <- liftIO newChan
1452 chan <- liftIO newChan
1113− let static = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1453+ let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1114 check xs = do
1454 check xs = do
1115 withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1455 withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1116 checkRemoval chan 1
1456 checkRemoval chan 1
1117 checkInsert chan 2 "deux"
1457 checkInsert chan 2 "deux"
1118 checkReplace chan 3 "trois"
1458 checkReplace chan 3 "trois"
1119− testWidget' static check $ void $ do
1459+ testWidget' preSwitchover check $ void $ do
1120 pb <- getPostBuild
1460 pb <- getPostBuild
1121 replace <- triggerEventWithChan chan
1461 replace <- triggerEventWithChan chan
1122 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1462 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1160,7 +1500,7 @@ tests withDebugging wdConfig caps _selenium = do
1160 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1500 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1161 liftIO $ dmap `H.shouldBe` intMap
1501 liftIO $ dmap `H.shouldBe` intMap
1163− describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
1503+ session' "traverseDMapWithKeyWithAdjustWithMove" $ do
1164 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)
1165 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1505 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1166 elClass "span" "key" $ text $ textKey2 k
1506 elClass "span" "key" $ text $ textKey2 k
@@ -1172,8 +1512,8 @@ tests withDebugging wdConfig caps _selenium = do
1172 Key2_Char c -> "c" <> T.pack [c]
1512 Key2_Char c -> "c" <> T.pack [c]
1173 checkItem :: WD.Element -> Text -> Text -> WD ()
1513 checkItem :: WD.Element -> Text -> Text -> WD ()
1174 checkItem li k v = do
1514 checkItem li k v = do
1175− shouldContainTextNoRetry k =<< (WD.findElemFrom li (WD.ByClass "key"))
1515+ shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1176− shouldContainTextNoRetry v =<< (WD.findElemFrom li (WD.ByClass "value"))
1516+ shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
1177 checkInitialItems dm xs = do
1517 checkInitialItems dm xs = do
1178 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1518 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1179 forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey2 k) (T.pack $ has @Show k $ show v)
1519 forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey2 k) (T.pack $ has @Show k $ show v)
@@ -1181,6 +1521,9 @@ tests withDebugging wdConfig caps _selenium = do
1181 xs <- WD.findElems (WD.ByTag "li")
1521 xs <- WD.findElems (WD.ByTag "li")
1182 checkInitialItems dm xs
1522 checkInitialItems dm xs
1525+ :: (DMap Key2 Identity -> (WD.Element -> Chan (PatchDMapWithMove Key2 Identity) -> WD ()) -> WD ())
1526+ -> H.SpecM (WdTestSession ()) ()
1184 moveSpec testMove = do
1527 moveSpec testMove = do
1185 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
1528 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
1186 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
1529 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
@@ -1208,19 +1551,19 @@ tests withDebugging wdConfig caps _selenium = do
1209 describe "hydration" $ moveSpec $ \initMap test -> do
1552 describe "hydration" $ moveSpec $ \initMap test -> do
1210 chan <- liftIO newChan
1553 chan <- liftIO newChan
1211− let static = getAndCheckInitialItems initMap
1554+ let preSwitchover = getAndCheckInitialItems initMap
1212 check xs = do
1555 check xs = do
1213 checkInitialItems initMap xs
1556 checkInitialItems initMap xs
1214 body <- getBody
1557 body <- getBody
1215 test body chan
1558 test body chan
1216− testWidget' static check $ void $ do
1559+ testWidget' preSwitchover check $ void $ do
1217 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1560 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1218 liftIO $ assertEqual "DMap" initMap dmap
1561 liftIO $ assertEqual "DMap" initMap dmap
1220 describe "hydration/immediate" $ moveSpec $ \initMap test -> do
1563 describe "hydration/immediate" $ moveSpec $ \initMap test -> do
1221 chan <- liftIO newChan
1564 chan <- liftIO newChan
1222 replace <- liftIO newChan
1565 replace <- liftIO newChan
1223− lock <- liftIO newEmptyMVar
1566+ lock :: MVar () <- liftIO newEmptyMVar
1224 let check = do
1567 let check = do
1225 liftIO $ do
1568 liftIO $ do
1226 writeChan replace ()
1569 writeChan replace ()
@@ -1237,12 +1580,14 @@ tests withDebugging wdConfig caps _selenium = do
1237 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1580 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1238 liftIO $ assertEqual "DMap" initMap dmap
1581 liftIO $ assertEqual "DMap" initMap dmap
1240− describe "hydrating invalid HTML" $ session' $ do
1583+ session' "hydrating invalid HTML" $ do
1241− it "can hydrate list in paragraph" $ runWD $ do
1584+ xit "can hydrate list in paragraph" $ runWD $ do
1242− let static = do
1585+ let preSwitchover = do
1243 checkBodyText "before\ninner\nafter"
1586 checkBodyText "before\ninner\nafter"
1244 -- Two <p> tags should be present
1587 -- Two <p> tags should be present
1245− [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)"
1246 ol <- findElemWithRetry (WD.ByTag "ol")
1591 ol <- findElemWithRetry (WD.ByTag "ol")
1247 shouldContainText "before" p1
1592 shouldContainText "before" p1
1248 shouldContainText "inner" ol
1593 shouldContainText "inner" ol
@@ -1253,7 +1598,8 @@ tests withDebugging wdConfig caps _selenium = do
1253 shouldContainText "before\ninner\nafter" p1
1598 shouldContainText "before\ninner\nafter" p1
1254 elementShouldBeRemoved ol
1599 elementShouldBeRemoved ol
1255 elementShouldBeRemoved p2
1600 elementShouldBeRemoved p2
1256− testWidget' static check $ do
1601+ -- Don't fail fatally when hydration encounters the invalid DOM
1602+ testWidgetDebug' False withDebugging preSwitchover check $ do
1257 -- This is deliberately invalid HTML, the browser will interpret it as
1603 -- This is deliberately invalid HTML, the browser will interpret it as
1258 -- <p>before</p><ol>inner</ol>after<p></p>
1604 -- <p>before</p><ol>inner</ol>after<p></p>
1259 el "p" $ do
1605 el "p" $ do
@@ -1261,6 +1607,29 @@ tests withDebugging wdConfig caps _selenium = do
1261 el "ol" $ text "inner"
1607 el "ol" $ text "inner"
1262 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"
1264data Selenium = Selenium
1633data Selenium = Selenium
1265 { _selenium_portNumber :: PortNumber
1634 { _selenium_portNumber :: PortNumber
1266 , _selenium_stopServer :: IO ()
1635 , _selenium_stopServer :: IO ()
@@ -1328,6 +1697,9 @@ checkTextInId i expected = do
1328findElemWithRetry :: Selector -> WD WD.Element
1697findElemWithRetry :: Selector -> WD WD.Element
1329findElemWithRetry = withRetry . WD.findElem
1698findElemWithRetry = withRetry . WD.findElem
1700+findElemsWithRetry :: Selector -> WD [WD.Element]
1701+findElemsWithRetry = withRetry . WD.findElems
1331getBody :: WD WD.Element
1703getBody :: WD WD.Element
1332getBody = WD.findElem $ WD.ByTag "body"
1704getBody = WD.findElem $ WD.ByTag "body"
@@ -1336,8 +1708,8 @@ withRetry a = wait 300
1336 where wait :: Int -> WD a
1708 where wait :: Int -> WD a
1337 wait 0 = a
1709 wait 0 = a
1338 wait n = try a >>= \case
1710 wait n = try a >>= \case
1339− Left (_ :: SomeException) -> do
1711+ Left (e :: SomeException) -> do
1340− liftIO $ threadDelay 100000
1712+ liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
1341 wait $ n - 1
1713 wait $ n - 1
1342 Right v -> return v
1714 Right v -> return v
@@ -1353,11 +1725,12 @@ testWidgetStaticDebug
1353 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1725 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1354 -- ^ Widget we are testing
1726 -- ^ Widget we are testing
1356−testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
1728+testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
1358-- | TODO: do something about JSExceptions not causing tests to fail
1730-- | TODO: do something about JSExceptions not causing tests to fail
1359testWidgetDebug
1731testWidgetDebug
1361 -> WD ()
1734 -> WD ()
1362 -- ^ 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)
@@ -1365,12 +1738,16 @@ testWidgetDebug
1365 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1738 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1366 -- ^ Widget we are testing
1739 -- ^ Widget we are testing
1368−testWidgetDebug withDebugging beforeJS afterSwitchover =
1741+testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =
1369− testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
1742+ testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)
1744+data HydrationFailedException = HydrationFailedException deriving Show
1745+instance Exception HydrationFailedException
1371-- | TODO: do something about JSExceptions not causing tests to fail
1747-- | TODO: do something about JSExceptions not causing tests to fail
1372testWidgetDebug'
1748testWidgetDebug'
1375 -- ^ 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)
1376 -> (a -> WD b)
1753 -> (a -> WD b)
@@ -1378,7 +1755,7 @@ testWidgetDebug'
1378 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1755 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1379 -- ^ Widget we are testing (contents of body)
1756 -- ^ Widget we are testing (contents of body)
1381−testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1758+testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
1382 let putStrLnDebug :: MonadIO m => Text -> m ()
1759 let putStrLnDebug :: MonadIO m => Text -> m ()
1383 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1760 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1384 staticApp = do
1761 staticApp = do
@@ -1387,9 +1764,10 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1387 bodyWidget
1764 bodyWidget
1388 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1765 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1389 putStrLnDebug "rendering static"
1766 putStrLnDebug "rendering static"
1390− ((), html) <- liftIO $ renderStatic staticApp
1767+ ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1391 putStrLnDebug "rendered static"
1768 putStrLnDebug "rendered static"
1392 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 ()
1393 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1771 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1394 let entryPoint = do
1772 let entryPoint = do
1395 putStrLnDebug "taking waitBeforeJS"
1773 putStrLnDebug "taking waitBeforeJS"
@@ -1401,7 +1779,7 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1401 liftIO $ putMVar waitUntilSwitchover ()
1779 liftIO $ putMVar waitUntilSwitchover ()
1402 putStrLnDebug "put waitUntilSwitchover"
1780 putStrLnDebug "put waitUntilSwitchover"
1403 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1781 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1404− mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
1782+ mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
1405 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1783 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1406 syncPoint
1784 syncPoint
1407 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
1785 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
@@ -1419,23 +1797,26 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1420 -- hSilence to get rid of ConnectionClosed logs
1798 -- hSilence to get rid of ConnectionClosed logs
1421 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1799 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1422− jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
1800+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
1423− jsaddleTid <- liftIO jsaddleWarp
1801+ withAsync' jsaddleWarp $ do
1424− putStrLnDebug "taking waitJSaddle"
1802+ putStrLnDebug "taking waitJSaddle"
1425− liftIO $ takeMVar waitJSaddle
1803+ liftIO $ takeMVar waitJSaddle
1426− putStrLnDebug "opening page"
1804+ putStrLnDebug "opening page"
1427− WD.openPage $ "http://localhost:" <> show jsaddlePort
1805+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1428− putStrLnDebug "running beforeJS"
1806+ putStrLnDebug "running beforeJS"
1429− a <- beforeJS
1807+ a <- beforeJS
1430− putStrLnDebug "putting waitBeforeJS"
1808+ putStrLnDebug "putting waitBeforeJS"
1431− liftIO $ putMVar waitBeforeJS ()
1809+ liftIO $ putMVar waitBeforeJS ()
1432− putStrLnDebug "taking waitUntilSwitchover"
1810+ putStrLnDebug "taking waitUntilSwitchover"
1433− liftIO $ takeMVar waitUntilSwitchover
1811+ liftIO $ takeMVar waitUntilSwitchover
1434− putStrLnDebug "running afterSwitchover"
1812+ putStrLnDebug "running afterSwitchover"
1435− b <- afterSwitchover a
1813+ afterSwitchover a
1436− putStrLnDebug "killing jsaddle thread"
1814+
1437− liftIO $ killThread jsaddleTid
1815+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
1438− return b
1816+withAsync' f g = bracket
1817+ (liftIO $ Async.async f)
1818+ (liftIO . Async.uninterruptibleCancel)
1440data Key2 a where
1821data Key2 a where
1441 Key2_Int :: Int -> Key2 Int
1822 Key2_Int :: Int -> Key2 Int
@@ -1445,12 +1826,3 @@ deriveGEq ''Key2
1445deriveGCompare ''Key2
1826deriveGCompare ''Key2
1446deriveGShow ''Key2
1827deriveGShow ''Key2
1447deriveArgDict ''Key2
1828deriveArgDict ''Key2
1449−instance ShowTag Key2 Identity where
1450− showTaggedPrec = \case
1451− Key2_Int _ -> showsPrec
1452− Key2_Char _ -> showsPrec
1454−instance EqTag Key2 Identity where
1455− eqTagged (Key2_Int _) (Key2_Int _) = (==)
1456− eqTagged (Key2_Char _) (Key2_Char _) = (==)