@@ -1,9 +1,12 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE StandaloneDeriving #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE UndecidableInstances #-}
2{-# LANGUAGE ConstraintKinds #-}
6{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE OverloadedStrings #-}
12{-# LANGUAGE OverloadedStrings #-}
@@ -11,43 +14,27 @@
11{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RecursiveDo #-}
15{-# LANGUAGE RecursiveDo #-}
13{-# LANGUAGE ScopedTypeVariables #-}
16{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TemplateHaskell #-}
17{-# LANGUAGE TemplateHaskell #-}
16{-# LANGUAGE TupleSections #-}
18{-# LANGUAGE TupleSections #-}
17{-# LANGUAGE TypeApplications #-}
19{-# LANGUAGE TypeApplications #-}
18{-# LANGUAGE TypeFamilies #-}
20{-# 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)
32import Control.Concurrent
22import Control.Concurrent
33−import qualified Control.Concurrent.Async as Async
34−import Control.Lens.Operators
35−import Control.Monad hiding (fail)
23+import Control.Monad
36import Control.Monad.Catch
24import Control.Monad.Catch
37−import Control.Monad.Fail
38import Control.Monad.Fix
25import Control.Monad.Fix
39import Control.Monad.IO.Class
26import Control.Monad.IO.Class
40import Control.Monad.Ref
27import Control.Monad.Ref
41import Data.Constraint.Extras
28import Data.Constraint.Extras
42import Data.Constraint.Extras.TH
29import Data.Constraint.Extras.TH
43import Data.Dependent.Map (DMap)
30import Data.Dependent.Map (DMap)
44−import Data.Dependent.Sum (DSum(..), (==>))
31+import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
32+--import Data.Foldable (traverse_)
45import Data.Functor.Identity
33import Data.Functor.Identity
46import Data.Functor.Misc
34import Data.Functor.Misc
47import Data.GADT.Compare.TH
35import Data.GADT.Compare.TH
48import Data.GADT.Show.TH
36import Data.GADT.Show.TH
49import Data.IORef (IORef)
37import Data.IORef (IORef)
50−import Data.List (sort)
51import Data.Maybe
38import Data.Maybe
52import Data.Proxy
39import Data.Proxy
53import Data.Text (Text)
40import Data.Text (Text)
@@ -58,7 +45,6 @@ import Network.Socket
58import Network.Wai
45import Network.Wai
59import Network.WebSockets
46import Network.WebSockets
60import Reflex.Dom.Core
47import Reflex.Dom.Core
61−import Reflex.Dom.Widget.Input (dropdown)
62import Reflex.Patch.DMapWithMove
48import Reflex.Patch.DMapWithMove
63import System.Directory
49import System.Directory
64import System.Environment
50import System.Environment
@@ -66,14 +52,12 @@ import System.IO (stderr)
66import System.IO.Silently
52import System.IO.Silently
67import System.IO.Temp
53import System.IO.Temp
68import System.Process
54import System.Process
69−import System.Which (staticWhich)
70−import qualified Test.HUnit as HUnit
55+import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
71import qualified Test.Hspec as H
56import qualified Test.Hspec as H
72−import qualified Test.Hspec.Core.Spec as H
73import Test.Hspec (xit)
57import Test.Hspec (xit)
74−import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
58+import Test.Hspec.WebDriver hiding (runWD, click, uploadFile)
75import qualified Test.Hspec.WebDriver as WD
59import qualified Test.Hspec.WebDriver as WD
76−import Test.WebDriver (WD(..))
60+import Test.WebDriver (WD)
78import qualified Data.ByteString.Lazy as LBS
62import qualified Data.ByteString.Lazy as LBS
79import qualified Data.Dependent.Map as DMap
63import qualified Data.Dependent.Map as DMap
@@ -89,32 +73,19 @@ import qualified Test.WebDriver.Capabilities as WD
89import Test.Util.ChromeFlags
73import Test.Util.ChromeFlags
90import Test.Util.UnshareNetwork
74import Test.Util.UnshareNetwork
92−-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
93−deriving instance MonadMask WD
96−chromium = $(staticWhich "chromium")
98seleniumPort, jsaddlePort :: PortNumber
76seleniumPort, jsaddlePort :: PortNumber
99seleniumPort = 8000
77seleniumPort = 8000
100jsaddlePort = 8001
78jsaddlePort = 8001
102-- TODO Remove orphan
80-- TODO Remove orphan
103−instance MonadRef WD where
81+deriving instance MonadRef WD
104− type Ref WD = Ref IO
105− newRef = WD . newRef
106− readRef = WD . readRef
107− writeRef r = WD . writeRef r
109assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
83assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
110−assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
84+assertEqual a b = liftIO . HUnit.assertEqual a b
112assertFailure :: MonadIO m => String -> m ()
86assertFailure :: MonadIO m => String -> m ()
113assertFailure = liftIO . HUnit.assertFailure
87assertFailure = liftIO . HUnit.assertFailure
115−assertBool :: (MonadIO m) => String -> Bool -> m ()
116−assertBool msg bool = liftIO $ HUnit.assertBool msg bool
118chromeConfig :: Text -> [Text] -> WD.WDConfig
89chromeConfig :: Text -> [Text] -> WD.WDConfig
119chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
90chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
@@ -141,26 +112,35 @@ deriveGEq ''DKey
141deriveGCompare ''DKey
112deriveGCompare ''DKey
142deriveGShow ''DKey
113deriveGShow ''DKey
144−deriving instance MonadFail WD
115+instance ShowTag DKey Identity where
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 = (==)
146main :: IO ()
126main :: IO ()
148− unshareNetwork
128+ unshareNetork
149 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
129 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
150 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
130 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
151 withSeleniumServer $ \selenium -> do
131 withSeleniumServer $ \selenium -> do
152− let browserPath = T.strip $ T.pack chromium
132+ browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
153 when (T.null browserPath) $ fail "No browser found"
133 when (T.null browserPath) $ fail "No browser found"
154− withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
134+ withDebugging <- isJust <$> lookupEnv "DEBUG"
155 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
135 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
156 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
136 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
157− hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
137+ hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
159−tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
139+tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
160tests withDebugging wdConfig caps _selenium = do
140tests withDebugging wdConfig caps _selenium = do
161 let putStrLnDebug :: MonadIO m => Text -> m ()
141 let putStrLnDebug :: MonadIO m => Text -> m ()
162 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
142 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
163− session' t = sessionWith wdConfig t . using caps
143+ session' = sessionWith wdConfig "" . using (map (,"") caps)
164 runWD m = runWDOptions (WdOptions False) $ do
144 runWD m = runWDOptions (WdOptions False) $ do
165 putStrLnDebug "before"
145 putStrLnDebug "before"
@@ -169,10 +149,10 @@ tests withDebugging wdConfig caps _selenium = do
169 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
149 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
170 testWidgetStatic = testWidgetStaticDebug withDebugging
150 testWidgetStatic = testWidgetStaticDebug withDebugging
171 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
151 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
172− testWidget = testWidgetDebug True withDebugging
152+ testWidget = testWidgetDebug withDebugging
173 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
153 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
174− testWidget' = testWidgetDebug' True withDebugging
154+ testWidget' = testWidgetDebug' withDebugging
175− session' "text" $ do
155+ describe "text" $ session' $ do
176 it "works" $ runWD $ do
156 it "works" $ runWD $ do
177 testWidgetStatic (checkBodyText "hello world") $ do
157 testWidgetStatic (checkBodyText "hello world") $ do
178 text "hello world"
158 text "hello world"
@@ -233,7 +213,7 @@ tests withDebugging wdConfig caps _selenium = do
233 click <- button ""
213 click <- button ""
234 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
214 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
236− session' "element" $ do
216+ describe "element" $ session' $ do
237 it "works with domEvent Click" $ runWD $ do
217 it "works with domEvent Click" $ runWD $ do
238 clickedRef <- liftIO $ newRef False
218 clickedRef <- liftIO $ newRef False
239 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
219 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
@@ -296,86 +276,36 @@ tests withDebugging wdConfig caps _selenium = do
296 (e, ()) <- element "div" conf $ text "hello world"
276 (e, ()) <- element "div" conf $ text "hello world"
297 let click = domEvent Click e
277 let click = domEvent Click e
298 return ()
278 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"
300− session' "inputElement" $ do
287+ describe "inputElement" $ do
301− describe "static renderer" $ do
288+ describe "hydration" $ session' $ do
302− it "sets value attribute" $ runWD $ do
303− let checkStatic = do
304− e <- findElemWithRetry $ WD.ByTag "input"
305− WD.attr e "value" `shouldBeWithRetryM` Just "test"
307− checkHydrated e = do
308− WD.attr e "value" `shouldBeWithRetryM` Just "test"
309− testWidget' checkStatic checkHydrated $ void $ inputElement $ def
310− & inputElementConfig_initialValue .~ "test"
311− it "updates value attribute at postBuild" $ runWD $ do
312− let checkStatic = do
313− e <- findElemWithRetry $ WD.ByTag "input"
314− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
316− checkHydrated e = do
317− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
318− testWidget' checkStatic checkHydrated $ do
320− _ <- inputElement $ def
321− & inputElementConfig_initialValue .~ "test"
322− & inputElementConfig_setValue .~ ("test-updated" <$ pb)
324− it "sets checked attr appropriately" $ runWD $ do
325− setCheckedChan <- liftIO newChan
326− let checkStatic = do
327− e <- findElemWithRetry $ WD.ByTag "input"
328− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
331− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
333− WD.click e -- Click to uncheck
334− WD.attr e "checked" `shouldBeWithRetryM` Nothing
335− liftIO $ writeChan setCheckedChan True -- Programatically check the checkbox
336− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
337− testWidget' checkStatic checkValue $ do
338− setChecked <- triggerEventWithChan setCheckedChan
339− _ <- inputElement $ def
340− & initialAttributes .~ "type" =: "checkbox"
341− & inputElementConfig_initialChecked .~ True
342− & inputElementConfig_setChecked .~ setChecked
344− it "sets checked attr appropriately at postbuild" $ runWD $ do
345− let checkStatic = do
346− e <- findElemWithRetry $ WD.ByTag "input"
347− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
350− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
351− testWidget' checkStatic checkValue $ do
353− _ <- inputElement $ def
354− & initialAttributes .~ "type" =: "checkbox"
355− & inputElementConfig_initialChecked .~ False
356− & inputElementConfig_setChecked .~ (True <$ pb)
358− describe "hydration" $ do
359 it "doesn't wipe user input when switching over" $ runWD $ do
289 it "doesn't wipe user input when switching over" $ runWD $ do
360− inputRef <- newRef ("hello " :: Text)
290+ inputRef <- newRef ("" :: Text)
361 testWidget'
291 testWidget'
363 e <- findElemWithRetry $ WD.ByTag "input"
293 e <- findElemWithRetry $ WD.ByTag "input"
364− WD.sendKeys "world" e
294+ WD.sendKeys "hello world" e
366 (\e -> do
296 (\e -> do
367 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
297 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
368− WD.click =<< findElemWithRetry (WD.ByTag "button")
298+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
369 readRef inputRef `shouldBeWithRetryM` "hello world"
299 readRef inputRef `shouldBeWithRetryM` "hello world"
371− e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
301+ e <- inputElement def
372 click <- button "save"
302 click <- button "save"
373 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
303 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
374 it "captures user input after switchover" $ runWD $ do
304 it "captures user input after switchover" $ runWD $ do
375 inputRef <- newRef ("" :: Text)
305 inputRef <- newRef ("" :: Text)
376 let checkValue = do
306 let checkValue = do
377− WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
307+ WD.sendKeys "hello world" =<< (findElemWithRetry $ WD.ByTag "input")
378− WD.click =<< findElemWithRetry (WD.ByTag "button")
308+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
379 readRef inputRef `shouldBeWithRetryM` "hello world"
309 readRef inputRef `shouldBeWithRetryM` "hello world"
380 testWidget (pure ()) checkValue $ do
310 testWidget (pure ()) checkValue $ do
381 e <- inputElement def
311 e <- inputElement def
@@ -425,56 +355,31 @@ tests withDebugging wdConfig caps _selenium = do
425 checkedByUIRef <- newRef False
355 checkedByUIRef <- newRef False
426 checkedRef <- newRef False
356 checkedRef <- newRef False
427 setCheckedChan <- liftIO newChan
357 setCheckedChan <- liftIO newChan
428− let checkStatic = do
429− e <- findElemWithRetry $ WD.ByTag "input"
430− WD.attr e "checked" `shouldBeWithRetryM` Nothing
432− checkValue e = do
358+ let checkValue = do
433 readRef checkedByUIRef `shouldBeWithRetryM` False
359 readRef checkedByUIRef `shouldBeWithRetryM` False
434 readRef checkedRef `shouldBeWithRetryM` False
360 readRef checkedRef `shouldBeWithRetryM` False
435− WD.attr e "checked" `shouldBeWithRetryM` Nothing
361+ e <- findElemWithRetry $ WD.ByTag "input"
436 WD.moveToCenter e
362 WD.moveToCenter e
437 WD.click e
363 WD.click e
438 readRef checkedByUIRef `shouldBeWithRetryM` True
364 readRef checkedByUIRef `shouldBeWithRetryM` True
439 readRef checkedRef `shouldBeWithRetryM` True
365 readRef checkedRef `shouldBeWithRetryM` True
440− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
441 liftIO $ writeChan setCheckedChan False
366 liftIO $ writeChan setCheckedChan False
442 readRef checkedByUIRef `shouldBeWithRetryM` True
367 readRef checkedByUIRef `shouldBeWithRetryM` True
443 readRef checkedRef `shouldBeWithRetryM` False
368 readRef checkedRef `shouldBeWithRetryM` False
444− WD.attr e "checked" `shouldBeWithRetryM` Nothing
445− testWidget' checkStatic checkValue $ do
369+ testWidget (pure ()) checkValue $ do
446 setChecked <- triggerEventWithChan setCheckedChan
370 setChecked <- triggerEventWithChan setCheckedChan
447 e <- inputElement $ def
371 e <- inputElement $ def
448 & initialAttributes .~ "type" =: "checkbox"
372 & initialAttributes .~ "type" =: "checkbox"
449 & inputElementConfig_setChecked .~ setChecked
373 & inputElementConfig_setChecked .~ setChecked
450 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
374 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
451 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
375 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
452− it "respects user updates to checked which happen before hydration" $ runWD $ do
453− checkedByUIRef <- newRef False
454− checkedRef <- newRef False
455− let checkStatic = do
456− e <- findElemWithRetry $ WD.ByTag "input"
457− WD.attr e "checked" `shouldBeWithRetryM` Nothing
460− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
463− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
464− readRef checkedByUIRef `shouldBeWithRetryM` True
465− readRef checkedRef `shouldBeWithRetryM` True
466− testWidget' checkStatic checkValue $ do
467− e <- inputElement $ def
468− & initialAttributes .~ "type" =: "checkbox"
469− performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
470− performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
471 it "captures file uploads" $ runWD $ do
376 it "captures file uploads" $ runWD $ do
472 filesRef :: IORef [Text] <- newRef []
377 filesRef :: IORef [Text] <- newRef []
473 let uploadFile = do
378 let uploadFile = do
474 e <- findElemWithRetry $ WD.ByTag "input"
379 e <- findElemWithRetry $ WD.ByTag "input"
475 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
380 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
476 WD.sendKeys (T.pack path) e
381 WD.sendKeys (T.pack path) e
477− WD.click =<< findElemWithRetry (WD.ByTag "button")
382+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
478 liftIO $ removeFile path
383 liftIO $ removeFile path
479 readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
384 readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
480 testWidget (pure ()) uploadFile $ do
385 testWidget (pure ()) uploadFile $ do
@@ -483,122 +388,13 @@ tests withDebugging wdConfig caps _selenium = do
483 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
388 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
484 names <- liftJSM $ traverse File.getName fs
389 names <- liftJSM $ traverse File.getName fs
485 liftIO $ writeRef filesRef names
390 liftIO $ writeRef filesRef names
486− it "fires _input event if the user altered the value before hydration" $ runWD $ do
391+
487− input <- newRef ("" :: Text)
488− update <- newRef ("" :: Text)
489− let checkStatic = do
490− e <- findElemWithRetry $ WD.ByTag "input"
491− WD.attr e "value" `shouldBeWithRetryM` Just ""
492− WD.sendKeys "test" e
493− WD.attr e "value" `shouldBeWithRetryM` Just "test"
495− checkHydrated e = do
496− WD.attr e "value" `shouldBeWithRetryM` Just "test"
497− readRef input `shouldBeWithRetryM` "test"
498− readRef update `shouldBeWithRetryM` "test"
499− testWidget' checkStatic checkHydrated $ do
500− e <- inputElement def
501− performEvent_ $ liftIO . writeRef input <$> _inputElement_input e
502− performEvent_ $ liftIO . writeRef update <$> updated (_inputElement_value e)
503− it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
504− input <- newRef (Nothing :: Maybe Text)
505− let checkStatic = do
506− e <- findElemWithRetry $ WD.ByTag "input"
507− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
509− checkHydrated e = do
510− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
511− readRef input `shouldBeWithRetryM` Nothing
512− testWidget' checkStatic checkHydrated $ do
514− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
515− performEvent_ $ liftIO . writeRef input . Just <$> _inputElement_input e
516− it "SSR produces correct DOM based on inputElement values when setValue happens at postBuild" $ runWD $ do
518− input <- findElemWithRetry $ WD.ByTag "input"
519− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
520− p <- findElemWithRetry (WD.ByTag "p")
521− shouldContainText "pb" p
522− testWidget checkBoth checkBoth $ do
524− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
525− el "p" $ dynText $ _inputElement_value e
526− it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
527− let checkStatic = do
528− input <- findElemWithRetry $ WD.ByTag "input"
529− h2_value <- findElemWithRetry (WD.ByTag "h2")
530− h3_input <- findElemWithRetry (WD.ByTag "h3")
531− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
532− shouldContainText "pb" h2_value
533− shouldContainText "" h3_input
534− WD.sendKeys "abc" input
535− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
536− shouldContainText "pb" h2_value
537− shouldContainText "" h3_input
538− pure (input, h2_value, h3_input)
539− checkHydrated (input, h2_value, h3_input) = do
540− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
541− shouldContainText "pbabc" h3_input
542− shouldContainText "pbabc pb" h2_value
544− testWidget' checkStatic checkHydrated $ do
546− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
547− el "h1" $ dynText $ _inputElement_value e
548− el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _inputElement_value e
549− el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _inputElement_input e
550− it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
551− let checkStatic = do
552− input <- findElemWithRetry $ WD.ByTag "input"
553− p <- findElemWithRetry (WD.ByTag "p")
554− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
555− shouldContainText "pb" p
556− WD.sendKeys "abc" input
557− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
558− shouldContainText "pb" p -- It won't be updated yet
560− checkHydrated (input, p) = do
561− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
562− shouldContainText "pbabc" p
564− testWidget' checkStatic checkHydrated $ do
566− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
567− el "p" $ dynText $ _inputElement_value e
568− it "input event and (updated value) fire correctly when both setValue AND user updated value happen before switchover" $ runWD $ do
569− valRef <- newRef ([] :: [Text])
570− inputRef <- newRef ([] :: [Text])
571− let consRef ref a = liftIO $ atomicModifyRef ref $ \as -> (a:as, ())
573− input <- findElemWithRetry $ WD.ByTag "input"
574− p <- findElemWithRetry (WD.ByTag "p")
575− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
576− shouldContainText "pb" p
577− WD.sendKeys "abc" input
578− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
579− shouldContainText "pb" p -- It won't be updated yet
580− readRef inputRef `shouldBeWithRetryM` [] -- Should never fire input ref during SSR
581− readRef valRef `shouldBeWithRetryM` ["pb"]
583− checkHydrated (input, p) = do
584− readRef inputRef `shouldBeWithRetryM` ["pbabc"]
585− readRef valRef `shouldBeWithRetryM` ["pbabc", "pb"]
586− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
587− shouldContainText "pbabc" p
589− testWidget' checkStatic checkHydrated $ do
590− liftIO $ writeRef valRef []
592− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
593− el "p" $ dynText $ _inputElement_value e
594− performEvent_ $ consRef valRef <$> updated (_inputElement_value e)
595− performEvent_ $ consRef inputRef <$> _inputElement_input e
596− describe "hydration/immediate" $ do
392+ describe "hydration/immediate" $ session' $ do
597 it "captures user input after switchover" $ runWD $ do
393 it "captures user input after switchover" $ runWD $ do
598 inputRef :: IORef Text <- newRef ""
394 inputRef :: IORef Text <- newRef ""
599 let checkValue = do
395 let checkValue = do
600− WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
396+ WD.sendKeys "hello world" =<< (findElemWithRetry $ WD.ByTag "input")
601− WD.click =<< findElemWithRetry (WD.ByTag "button")
397+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
602 readRef inputRef `shouldBeWithRetryM` "hello world"
398 readRef inputRef `shouldBeWithRetryM` "hello world"
603 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
399 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
604 e <- inputElement def
400 e <- inputElement def
@@ -615,6 +411,7 @@ tests withDebugging wdConfig caps _selenium = do
615 e <- inputElement def
411 e <- inputElement def
616 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
412 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
617 it "sets value appropriately" $ runWD $ do
413 it "sets value appropriately" $ runWD $ do
414+ putStrLnDebug "sets value appropriately"
618 valueByUIRef :: IORef Text <- newRef ""
415 valueByUIRef :: IORef Text <- newRef ""
619 valueRef :: IORef Text <- newRef ""
416 valueRef :: IORef Text <- newRef ""
620 setValueChan :: Chan Text <- liftIO newChan
417 setValueChan :: Chan Text <- liftIO newChan
@@ -635,69 +432,77 @@ tests withDebugging wdConfig caps _selenium = do
635 performEvent_ $ liftIO . writeRef valueByUIRef <$> _inputElement_input e
432 performEvent_ $ liftIO . writeRef valueByUIRef <$> _inputElement_input e
636 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
433 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
637 it "sets checked appropriately" $ runWD $ do
434 it "sets checked appropriately" $ runWD $ do
435+ putStrLnDebug "sets checked appropriately"
638 checkedByUIRef <- newRef False
436 checkedByUIRef <- newRef False
639 checkedRef <- newRef False
437 checkedRef <- newRef False
640 setCheckedChan <- liftIO newChan
438 setCheckedChan <- liftIO newChan
641 let checkValue = do
439 let checkValue = do
642 readRef checkedByUIRef `shouldBeWithRetryM` False
441 readRef checkedByUIRef `shouldBeWithRetryM` False
643 readRef checkedRef `shouldBeWithRetryM` False
443 readRef checkedRef `shouldBeWithRetryM` False
644 e <- findElemWithRetry $ WD.ByTag "input"
445 e <- findElemWithRetry $ WD.ByTag "input"
645 WD.moveToCenter e
447 WD.moveToCenter e
646 WD.click e
449 WD.click e
647 readRef checkedByUIRef `shouldBeWithRetryM` True
451 readRef checkedByUIRef `shouldBeWithRetryM` True
648 readRef checkedRef `shouldBeWithRetryM` True
453 readRef checkedRef `shouldBeWithRetryM` True
649 liftIO $ writeChan setCheckedChan False
455 liftIO $ writeChan setCheckedChan False
650 readRef checkedByUIRef `shouldBeWithRetryM` True
457 readRef checkedByUIRef `shouldBeWithRetryM` True
651 readRef checkedRef `shouldBeWithRetryM` False
459 readRef checkedRef `shouldBeWithRetryM` False
652 testWidget (pure ()) checkValue $ do
461 testWidget (pure ()) checkValue $ do
653 setChecked <- triggerEventWithChan setCheckedChan
463 setChecked <- triggerEventWithChan setCheckedChan
654 prerender_ (pure ()) $ do
465 prerender_ (pure ()) $ do
655 e <- inputElement $ def
467 e <- inputElement $ def
656 & initialAttributes .~ "type" =: "checkbox"
468 & initialAttributes .~ "type" =: "checkbox"
657 & inputElementConfig_setChecked .~ setChecked
469 & inputElementConfig_setChecked .~ setChecked
658 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
471 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
659 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
473 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
660 it "captures file uploads" $ runWD $ do
475 it "captures file uploads" $ runWD $ do
661 filesRef :: IORef [Text] <- newRef []
476 filesRef :: IORef [Text] <- newRef []
662 let uploadFile = do
477 let uploadFile = do
663 e <- findElemWithRetry $ WD.ByTag "input"
479 e <- findElemWithRetry $ WD.ByTag "input"
664 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
481 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
665 WD.sendKeys (T.pack path) e
483 WD.sendKeys (T.pack path) e
666− WD.click =<< findElemWithRetry (WD.ByTag "button")
485+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
667 liftIO $ removeFile path
487 liftIO $ removeFile path
668 readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
489 readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
669 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
491 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
670 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
493 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
671 click <- button "save"
495 click <- button "save"
672 performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
497 performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
673 names <- liftJSM $ traverse File.getName fs
499 names <- liftJSM $ traverse File.getName fs
674 liftIO $ writeRef filesRef names
501 liftIO $ writeRef filesRef names
676− session' "textAreaElement" $ do
504+ describe "textAreaElement" $ do
677− describe "static renderer" $ do
678− it "sets value attribute" $ runWD $ do
679− let checkStatic = do
680− e <- findElemWithRetry $ WD.ByTag "textarea"
681− WD.attr e "value" `shouldBeWithRetryM` Just "test"
683− checkHydrated e = do
684− WD.attr e "value" `shouldBeWithRetryM` Just "test"
685− testWidget' checkStatic checkHydrated $ void $ textAreaElement $ def
686− & textAreaElementConfig_initialValue .~ "test"
687− it "updates value attribute at postBuild" $ runWD $ do
688− let checkStatic = do
689− e <- findElemWithRetry $ WD.ByTag "textarea"
690− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
692− checkHydrated e = do
693− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
694− testWidget' checkStatic checkHydrated $ do
696− _ <- textAreaElement $ def
697− & textAreaElementConfig_initialValue .~ "test"
698− & textAreaElementConfig_setValue .~ ("test-updated" <$ pb)
700− describe "hydration" $ do
505+ describe "hydration" $ session' $ do
701 it "doesn't wipe user input when switching over" $ runWD $ do
506 it "doesn't wipe user input when switching over" $ runWD $ do
702 inputRef <- newRef ("" :: Text)
507 inputRef <- newRef ("" :: Text)
703 testWidget'
508 testWidget'
@@ -716,8 +521,8 @@ tests withDebugging wdConfig caps _selenium = do
716 it "captures user input after switchover" $ runWD $ do
521 it "captures user input after switchover" $ runWD $ do
717 inputRef <- newRef ("" :: Text)
522 inputRef <- newRef ("" :: Text)
718 let checkValue = do
523 let checkValue = do
719− WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "textarea")
524+ WD.sendKeys "hello world" =<< (findElemWithRetry $ WD.ByTag "textarea")
720− WD.click =<< findElemWithRetry (WD.ByTag "button")
525+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
721 readRef inputRef `shouldBeWithRetryM` "hello world"
526 readRef inputRef `shouldBeWithRetryM` "hello world"
722 testWidget (pure ()) checkValue $ do
527 testWidget (pure ()) checkValue $ do
723 e <- textAreaElement def
528 e <- textAreaElement def
@@ -763,90 +568,8 @@ tests withDebugging wdConfig caps _selenium = do
763 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
568 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
764 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
569 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
765 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
570 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
766− it "fires _input event if the user altered the value before hydration" $ runWD $ do
767− textarea <- newRef ("" :: Text)
768− update <- newRef ("" :: Text)
769− let checkStatic = do
770− e <- findElemWithRetry $ WD.ByTag "textarea"
771− WD.attr e "value" `shouldBeWithRetryM` Just ""
772− WD.sendKeys "test" e
773− WD.attr e "value" `shouldBeWithRetryM` Just "test"
775− checkHydrated e = do
776− WD.attr e "value" `shouldBeWithRetryM` Just "test"
777− readRef textarea `shouldBeWithRetryM` "test"
778− readRef update `shouldBeWithRetryM` "test"
779− testWidget' checkStatic checkHydrated $ do
780− e <- textAreaElement def
781− performEvent_ $ liftIO . writeRef textarea <$> _textAreaElement_input e
782− performEvent_ $ liftIO . writeRef update <$> updated (_textAreaElement_value e)
783− it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
784− textarea <- newRef (Nothing :: Maybe Text)
785− let checkStatic = do
786− e <- findElemWithRetry $ WD.ByTag "textarea"
787− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
789− checkHydrated e = do
790− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
791− readRef textarea `shouldBeWithRetryM` Nothing
792− testWidget' checkStatic checkHydrated $ do
794− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
795− performEvent_ $ liftIO . writeRef textarea . Just <$> _textAreaElement_input e
796− it "SSR produces correct DOM based on textAreaElement values when setValue happens at postBuild" $ runWD $ do
798− textarea <- findElemWithRetry $ WD.ByTag "textarea"
799− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
800− p <- findElemWithRetry (WD.ByTag "p")
801− shouldContainText "pb" p
802− testWidget checkBoth checkBoth $ do
804− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
805− el "p" $ dynText $ _textAreaElement_value e
806− it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
807− let checkStatic = do
808− textarea <- findElemWithRetry $ WD.ByTag "textarea"
809− h2_value <- findElemWithRetry (WD.ByTag "h2")
810− h3_input <- findElemWithRetry (WD.ByTag "h3")
811− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
812− shouldContainText "pb" h2_value
813− shouldContainText "" h3_input
814− WD.sendKeys "abc" textarea
815− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
816− shouldContainText "pb" h2_value
817− shouldContainText "" h3_input
818− pure (textarea, h2_value, h3_input)
819− checkHydrated (textarea, h2_value, h3_input) = do
820− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
821− shouldContainText "pbabc" h3_input
822− shouldContainText "pbabc pb" h2_value
824− testWidget' checkStatic checkHydrated $ do
826− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
827− el "h1" $ dynText $ _textAreaElement_value e
828− el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _textAreaElement_value e
829− el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _textAreaElement_input e
830− it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
831− let checkStatic = do
832− textarea <- findElemWithRetry $ WD.ByTag "textarea"
833− p <- findElemWithRetry (WD.ByTag "p")
834− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
835− shouldContainText "pb" p
836− WD.sendKeys "abc" textarea
837− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
838− shouldContainText "pb" p -- It won't be updated yet
840− checkHydrated (textarea, p) = do
841− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
842− shouldContainText "pbabc" p
844− testWidget' checkStatic checkHydrated $ do
846− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
847− el "p" $ dynText $ _textAreaElement_value e
849− describe "hydration/immediate" $ do
572+ describe "hydration/immediate" $ session' $ do
850 it "captures user input after switchover" $ runWD $ do
573 it "captures user input after switchover" $ runWD $ do
851 inputRef :: IORef Text <- newRef ""
574 inputRef :: IORef Text <- newRef ""
852 let checkValue = do
575 let checkValue = do
@@ -888,24 +611,24 @@ tests withDebugging wdConfig caps _selenium = do
888 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
611 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
889 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
612 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
891− session' "selectElement" $ do
614+ describe "selectElement" $ do
892 let options :: DomBuilder t m => m ()
615 let options :: DomBuilder t m => m ()
893 options = do
616 options = do
894 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
617 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
895 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
618 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
896 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
619 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
897− describe "hydration" $ do
620+ describe "hydration" $ session' $ do
898 it "sets initial value correctly" $ runWD $ do
621 it "sets initial value correctly" $ runWD $ do
899 inputRef <- newRef ("" :: Text)
622 inputRef <- newRef ("" :: Text)
900 let setup = do
623 let setup = do
901 e <- findElemWithRetry $ WD.ByTag "select"
624 e <- findElemWithRetry $ WD.ByTag "select"
902 assertAttr e "value" (Just "three")
625 assertAttr e "value" (Just "three")
903− WD.click =<< findElemWithRetry (WD.ById "two")
626+ WD.click =<< (findElemWithRetry $ WD.ById "two")
905 check e = do
628 check e = do
906 assertAttr e "value" (Just "two")
629 assertAttr e "value" (Just "two")
907 readRef inputRef `shouldBeWithRetryM` "three"
630 readRef inputRef `shouldBeWithRetryM` "three"
908− WD.click =<< findElemWithRetry (WD.ByTag "button")
631+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
909 assertAttr e "value" (Just "two")
632 assertAttr e "value" (Just "two")
910 readRef inputRef `shouldBeWithRetryM` "two"
633 readRef inputRef `shouldBeWithRetryM` "two"
911 testWidget' setup check $ do
634 testWidget' setup check $ do
@@ -918,9 +641,9 @@ tests withDebugging wdConfig caps _selenium = do
918 let checkValue = do
641 let checkValue = do
919 e <- findElemWithRetry $ WD.ByTag "select"
642 e <- findElemWithRetry $ WD.ByTag "select"
920 assertAttr e "value" (Just "one")
643 assertAttr e "value" (Just "one")
921− WD.click =<< findElemWithRetry (WD.ById "two")
644+ WD.click =<< (findElemWithRetry $ WD.ById "two")
922 assertAttr e "value" (Just "two")
645 assertAttr e "value" (Just "two")
923− WD.click =<< findElemWithRetry (WD.ByTag "button")
646+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
924 readRef inputRef `shouldBeWithRetryM` "two"
647 readRef inputRef `shouldBeWithRetryM` "two"
925 testWidget (pure ()) checkValue $ do
648 testWidget (pure ()) checkValue $ do
926 (e, ()) <- selectElement def options
649 (e, ()) <- selectElement def options
@@ -968,7 +691,7 @@ tests withDebugging wdConfig caps _selenium = do
968 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
691 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
969 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
692 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
971− describe "hydration/immediate" $ do
694+ describe "hydration/immediate" $ session' $ do
972 it "captures user input after switchover" $ runWD $ do
695 it "captures user input after switchover" $ runWD $ do
973 inputRef :: IORef Text <- newRef ""
696 inputRef :: IORef Text <- newRef ""
974 let checkValue = do
697 let checkValue = do
@@ -1014,7 +737,7 @@ tests withDebugging wdConfig caps _selenium = do
1014 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
737 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
1015 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
738 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
1017− session' "prerender" $ do
740+ describe "prerender" $ session' $ do
1018 it "works in simple case" $ runWD $ do
741 it "works in simple case" $ runWD $ do
1019 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
742 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
1020 prerender_ (text "One") (text "Two")
743 prerender_ (text "One") (text "Two")
@@ -1059,9 +782,9 @@ tests withDebugging wdConfig caps _selenium = do
1059 pb <- getPostBuild
782 pb <- getPostBuild
1060 performEvent_ $ liftIO (putMVar lock ()) <$ pb
783 performEvent_ $ liftIO (putMVar lock ()) <$ pb
1061 it "result Dynamic is updated *after* switchover" $ runWD $ do
784 it "result Dynamic is updated *after* switchover" $ runWD $ do
1062− let preSwitchover = checkBodyText "PostBuild"
785+ let static = checkBodyText "PostBuild"
1063 check = checkBodyText "Client"
786 check = checkBodyText "Client"
1064− testWidget preSwitchover check $ void $ do
787+ testWidget static check $ void $ do
1065 d <- prerender (pure "Initial") (pure "Client")
788 d <- prerender (pure "Initial") (pure "Client")
1066 pb <- getPostBuild
789 pb <- getPostBuild
1067 initial <- sample $ current d
790 initial <- sample $ current d
@@ -1069,30 +792,21 @@ tests withDebugging wdConfig caps _selenium = do
1069 -- This essentially checks that the client IO runs *after* switchover/postBuild,
792 -- This essentially checks that the client IO runs *after* switchover/postBuild,
1070 -- thus can't create conflicting DOM
793 -- thus can't create conflicting DOM
1071 it "can't exploit IO to break hydration" $ runWD $ do
794 it "can't exploit IO to break hydration" $ runWD $ do
1072− let preSwitchover = checkBodyText "Initial"
795+ let static = checkBodyText "Initial"
1073− testWidgetStatic preSwitchover $ void $ do
796+ testWidgetStatic static $ void $ do
1074 ref <- liftIO $ newRef "Initial"
797 ref <- liftIO $ newRef "Initial"
1075 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
798 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
1076 text <=< liftIO $ readRef ref
799 text <=< liftIO $ readRef ref
1077 -- As above, so below
800 -- As above, so below
1078 it "can't exploit triggerEvent to break hydration" $ runWD $ do
801 it "can't exploit triggerEvent to break hydration" $ runWD $ do
1079− let preSwitchover = checkBodyText "Initial"
802+ let static = checkBodyText "Initial"
1080 check = checkBodyText "Client"
803 check = checkBodyText "Client"
1081− testWidget preSwitchover check $ void $ do
804+ testWidget static check $ void $ do
1082 (e, trigger) <- newTriggerEvent
805 (e, trigger) <- newTriggerEvent
1083 prerender_ (pure ()) (liftIO $ trigger "Client")
806 prerender_ (pure ()) (liftIO $ trigger "Client")
1084 textNode $ TextNodeConfig "Initial" $ Just e
807 textNode $ TextNodeConfig "Initial" $ Just e
1086− session' "namespaces" $ do
1087− it "dyn can be nested in namespaced widget" $ runWD $ do
1088− testWidget (pure ()) (checkTextInTag "svg" "one") $ do
1089− let svgRootCfg = def
1090− & (elementConfig_namespace ?~ "http://www.w3.org/2000/svg")
1091− & (elementConfig_initialAttributes .~ ("width" =: "100%" <> "height" =: "100%" <> "viewBox" =: "0 0 1536 2048"))
1092− void $ element "svg" svgRootCfg $ do
1093− dyn_ $ text "one" <$ pure ()
1095− session' "runWithReplace" $ do
809+ describe "runWithReplace" $ session' $ do
1096 it "works" $ runWD $ do
810 it "works" $ runWD $ do
1097 replaceChan :: Chan Text <- liftIO newChan
811 replaceChan :: Chan Text <- liftIO newChan
1098 let setup = findElemWithRetry $ WD.ByTag "div"
812 let setup = findElemWithRetry $ WD.ByTag "div"
@@ -1126,7 +840,7 @@ tests withDebugging wdConfig caps _selenium = do
1126 , el "span" . text <$> replace
840 , el "span" . text <$> replace
1128 it "can be nested in postBuild widget" $ runWD $ do
842 it "can be nested in postBuild widget" $ runWD $ do
1129− replaceChan :: Chan Text <- liftIO newChan
843+ replaceChan <- liftIO newChan
1130 let setup = findElemWithRetry $ WD.ByTag "div"
844 let setup = findElemWithRetry $ WD.ByTag "div"
1131 check ssr = do
845 check ssr = do
1132 -- Check that the original element still exists and has the correct text
846 -- Check that the original element still exists and has the correct text
@@ -1159,7 +873,7 @@ tests withDebugging wdConfig caps _selenium = do
1159 replaceChan2 :: Chan Text <- liftIO newChan
873 replaceChan2 :: Chan Text <- liftIO newChan
1160 lock :: MVar () <- liftIO newEmptyMVar
874 lock :: MVar () <- liftIO newEmptyMVar
1161 let check = do
875 let check = do
1162− shouldContainText "" =<< findElemWithRetry (WD.ByTag "body")
876+ shouldContainText "" =<< (findElemWithRetry (WD.ByTag "body"))
1163 liftIO $ do
877 liftIO $ do
1164 writeChan replaceChan1 "one"
878 writeChan replaceChan1 "one"
1165 takeMVar lock
879 takeMVar lock
@@ -1236,61 +950,7 @@ tests withDebugging wdConfig caps _selenium = do
1236 , el "span" . text <$> replace
950 , el "span" . text <$> replace
1239− let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)
1240− it "removes bracketing comments" $ runWD $ do
1241− replaceChan :: Chan () <- liftIO newChan
1243− preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
1245− liftIO $ writeChan replaceChan () -- trigger creation of p tag
1246− _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
1247− checkInnerHtml "div" "before|<p>inner2</p>|after"
1248− testWidget' preSwitchover check $ do
1249− replace <- triggerEventWithChan replaceChan
1252− _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
1254− it "ignores extra ending bracketing comment" $ runWD $ do
1255− replaceChan :: Chan () <- liftIO newChan
1257− preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"
1259− liftIO $ writeChan replaceChan () -- trigger creation of p tag
1260− _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
1261− checkInnerHtml "div" "before|inner2|after"
1262− testWidget' preSwitchover check $ do
1263− replace <- triggerEventWithChan replaceChan
1266− _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
1268− void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
1269− -- TODO This test actually causes a hydration failure, but it wasn't
1270− -- previously detected, so I've marked it pending
1271− xit "ignores missing ending bracketing comments" $ runWD $ do
1272− replaceChan :: Chan () <- liftIO newChan
1275− checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
1276− divEl <- findElemWithRetry (WD.ByTag "div")
1277− let wrongHtml = "<!--replace-start-0-->inner1"
1278− actualHtml :: String <- WD.executeJS
1279− [WD.JSArg divEl, WD.JSArg wrongHtml]
1280− "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"
1281− actualHtml `shouldBe` wrongHtml
1283− liftIO $ writeChan replaceChan () -- trigger creation of p tag
1284− _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
1285− checkInnerHtml "div" "before|<p>inner2</p>|after"
1286− testWidget' preSwitchover check $ do
1287− replace <- triggerEventWithChan replaceChan
1290− _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
1293− session' "traverseDMapWithKeyWithAdjust" $ do
953+ describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1294 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
954 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
1295 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
955 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1296 elClass "span" "key" $ text $ textKey k
956 elClass "span" "key" $ text $ textKey k
@@ -1299,8 +959,8 @@ tests withDebugging wdConfig caps _selenium = do
1299 checkItem :: WD.Element -> Text -> Text -> WD ()
959 checkItem :: WD.Element -> Text -> Text -> WD ()
1300 checkItem li k v = do
960 checkItem li k v = do
1301 putStrLnDebug "checkItem"
961 putStrLnDebug "checkItem"
1302− shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
962+ shouldContainTextNoRetry k =<< (WD.findElemFrom li (WD.ByClass "key"))
1303− shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
963+ shouldContainTextNoRetry v =<< (WD.findElemFrom li (WD.ByClass "value"))
1304 checkInitialItems dm xs = do
964 checkInitialItems dm xs = do
1305 putStrLnDebug "checkInitialItems"
965 putStrLnDebug "checkInitialItems"
1306 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
966 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
@@ -1330,26 +990,26 @@ tests withDebugging wdConfig caps _selenium = do
1330 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
990 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
1331 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
991 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1332 chan <- liftIO newChan
992 chan <- liftIO newChan
1333− let preSwitchover :: WD [WD.Element]
993+ let static :: WD [WD.Element]
1334− preSwitchover = getAndCheckInitialItems keyMap
994+ static = getAndCheckInitialItems keyMap
1335 check :: [WD.Element] -> WD ()
995 check :: [WD.Element] -> WD ()
1336 check xs = do
996 check xs = do
1337 checkInitialItems keyMap xs
997 checkInitialItems keyMap xs
1338 checkRemoval chan Key_Int
998 checkRemoval chan Key_Int
1339 checkReplace chan Key_Char 'B'
999 checkReplace chan Key_Char 'B'
1340 checkInsert chan Key_Bool True
1000 checkInsert chan Key_Bool True
1341− testWidget' preSwitchover check $ do
1001+ testWidget' static check $ do
1342 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1002 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1343 liftIO $ dmap `H.shouldBe` keyMap
1003 liftIO $ dmap `H.shouldBe` keyMap
1344 it "handles postBuild correctly" $ runWD $ do
1004 it "handles postBuild correctly" $ runWD $ do
1345 chan <- liftIO newChan
1005 chan <- liftIO newChan
1346− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1006+ let static = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1347 check xs = do
1007 check xs = do
1348 withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1008 withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1349 checkRemoval chan Key_Int
1009 checkRemoval chan Key_Int
1350 checkInsert chan Key_Char 'B'
1010 checkInsert chan Key_Char 'B'
1351 checkReplace chan Key_Bool True
1011 checkReplace chan Key_Bool True
1352− testWidget' preSwitchover check $ void $ do
1012+ testWidget' static check $ void $ do
1353 pb <- getPostBuild
1013 pb <- getPostBuild
1354 replace <- triggerEventWithChan chan
1014 replace <- triggerEventWithChan chan
1355 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1015 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1393,7 +1053,7 @@ tests withDebugging wdConfig caps _selenium = do
1393 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1053 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1394 liftIO $ dmap `H.shouldBe` keyMap
1054 liftIO $ dmap `H.shouldBe` keyMap
1396− session' "traverseIntMapWithKeyWithAdjust" $ do
1056+ describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
1397 let textKeyInt k = "key" <> T.pack (show k)
1057 let textKeyInt k = "key" <> T.pack (show k)
1398 intMap = IntMap.fromList
1058 intMap = IntMap.fromList
1399 [ (1, "one")
1059 [ (1, "one")
@@ -1439,24 +1099,24 @@ tests withDebugging wdConfig caps _selenium = do
1439 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1099 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1440 xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1100 xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1441 chan <- liftIO newChan
1101 chan <- liftIO newChan
1442− let preSwitchover = getAndCheckInitialItems intMap
1102+ let static = getAndCheckInitialItems intMap
1443 check xs = do
1103 check xs = do
1444 checkInitialItems intMap xs
1104 checkInitialItems intMap xs
1445 checkRemoval chan 1
1105 checkRemoval chan 1
1446 checkReplace chan 2 "deux"
1106 checkReplace chan 2 "deux"
1447 checkInsert chan 4 "four"
1107 checkInsert chan 4 "four"
1448− testWidget' preSwitchover check $ void $ do
1108+ testWidget' static check $ void $ do
1449 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1109 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1450 liftIO $ im `H.shouldBe` intMap
1110 liftIO $ im `H.shouldBe` intMap
1451 xit "handles postBuild correctly" $ runWD $ do
1111 xit "handles postBuild correctly" $ runWD $ do
1452 chan <- liftIO newChan
1112 chan <- liftIO newChan
1453− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1113+ let static = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1454 check xs = do
1114 check xs = do
1455 withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1115 withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1456 checkRemoval chan 1
1116 checkRemoval chan 1
1457 checkInsert chan 2 "deux"
1117 checkInsert chan 2 "deux"
1458 checkReplace chan 3 "trois"
1118 checkReplace chan 3 "trois"
1459− testWidget' preSwitchover check $ void $ do
1119+ testWidget' static check $ void $ do
1460 pb <- getPostBuild
1120 pb <- getPostBuild
1461 replace <- triggerEventWithChan chan
1121 replace <- triggerEventWithChan chan
1462 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1122 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1500,7 +1160,7 @@ tests withDebugging wdConfig caps _selenium = do
1500 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1160 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1501 liftIO $ dmap `H.shouldBe` intMap
1161 liftIO $ dmap `H.shouldBe` intMap
1503− session' "traverseDMapWithKeyWithAdjustWithMove" $ do
1163+ describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
1504 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1164 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1505 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1165 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1506 elClass "span" "key" $ text $ textKey2 k
1166 elClass "span" "key" $ text $ textKey2 k
@@ -1512,8 +1172,8 @@ tests withDebugging wdConfig caps _selenium = do
1512 Key2_Char c -> "c" <> T.pack [c]
1172 Key2_Char c -> "c" <> T.pack [c]
1513 checkItem :: WD.Element -> Text -> Text -> WD ()
1173 checkItem :: WD.Element -> Text -> Text -> WD ()
1514 checkItem li k v = do
1174 checkItem li k v = do
1515− shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1175+ shouldContainTextNoRetry k =<< (WD.findElemFrom li (WD.ByClass "key"))
1516− shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
1176+ shouldContainTextNoRetry v =<< (WD.findElemFrom li (WD.ByClass "value"))
1517 checkInitialItems dm xs = do
1177 checkInitialItems dm xs = do
1518 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1178 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1519 forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey2 k) (T.pack $ has @Show k $ show v)
1179 forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey2 k) (T.pack $ has @Show k $ show v)
@@ -1521,9 +1181,6 @@ tests withDebugging wdConfig caps _selenium = do
1521 xs <- WD.findElems (WD.ByTag "li")
1181 xs <- WD.findElems (WD.ByTag "li")
1522 checkInitialItems dm xs
1182 checkInitialItems dm xs
1525− :: (DMap Key2 Identity -> (WD.Element -> Chan (PatchDMapWithMove Key2 Identity) -> WD ()) -> WD ())
1526− -> H.SpecM (WdTestSession ()) ()
1527 moveSpec testMove = do
1184 moveSpec testMove = do
1528 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
1185 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
1529 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
1186 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
@@ -1551,19 +1208,19 @@ tests withDebugging wdConfig caps _selenium = do
1552 describe "hydration" $ moveSpec $ \initMap test -> do
1209 describe "hydration" $ moveSpec $ \initMap test -> do
1553 chan <- liftIO newChan
1210 chan <- liftIO newChan
1554− let preSwitchover = getAndCheckInitialItems initMap
1211+ let static = getAndCheckInitialItems initMap
1555 check xs = do
1212 check xs = do
1556 checkInitialItems initMap xs
1213 checkInitialItems initMap xs
1557 body <- getBody
1214 body <- getBody
1558 test body chan
1215 test body chan
1559− testWidget' preSwitchover check $ void $ do
1216+ testWidget' static check $ void $ do
1560 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1217 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1561 liftIO $ assertEqual "DMap" initMap dmap
1218 liftIO $ assertEqual "DMap" initMap dmap
1563 describe "hydration/immediate" $ moveSpec $ \initMap test -> do
1220 describe "hydration/immediate" $ moveSpec $ \initMap test -> do
1564 chan <- liftIO newChan
1221 chan <- liftIO newChan
1565 replace <- liftIO newChan
1222 replace <- liftIO newChan
1566− lock :: MVar () <- liftIO newEmptyMVar
1223+ lock <- liftIO newEmptyMVar
1567 let check = do
1224 let check = do
1568 liftIO $ do
1225 liftIO $ do
1569 writeChan replace ()
1226 writeChan replace ()
@@ -1580,14 +1237,12 @@ tests withDebugging wdConfig caps _selenium = do
1580 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1237 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1581 liftIO $ assertEqual "DMap" initMap dmap
1238 liftIO $ assertEqual "DMap" initMap dmap
1583− session' "hydrating invalid HTML" $ do
1240+ describe "hydrating invalid HTML" $ session' $ do
1584− xit "can hydrate list in paragraph" $ runWD $ do
1241+ it "can hydrate list in paragraph" $ runWD $ do
1585− let preSwitchover = do
1242+ let static = do
1586 checkBodyText "before\ninner\nafter"
1243 checkBodyText "before\ninner\nafter"
1587 -- Two <p> tags should be present
1244 -- Two <p> tags should be present
1588− (p1, p2) <- WD.findElems (WD.ByTag "p") >>= \case
1245+ [p1, p2] <- WD.findElems (WD.ByTag "p")
1589− [p1, p2] -> pure (p1, p2)
1590− _ -> error "Unexpected number of `p` tags (expected 2)"
1591 ol <- findElemWithRetry (WD.ByTag "ol")
1246 ol <- findElemWithRetry (WD.ByTag "ol")
1592 shouldContainText "before" p1
1247 shouldContainText "before" p1
1593 shouldContainText "inner" ol
1248 shouldContainText "inner" ol
@@ -1598,8 +1253,7 @@ tests withDebugging wdConfig caps _selenium = do
1598 shouldContainText "before\ninner\nafter" p1
1253 shouldContainText "before\ninner\nafter" p1
1599 elementShouldBeRemoved ol
1254 elementShouldBeRemoved ol
1600 elementShouldBeRemoved p2
1255 elementShouldBeRemoved p2
1601− -- Don't fail fatally when hydration encounters the invalid DOM
1256+ testWidget' static check $ do
1602− testWidgetDebug' False withDebugging preSwitchover check $ do
1603 -- This is deliberately invalid HTML, the browser will interpret it as
1257 -- This is deliberately invalid HTML, the browser will interpret it as
1604 -- <p>before</p><ol>inner</ol>after<p></p>
1258 -- <p>before</p><ol>inner</ol>after<p></p>
1605 el "p" $ do
1259 el "p" $ do
@@ -1607,29 +1261,6 @@ tests withDebugging wdConfig caps _selenium = do
1607 el "ol" $ text "inner"
1261 el "ol" $ text "inner"
1608 text "after"
1262 text "after"
1610− -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
1611− -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
1612− -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
1613− session' "dropdown" $ do
1614− let doTest expectedOpts (initialValue :: Text) = do
1616− es <- findElemsWithRetry $ WD.ByTag "option"
1617− opts <- mapM fetchElement es
1618− assertEqual "missing/extra/incorrect option element(s)" expectedOpts (sort opts)
1619− testWidget doCheck doCheck $ do
1620− void $ dropdown initialValue (constDyn (("aa" :: Text) =: "aaa" <> "bb" =: "bbb")) def
1621− fetchElement e = do
1622− val <- WD.attr e "value"
1623− sel <- WD.attr e "selected"
1624− return (fromMaybe "" val, isJust sel)
1625− -- The "aa" test case is important, but a good test implementation probably needs to avoid selenium, because HTML parsers will insert a "selected" attribute on the first "option" tag if no selected attributes are present; thus as written, this erroneously succeeds on the old implementation (but properly implemented, should fail)
1626− -- Thus, it would appear that we do actually need a HTML5 or maybe XML parser for this test suite.
1627− xit "statically renders initial values (on aa)" $ runWD $ do
1628− doTest [("0",True),("1",False)] "aa"
1629− -- These tests are currently marked "pending" (by using "xit" instead of "it") because this test has a high chance of non-deterministically failing, which is a problem elsewhere in this test suite as well
1630− xit "statically renders initial values (on bb)" $ runWD $ do
1631− doTest [("0",False),("1",True)] "bb"
1633data Selenium = Selenium
1264data Selenium = Selenium
1634 { _selenium_portNumber :: PortNumber
1265 { _selenium_portNumber :: PortNumber
1635 , _selenium_stopServer :: IO ()
1266 , _selenium_stopServer :: IO ()
@@ -1697,9 +1328,6 @@ checkTextInId i expected = do
1697findElemWithRetry :: Selector -> WD WD.Element
1328findElemWithRetry :: Selector -> WD WD.Element
1698findElemWithRetry = withRetry . WD.findElem
1329findElemWithRetry = withRetry . WD.findElem
1700−findElemsWithRetry :: Selector -> WD [WD.Element]
1701−findElemsWithRetry = withRetry . WD.findElems
1703getBody :: WD WD.Element
1331getBody :: WD WD.Element
1704getBody = WD.findElem $ WD.ByTag "body"
1332getBody = WD.findElem $ WD.ByTag "body"
@@ -1708,8 +1336,8 @@ withRetry a = wait 300
1708 where wait :: Int -> WD a
1336 where wait :: Int -> WD a
1709 wait 0 = a
1337 wait 0 = a
1710 wait n = try a >>= \case
1338 wait n = try a >>= \case
1711− Left (e :: SomeException) -> do
1339+ Left (_ :: SomeException) -> do
1712− liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
1340+ liftIO $ threadDelay 100000
1713 wait $ n - 1
1341 wait $ n - 1
1714 Right v -> return v
1342 Right v -> return v
@@ -1725,12 +1353,11 @@ testWidgetStaticDebug
1725 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1353 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1726 -- ^ Widget we are testing
1354 -- ^ Widget we are testing
1728−testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
1356+testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
1730-- | TODO: do something about JSExceptions not causing tests to fail
1358-- | TODO: do something about JSExceptions not causing tests to fail
1731testWidgetDebug
1359testWidgetDebug
1734 -> WD ()
1361 -> WD ()
1735 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1362 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
@@ -1738,16 +1365,12 @@ testWidgetDebug
1738 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1365 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1739 -- ^ Widget we are testing
1366 -- ^ Widget we are testing
1741−testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =
1368+testWidgetDebug withDebugging beforeJS afterSwitchover =
1742− testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)
1369+ testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
1744−data HydrationFailedException = HydrationFailedException deriving Show
1745−instance Exception HydrationFailedException
1747-- | TODO: do something about JSExceptions not causing tests to fail
1371-- | TODO: do something about JSExceptions not causing tests to fail
1748testWidgetDebug'
1372testWidgetDebug'
1752 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1375 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1753 -> (a -> WD b)
1376 -> (a -> WD b)
@@ -1755,7 +1378,7 @@ testWidgetDebug'
1755 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1378 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1756 -- ^ Widget we are testing (contents of body)
1379 -- ^ Widget we are testing (contents of body)
1758−testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
1381+testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1759 let putStrLnDebug :: MonadIO m => Text -> m ()
1382 let putStrLnDebug :: MonadIO m => Text -> m ()
1760 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1383 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1761 staticApp = do
1384 staticApp = do
@@ -1764,10 +1387,9 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
1764 bodyWidget
1387 bodyWidget
1765 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1388 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1766 putStrLnDebug "rendering static"
1389 putStrLnDebug "rendering static"
1767− ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1390+ ((), html) <- liftIO $ renderStatic staticApp
1768 putStrLnDebug "rendered static"
1391 putStrLnDebug "rendered static"
1769 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1392 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1770− onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
1771 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1393 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1772 let entryPoint = do
1394 let entryPoint = do
1773 putStrLnDebug "taking waitBeforeJS"
1395 putStrLnDebug "taking waitBeforeJS"
@@ -1779,7 +1401,7 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
1779 liftIO $ putMVar waitUntilSwitchover ()
1401 liftIO $ putMVar waitUntilSwitchover ()
1780 putStrLnDebug "put waitUntilSwitchover"
1402 putStrLnDebug "put waitUntilSwitchover"
1781 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1403 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1782− mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
1404+ mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
1783 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1405 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1784 syncPoint
1406 syncPoint
1785 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
1407 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
@@ -1797,26 +1419,23 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
1798 -- hSilence to get rid of ConnectionClosed logs
1420 -- hSilence to get rid of ConnectionClosed logs
1799 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1421 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1800− jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
1422+ jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
1801− withAsync' jsaddleWarp $ do
1423+ jsaddleTid <- liftIO jsaddleWarp
1802− putStrLnDebug "taking waitJSaddle"
1424+ putStrLnDebug "taking waitJSaddle"
1803− liftIO $ takeMVar waitJSaddle
1425+ liftIO $ takeMVar waitJSaddle
1804− putStrLnDebug "opening page"
1426+ putStrLnDebug "opening page"
1805− WD.openPage $ "http://localhost:" <> show jsaddlePort
1427+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1806− putStrLnDebug "running beforeJS"
1428+ putStrLnDebug "running beforeJS"
1807− a <- beforeJS
1429+ a <- beforeJS
1808− putStrLnDebug "putting waitBeforeJS"
1430+ putStrLnDebug "putting waitBeforeJS"
1809− liftIO $ putMVar waitBeforeJS ()
1431+ liftIO $ putMVar waitBeforeJS ()
1810− putStrLnDebug "taking waitUntilSwitchover"
1432+ putStrLnDebug "taking waitUntilSwitchover"
1811− liftIO $ takeMVar waitUntilSwitchover
1433+ liftIO $ takeMVar waitUntilSwitchover
1812− putStrLnDebug "running afterSwitchover"
1434+ putStrLnDebug "running afterSwitchover"
1813− afterSwitchover a
1435+ b <- afterSwitchover a
1814−
1436+ putStrLnDebug "killing jsaddle thread"
1815−withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
1437+ liftIO $ killThread jsaddleTid
1816−withAsync' f g = bracket
1438+ return b
1817− (liftIO $ Async.async f)
1818− (liftIO . Async.uninterruptibleCancel)
1821data Key2 a where
1440data Key2 a where
1822 Key2_Int :: Int -> Key2 Int
1441 Key2_Int :: Int -> Key2 Int
@@ -1826,3 +1445,12 @@ deriveGEq ''Key2
1826deriveGCompare ''Key2
1445deriveGCompare ''Key2
1827deriveGShow ''Key2
1446deriveGShow ''Key2
1828deriveArgDict ''Key2
1447deriveArgDict ''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 _) = (==)