@@ -1,9 +1,11 @@
11{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE StandaloneDeriving #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE UndecidableInstances #-}
25{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE CPP #-}
37{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
58{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
79{-# LANGUAGE LambdaCase #-}
810{-# LANGUAGE MultiParamTypeClasses #-}
911{-# LANGUAGE OverloadedStrings #-}
@@ -11,44 +13,29 @@
1113{-# LANGUAGE RankNTypes #-}
1214{-# LANGUAGE RecursiveDo #-}
1315{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE StandaloneDeriving #-}
1516{-# LANGUAGE TemplateHaskell #-}
1617{-# LANGUAGE TupleSections #-}
1718{-# LANGUAGE TypeApplications #-}
1819{-# LANGUAGE TypeFamilies #-}
19−{-# LANGUAGE UndecidableInstances #-}
20−
21−{-# OPTIONS_GHC -fno-warn-orphans #-}
2220
23−-- Notice to those working on this test suite:
24−-- It doesn't appear to be possible to use --match to run a particular test, in
25−-- this situation the test may hang before reaching our code. This seems to
26−-- happen when the test is not the first test in the block. As a workaround, you
27−-- can just comment out the other tests. Also, using `xit` will cause the same
28−-- issue. `xit` tests must be the last tests in the session, or the session will
29−-- hang in the following test.
30−
31−import Prelude hiding (fail)
3221import Control.Concurrent
33−import qualified Control.Concurrent.Async as Async
34−import Control.Lens.Operators
35−import Control.Monad hiding (fail)
22+import Control.Monad
3623import Control.Monad.Catch
37−import Control.Monad.Fail
3824import Control.Monad.Fix
3925import Control.Monad.IO.Class
4026import Control.Monad.Ref
27+import Data.Constraint (Dict(..))
4128import Data.Constraint.Extras
4229import Data.Constraint.Extras.TH
4330import Data.Dependent.Map (DMap)
44−import Data.Dependent.Sum (DSum(..), (==>))
31+import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
32+import Data.Foldable (traverse_)
4533import Data.Functor.Identity
4634import Data.Functor.Misc
4735import Data.GADT.Compare.TH
4836import Data.GADT.Show.TH
4937import Data.IORef (IORef)
50−import Data.List (sort)
51−import Data.Maybe
38+import Data.Maybe (fromMaybe, fromJust)
5239import Data.Proxy
5340import Data.Text (Text)
5441import Language.Javascript.JSaddle (syncPoint, liftJSM)
@@ -58,22 +45,18 @@ import Network.Socket
5845import Network.Wai
5946import Network.WebSockets
6047import Reflex.Dom.Core
61−import Reflex.Dom.Widget.Input (dropdown)
6248import Reflex.Patch.DMapWithMove
6349import System.Directory
64−import System.Environment
6550import System.IO (stderr)
6651import System.IO.Silently
6752import System.IO.Temp
6853import System.Process
69−import System.Which (staticWhich)
70−import qualified Test.HUnit as HUnit
54+import System.Timeout.Lifted
55+import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
7156import qualified Test.Hspec as H
72−import qualified Test.Hspec.Core.Spec as H
73−import Test.Hspec (xit)
74−import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
57+import Test.Hspec.WebDriver hiding (runWD)
7558import qualified Test.Hspec.WebDriver as WD
76−import Test.WebDriver (WD(..))
59+import Test.WebDriver (WD)
7760
7861import qualified Data.ByteString.Lazy as LBS
7962import qualified Data.Dependent.Map as DMap
@@ -86,37 +69,20 @@ import qualified System.FilePath as FilePath
8669import qualified Test.WebDriver as WD
8770import qualified Test.WebDriver.Capabilities as WD
8871
89−import Test.Util.ChromeFlags
90−import Test.Util.UnshareNetwork
91−
92−-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
93−deriving instance MonadMask WD
94−
95−chromium :: FilePath
96−chromium = $(staticWhich "chromium")
97−
98−seleniumPort, jsaddlePort :: PortNumber
99−seleniumPort = 8000
100−jsaddlePort = 8001
101−
10272-- TODO Remove orphan
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
73+deriving instance MonadRef WD
10874
10975assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
110−assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
76+assertEqual a b = liftIO . HUnit.assertEqual a b
11177
11278assertFailure :: MonadIO m => String -> m ()
11379assertFailure = liftIO . HUnit.assertFailure
11480
115−assertBool :: (MonadIO m) => String -> Bool -> m ()
116−assertBool msg bool = liftIO $ HUnit.assertBool msg bool
81+testTimeLimit :: Int
82+testTimeLimit = 5 * 1000 * 1000
11783
118−chromeConfig :: Text -> [Text] -> WD.WDConfig
119−chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
84+chromeConfig :: Text -> WD.WDConfig
85+chromeConfig fp = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = ["--headless"] }) WD.defaultConfig
12086
12187keyMap :: DMap DKey Identity
12288keyMap = DMap.fromList
@@ -141,38 +107,30 @@ deriveGEq ''DKey
141107deriveGCompare ''DKey
142108deriveGShow ''DKey
143109
144−deriving instance MonadFail WD
110+instance ShowTag DKey Identity where
111+ showTaggedPrec = \case
112+ Key_Int -> showsPrec
113+ Key_Char -> showsPrec
114+ Key_Bool -> showsPrec
115+
116+instance EqTag DKey Identity where
117+ eqTagged Key_Int Key_Int = (==)
118+ eqTagged Key_Char Key_Char = (==)
119+ eqTagged Key_Bool Key_Bool = (==)
145120
146121main :: IO ()
147−main = do
148− unshareNetwork
149− isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
150− withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
151− withSeleniumServer $ \selenium -> do
152− let browserPath = T.strip $ T.pack chromium
153− when (T.null browserPath) $ fail "No browser found"
154− withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
155− let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
156− chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
157− hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
122+main = withSeleniumServer $ \selenium -> do
123+ browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
124+ when (T.null browserPath) $ fail "No browser found"
125+ let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
126+ chromeCaps' = WD.getCaps $ chromeConfig browserPath
127+ hspec (tests wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
158128
159−tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
160−tests withDebugging wdConfig caps _selenium = do
161− let putStrLnDebug :: MonadIO m => Text -> m ()
162− putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
163− session' t = sessionWith wdConfig t . using caps
164− runWD m = runWDOptions (WdOptions False) $ do
165− putStrLnDebug "before"
166− r <- m
167− putStrLnDebug "after"
168− return r
169− testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
170− testWidgetStatic = testWidgetStaticDebug withDebugging
171− testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
172− testWidget = testWidgetDebug True withDebugging
173− testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
174− testWidget' = testWidgetDebug' True withDebugging
175− session' "text" $ do
129+tests :: WD.WDConfig -> [Capabilities] -> Selenium -> Spec
130+tests wdConfig caps _selenium = do
131+ let session' = sessionWith wdConfig "" . using (map (,"") caps)
132+ runWD = runWDOptions (WdOptions False)
133+ describe "text" $ session' $ do
176134 it "works" $ runWD $ do
177135 testWidgetStatic (checkBodyText "hello world") $ do
178136 text "hello world"
@@ -227,25 +185,27 @@ tests withDebugging wdConfig caps _selenium = do
227185 it "updates in immediate mode" $ runWD $ do
228186 let checkUpdated = do
229187 checkBodyText "initial"
230− WD.click =<< findElemWithRetry (WD.ByTag "button")
188+ WD.click =<< WD.findElem (WD.ByTag "button")
189+ liftIO $ threadDelay 100000 -- wait for update
231190 checkBodyText "after"
232191 testWidget (pure ()) checkUpdated $ prerender_ (pure ()) $ do
233192 click <- button ""
234193 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
235194
236− session' "element" $ do
195+ describe "element" $ session' $ do
237196 it "works with domEvent Click" $ runWD $ do
238197 clickedRef <- liftIO $ newRef False
239− testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
198+ testWidget' (WD.findElem $ WD.ByTag "div") WD.click $ do
240199 (e, _) <- el' "div" $ text "hello world"
241200 performEvent_ $ liftIO (writeRef clickedRef True) <$ domEvent Click e
242− readRef clickedRef `shouldBeWithRetryM` True
201+ clicked <- liftIO $ readRef clickedRef
202+ liftIO $ assertEqual "Not clicked" True clicked
243203 it "works with eventFlags stopPropagation" $ runWD $ do
244204 firstClickedRef <- newRef False
245205 secondClickedRef <- newRef False
246206 let clickBoth = do
247− findElemWithRetry (WD.ById "first") >>= WD.click
248− findElemWithRetry (WD.ById "second") >>= WD.click
207+ WD.findElem (WD.ById "first") >>= WD.click
208+ WD.findElem (WD.ById "second") >>= WD.click
249209 testWidget (pure ()) clickBoth $ do
250210 (firstDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do
251211 void $ elAttr "span" ("id" =: "first") $ text "hello world"
@@ -262,7 +222,7 @@ tests withDebugging wdConfig caps _selenium = do
262222 assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)
263223 it "works with eventFlags preventDefault" $ runWD $ do
264224 let click = do
265− e <- findElemWithRetry $ WD.ByTag "input"
225+ e <- WD.findElem $ WD.ByTag "input"
266226 s0 <- WD.isSelected e
267227 WD.click e
268228 s1 <- WD.isSelected e
@@ -276,7 +236,7 @@ tests withDebugging wdConfig caps _selenium = do
276236 assertEqual "Click not prevented" (False, False) clicked
277237 it "can add/update/remove attributes" $ runWD $ do
278238 let checkInitialAttrs = do
279− e <- findElemWithRetry $ WD.ByTag "div"
239+ e <- WD.findElem $ WD.ByTag "div"
280240 assertAttr e "const" (Just "const")
281241 assertAttr e "delete" (Just "delete")
282242 assertAttr e "init" (Just "init")
@@ -284,11 +244,11 @@ tests withDebugging wdConfig caps _selenium = do
284244 pure e
285245 checkModifyAttrs e = do
286246 WD.click e
287− withRetry $ do
288− assertAttr e "const" (Just "const")
289− assertAttr e "delete" Nothing
290− assertAttr e "init" (Just "click")
291− assertAttr e "click" (Just "click")
247+ liftIO $ threadDelay 100000
248+ assertAttr e "const" (Just "const")
249+ assertAttr e "delete" Nothing
250+ assertAttr e "init" (Just "click")
251+ assertAttr e "click" (Just "click")
292252 testWidget' checkInitialAttrs checkModifyAttrs $ mdo
293253 let conf = def
294254 & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"
@@ -296,87 +256,40 @@ tests withDebugging wdConfig caps _selenium = do
296256 (e, ()) <- element "div" conf $ text "hello world"
297257 let click = domEvent Click e
298258 return ()
259+ -- TODO check this is the correct solution
260+ it "has ssr attribute, removes ssr attribute" $ runWD $ do
261+ let checkSSRAttr = do
262+ e <- WD.findElem $ WD.ByTag "div"
263+ assertAttr e "data-ssr" (Just "")
264+ pure e
265+ testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world"
299266
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"
306− pure e
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"
315− pure e
316− checkHydrated e = do
317− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
318− testWidget' checkStatic checkHydrated $ do
319− pb <- getPostBuild
320− _ <- inputElement $ def
321− & inputElementConfig_initialValue .~ "test"
322− & inputElementConfig_setValue .~ ("test-updated" <$ pb)
323− pure ()
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"
329− pure e
330− checkValue e = do
331− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
332− WD.moveToCenter e
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
343− pure ()
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"
348− pure e
349− checkValue e = do
350− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
351− testWidget' checkStatic checkValue $ do
352− pb <- getPostBuild
353− _ <- inputElement $ def
354− & initialAttributes .~ "type" =: "checkbox"
355− & inputElementConfig_initialChecked .~ False
356− & inputElementConfig_setChecked .~ (True <$ pb)
357− pure ()
358− describe "hydration" $ do
267+ describe "inputElement" $ do
268+ describe "hydration" $ session' $ do
359269 it "doesn't wipe user input when switching over" $ runWD $ do
360− inputRef <- newRef ("hello " :: Text)
270+ inputRef <- newRef ("" :: Text)
361271 testWidget'
362272 (do
363− e <- findElemWithRetry $ WD.ByTag "input"
364− WD.sendKeys "world" e
273+ e <- WD.findElem $ WD.ByTag "input"
274+ WD.sendKeys "hello world" e
365275 pure e)
366276 (\e -> do
367− WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
368− WD.click =<< findElemWithRetry (WD.ByTag "button")
369− readRef inputRef `shouldBeWithRetryM` "hello world"
277+ t <- WD.attr e "value"
278+ t `shouldBe` Just "hello world"
279+ WD.click <=< WD.findElem $ WD.ByTag "button"
280+ input <- liftIO $ readRef inputRef
281+ input `shouldBe` "hello world"
370282 ) $ do
371− e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
283+ e <- inputElement def
372284 click <- button "save"
373285 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
374286 it "captures user input after switchover" $ runWD $ do
375287 inputRef <- newRef ("" :: Text)
376288 let checkValue = do
377− WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
378− WD.click =<< findElemWithRetry (WD.ByTag "button")
379− readRef inputRef `shouldBeWithRetryM` "hello world"
289+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
290+ WD.click <=< WD.findElem $ WD.ByTag "button"
291+ input <- liftIO $ readRef inputRef
292+ input `shouldBe` "hello world"
380293 testWidget (pure ()) checkValue $ do
381294 e <- inputElement def
382295 click <- button "save"
@@ -384,21 +297,23 @@ tests withDebugging wdConfig caps _selenium = do
384297 it "sets focus appropriately" $ runWD $ do
385298 focusRef <- newRef False
386299 let checkValue = do
387− readRef focusRef `shouldBeWithRetryM` False
388− e <- findElemWithRetry $ WD.ByTag "input"
300+ readRef focusRef >>= flip shouldBe False
301+ e <- WD.findElem $ WD.ByTag "input"
389302 WD.click e
390− readRef focusRef `shouldBeWithRetryM` True
303+ liftIO $ threadDelay 100000
304+ readRef focusRef >>= flip shouldBe True
391305 testWidget (pure ()) checkValue $ do
392306 e <- inputElement def
393307 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
394308 it "sets focus when focus occurs before hydration" $ runWD $ do
395309 focusRef <- newRef False
396310 let setup = do
397− e <- findElemWithRetry $ WD.ByTag "input"
311+ e <- WD.findElem $ WD.ByTag "input"
398312 WD.click e
399− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
400− readRef focusRef `shouldBeWithRetryM` False
401− check = readRef focusRef `shouldBeWithRetryM` True
313+ hasFocus <- (== e) <$> WD.activeElem
314+ hasFocus `shouldBe` True
315+ readRef focusRef >>= flip shouldBe False
316+ check = readRef focusRef >>= flip shouldBe True
402317 testWidget setup check $ do
403318 e <- inputElement def
404319 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -407,15 +322,17 @@ tests withDebugging wdConfig caps _selenium = do
407322 valueRef <- newRef ("" :: Text)
408323 setValueChan :: Chan Text <- liftIO newChan
409324 let checkValue = do
410− readRef valueByUIRef `shouldBeWithRetryM` ""
411− readRef valueRef `shouldBeWithRetryM` ""
412− e <- findElemWithRetry $ WD.ByTag "input"
325+ readRef valueByUIRef >>= flip shouldBe ""
326+ readRef valueRef >>= flip shouldBe ""
327+ e <- WD.findElem $ WD.ByTag "input"
413328 WD.sendKeys "hello" e
414− readRef valueByUIRef `shouldBeWithRetryM` "hello"
415− readRef valueRef `shouldBeWithRetryM` "hello"
329+ liftIO $ threadDelay 100000
330+ readRef valueByUIRef >>= flip shouldBe "hello"
331+ readRef valueRef >>= flip shouldBe "hello"
416332 liftIO $ writeChan setValueChan "world"
417− readRef valueByUIRef `shouldBeWithRetryM` "hello"
418− readRef valueRef `shouldBeWithRetryM` "world"
333+ liftIO $ threadDelay 100000
334+ readRef valueByUIRef >>= flip shouldBe "hello"
335+ readRef valueRef >>= flip shouldBe "world"
419336 testWidget (pure ()) checkValue $ do
420337 update <- triggerEventWithChan setValueChan
421338 e <- inputElement $ def & inputElementConfig_setValue .~ update
@@ -425,181 +342,51 @@ tests withDebugging wdConfig caps _selenium = do
425342 checkedByUIRef <- newRef False
426343 checkedRef <- newRef False
427344 setCheckedChan <- liftIO newChan
428− let checkStatic = do
429− e <- findElemWithRetry $ WD.ByTag "input"
430− WD.attr e "checked" `shouldBeWithRetryM` Nothing
431− pure e
432− checkValue e = do
433− readRef checkedByUIRef `shouldBeWithRetryM` False
434− readRef checkedRef `shouldBeWithRetryM` False
435− WD.attr e "checked" `shouldBeWithRetryM` Nothing
345+ let checkValue = do
346+ readRef checkedByUIRef >>= flip shouldBe False
347+ readRef checkedRef >>= flip shouldBe False
348+ e <- WD.findElem $ WD.ByTag "input"
436349 WD.moveToCenter e
437350 WD.click e
438− readRef checkedByUIRef `shouldBeWithRetryM` True
439− readRef checkedRef `shouldBeWithRetryM` True
440− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
351+ liftIO $ threadDelay 100000
352+ readRef checkedByUIRef >>= flip shouldBe True
353+ readRef checkedRef >>= flip shouldBe True
441354 liftIO $ writeChan setCheckedChan False
442− readRef checkedByUIRef `shouldBeWithRetryM` True
443− readRef checkedRef `shouldBeWithRetryM` False
444− WD.attr e "checked" `shouldBeWithRetryM` Nothing
445− testWidget' checkStatic checkValue $ do
355+ liftIO $ threadDelay 100000
356+ readRef checkedByUIRef >>= flip shouldBe True
357+ readRef checkedRef >>= flip shouldBe False
358+ testWidget (pure ()) checkValue $ do
446359 setChecked <- triggerEventWithChan setCheckedChan
447360 e <- inputElement $ def
448361 & initialAttributes .~ "type" =: "checkbox"
449362 & inputElementConfig_setChecked .~ setChecked
450363 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
451364 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
458− WD.moveToCenter e
459− WD.click e
460− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
461− pure e
462− checkValue e = do
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)
471365 it "captures file uploads" $ runWD $ do
472366 filesRef :: IORef [Text] <- newRef []
473367 let uploadFile = do
474− e <- findElemWithRetry $ WD.ByTag "input"
368+ e <- WD.findElem $ WD.ByTag "input"
475369 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
476370 WD.sendKeys (T.pack path) e
477− WD.click =<< findElemWithRetry (WD.ByTag "button")
371+ WD.click <=< WD.findElem $ WD.ByTag "button"
478372 liftIO $ removeFile path
479− readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
373+ input <- readRef filesRef
374+ input `shouldBe` [T.pack $ FilePath.takeFileName path]
480375 testWidget (pure ()) uploadFile $ do
481376 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
482377 click <- button "save"
483378 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
484379 names <- liftJSM $ traverse File.getName fs
485380 liftIO $ writeRef filesRef names
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"
494− pure e
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"
508− pure e
509− checkHydrated e = do
510− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
511− readRef input `shouldBeWithRetryM` Nothing
512− testWidget' checkStatic checkHydrated $ do
513− pb <- getPostBuild
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
517− let checkBoth = 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
523− pb <- getPostBuild
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
543− pure ()
544− testWidget' checkStatic checkHydrated $ do
545− pb <- getPostBuild
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
559− pure (input, p)
560− checkHydrated (input, p) = do
561− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
562− shouldContainText "pbabc" p
563− pure ()
564− testWidget' checkStatic checkHydrated $ do
565− pb <- getPostBuild
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, ())
572− checkStatic = do
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"]
582− pure (input, p)
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
588− pure ()
589− testWidget' checkStatic checkHydrated $ do
590− liftIO $ writeRef valRef []
591− pb <- getPostBuild
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
381+
382+ describe "hydration/immediate" $ session' $ do
597383 it "captures user input after switchover" $ runWD $ do
598384 inputRef :: IORef Text <- newRef ""
599385 let checkValue = do
600− WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
601− WD.click =<< findElemWithRetry (WD.ByTag "button")
602− readRef inputRef `shouldBeWithRetryM` "hello world"
386+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
387+ WD.click <=< WD.findElem $ WD.ByTag "button"
388+ input <- readRef inputRef
389+ input `shouldBe` "hello world"
603390 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
604391 e <- inputElement def
605392 click <- button "save"
@@ -607,10 +394,11 @@ tests withDebugging wdConfig caps _selenium = do
607394 it "sets focus appropriately" $ runWD $ do
608395 focusRef <- newRef False
609396 let checkValue = do
610− readRef focusRef `shouldBeWithRetryM` False
611− e <- findElemWithRetry $ WD.ByTag "input"
397+ readRef focusRef >>= flip shouldBe False
398+ e <- WD.findElem $ WD.ByTag "input"
612399 WD.click e
613− readRef focusRef `shouldBeWithRetryM` True
400+ liftIO $ threadDelay 100000
401+ readRef focusRef >>= flip shouldBe True
614402 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
615403 e <- inputElement def
616404 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -619,15 +407,17 @@ tests withDebugging wdConfig caps _selenium = do
619407 valueRef :: IORef Text <- newRef ""
620408 setValueChan :: Chan Text <- liftIO newChan
621409 let checkValue = do
622− readRef valueByUIRef `shouldBeWithRetryM` ""
623− readRef valueRef `shouldBeWithRetryM` ""
624− e <- findElemWithRetry $ WD.ByTag "input"
410+ readRef valueByUIRef >>= flip shouldBe ""
411+ readRef valueRef >>= flip shouldBe ""
412+ e <- WD.findElem $ WD.ByTag "input"
625413 WD.sendKeys "hello" e
626− readRef valueByUIRef `shouldBeWithRetryM` "hello"
627− readRef valueRef `shouldBeWithRetryM` "hello"
414+ liftIO $ threadDelay 100000
415+ readRef valueByUIRef >>= flip shouldBe "hello"
416+ readRef valueRef >>= flip shouldBe "hello"
628417 liftIO $ writeChan setValueChan "world"
629− readRef valueByUIRef `shouldBeWithRetryM` "hello"
630− readRef valueRef `shouldBeWithRetryM` "world"
418+ liftIO $ threadDelay 100000
419+ readRef valueByUIRef >>= flip shouldBe "hello"
420+ readRef valueRef >>= flip shouldBe "world"
631421 testWidget (pure ()) checkValue $ do
632422 update <- triggerEventWithChan setValueChan
633423 prerender_ (pure ()) $ do
@@ -639,16 +429,18 @@ tests withDebugging wdConfig caps _selenium = do
639429 checkedRef <- newRef False
640430 setCheckedChan <- liftIO newChan
641431 let checkValue = do
642− readRef checkedByUIRef `shouldBeWithRetryM` False
643− readRef checkedRef `shouldBeWithRetryM` False
644− e <- findElemWithRetry $ WD.ByTag "input"
432+ readRef checkedByUIRef >>= flip shouldBe False
433+ readRef checkedRef >>= flip shouldBe False
434+ e <- WD.findElem $ WD.ByTag "input"
645435 WD.moveToCenter e
646436 WD.click e
647− readRef checkedByUIRef `shouldBeWithRetryM` True
648− readRef checkedRef `shouldBeWithRetryM` True
437+ liftIO $ threadDelay 100000
438+ readRef checkedByUIRef >>= flip shouldBe True
439+ readRef checkedRef >>= flip shouldBe True
649440 liftIO $ writeChan setCheckedChan False
650− readRef checkedByUIRef `shouldBeWithRetryM` True
651− readRef checkedRef `shouldBeWithRetryM` False
441+ liftIO $ threadDelay 100000
442+ readRef checkedByUIRef >>= flip shouldBe True
443+ readRef checkedRef >>= flip shouldBe False
652444 testWidget (pure ()) checkValue $ do
653445 setChecked <- triggerEventWithChan setCheckedChan
654446 prerender_ (pure ()) $ do
@@ -660,12 +452,13 @@ tests withDebugging wdConfig caps _selenium = do
660452 it "captures file uploads" $ runWD $ do
661453 filesRef :: IORef [Text] <- newRef []
662454 let uploadFile = do
663− e <- findElemWithRetry $ WD.ByTag "input"
455+ e <- WD.findElem $ WD.ByTag "input"
664456 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
665457 WD.sendKeys (T.pack path) e
666− WD.click =<< findElemWithRetry (WD.ByTag "button")
458+ WD.click <=< WD.findElem $ WD.ByTag "button"
667459 liftIO $ removeFile path
668− readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
460+ input <- liftIO $ readRef filesRef
461+ input `shouldBe` [T.pack $ FilePath.takeFileName path]
669462 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
670463 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
671464 click <- button "save"
@@ -673,42 +466,21 @@ tests withDebugging wdConfig caps _selenium = do
673466 names <- liftJSM $ traverse File.getName fs
674467 liftIO $ writeRef filesRef names
675468
676− session' "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"
682− pure e
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"
691− pure e
692− checkHydrated e = do
693− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
694− testWidget' checkStatic checkHydrated $ do
695− pb <- getPostBuild
696− _ <- textAreaElement $ def
697− & textAreaElementConfig_initialValue .~ "test"
698− & textAreaElementConfig_setValue .~ ("test-updated" <$ pb)
699− pure ()
700− describe "hydration" $ do
469+ describe "textAreaElement" $ do
470+ describe "hydration" $ session' $ do
701471 it "doesn't wipe user input when switching over" $ runWD $ do
702472 inputRef <- newRef ("" :: Text)
703473 testWidget'
704474 (do
705− e <- findElemWithRetry $ WD.ByTag "textarea"
475+ e <- WD.findElem $ WD.ByTag "textarea"
706476 WD.sendKeys "hello world" e
707477 pure e)
708478 (\e -> do
709− WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
710− WD.click <=< findElemWithRetry $ WD.ByTag "button"
711− readRef inputRef `shouldBeWithRetryM` "hello world"
479+ t <- WD.attr e "value"
480+ t `shouldBe` Just "hello world"
481+ WD.click <=< WD.findElem $ WD.ByTag "button"
482+ input <- readRef inputRef
483+ input `shouldBe` "hello world"
712484 ) $ do
713485 e <- textAreaElement def
714486 click <- button "save"
@@ -716,9 +488,10 @@ tests withDebugging wdConfig caps _selenium = do
716488 it "captures user input after switchover" $ runWD $ do
717489 inputRef <- newRef ("" :: Text)
718490 let checkValue = do
719− WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "textarea")
720− WD.click =<< findElemWithRetry (WD.ByTag "button")
721− readRef inputRef `shouldBeWithRetryM` "hello world"
491+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
492+ WD.click <=< WD.findElem $ WD.ByTag "button"
493+ input <- readRef inputRef
494+ input `shouldBe` "hello world"
722495 testWidget (pure ()) checkValue $ do
723496 e <- textAreaElement def
724497 click <- button "save"
@@ -726,21 +499,23 @@ tests withDebugging wdConfig caps _selenium = do
726499 it "sets focus appropriately" $ runWD $ do
727500 focusRef <- newRef False
728501 let checkValue = do
729− readRef focusRef `shouldBeWithRetryM` False
730− e <- findElemWithRetry $ WD.ByTag "textarea"
502+ readRef focusRef >>= flip shouldBe False
503+ e <- WD.findElem $ WD.ByTag "textarea"
731504 WD.click e
732− readRef focusRef `shouldBeWithRetryM` True
505+ liftIO $ threadDelay 100000
506+ readRef focusRef >>= flip shouldBe True
733507 testWidget (pure ()) checkValue $ do
734508 e <- textAreaElement def
735509 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
736510 it "sets focus when focus occurs before hydration" $ runWD $ do
737511 focusRef <- newRef False
738512 let setup = do
739− e <- findElemWithRetry $ WD.ByTag "textarea"
513+ e <- WD.findElem $ WD.ByTag "textarea"
740514 WD.click e
741− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
742− readRef focusRef `shouldBeWithRetryM` False
743− check = readRef focusRef `shouldBeWithRetryM` True
515+ hasFocus <- (== e) <$> WD.activeElem
516+ hasFocus `shouldBe` True
517+ readRef focusRef >>= flip shouldBe False
518+ check = readRef focusRef >>= flip shouldBe True
744519 testWidget setup check $ do
745520 e <- textAreaElement def
746521 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -749,110 +524,31 @@ tests withDebugging wdConfig caps _selenium = do
749524 valueRef <- newRef ("" :: Text)
750525 setValueChan :: Chan Text <- liftIO newChan
751526 let checkValue = do
752− readRef valueByUIRef `shouldBeWithRetryM` ""
753− readRef valueRef `shouldBeWithRetryM` ""
754− e <- findElemWithRetry $ WD.ByTag "textarea"
527+ readRef valueByUIRef >>= flip shouldBe ""
528+ readRef valueRef >>= flip shouldBe ""
529+ e <- WD.findElem $ WD.ByTag "textarea"
755530 WD.sendKeys "hello" e
756− readRef valueByUIRef `shouldBeWithRetryM` "hello"
757− readRef valueRef `shouldBeWithRetryM` "hello"
531+ liftIO $ threadDelay 100000
532+ readRef valueByUIRef >>= flip shouldBe "hello"
533+ readRef valueRef >>= flip shouldBe "hello"
758534 liftIO $ writeChan setValueChan "world"
759− readRef valueByUIRef `shouldBeWithRetryM` "hello"
760− readRef valueRef `shouldBeWithRetryM` "world"
535+ liftIO $ threadDelay 100000
536+ readRef valueByUIRef >>= flip shouldBe "hello"
537+ readRef valueRef >>= flip shouldBe "world"
761538 testWidget (pure ()) checkValue $ do
762539 setValue' <- triggerEventWithChan setValueChan
763540 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
764541 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
765542 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"
774− pure e
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"
788− pure e
789− checkHydrated e = do
790− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
791− readRef textarea `shouldBeWithRetryM` Nothing
792− testWidget' checkStatic checkHydrated $ do
793− pb <- getPostBuild
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
797− let checkBoth = 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
803− pb <- getPostBuild
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
823− pure ()
824− testWidget' checkStatic checkHydrated $ do
825− pb <- getPostBuild
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
839− pure (textarea, p)
840− checkHydrated (textarea, p) = do
841− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
842− shouldContainText "pbabc" p
843− pure ()
844− testWidget' checkStatic checkHydrated $ do
845− pb <- getPostBuild
846− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
847− el "p" $ dynText $ _textAreaElement_value e
848543
849− describe "hydration/immediate" $ do
544+ describe "hydration/immediate" $ session' $ do
850545 it "captures user input after switchover" $ runWD $ do
851546 inputRef :: IORef Text <- newRef ""
852547 let checkValue = do
853− WD.sendKeys "hello world" <=< findElemWithRetry $ WD.ByTag "textarea"
854− WD.click <=< findElemWithRetry $ WD.ByTag "button"
855− readRef inputRef `shouldBeWithRetryM` "hello world"
548+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
549+ WD.click <=< WD.findElem $ WD.ByTag "button"
550+ input <- liftIO $ readRef inputRef
551+ input `shouldBe` "hello world"
856552 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
857553 e <- textAreaElement def
858554 click <- button "save"
@@ -860,10 +556,11 @@ tests withDebugging wdConfig caps _selenium = do
860556 it "sets focus appropriately" $ runWD $ do
861557 focusRef <- newRef False
862558 let checkValue = do
863− readRef focusRef `shouldBeWithRetryM` False
864− e <- findElemWithRetry $ WD.ByTag "textarea"
559+ readRef focusRef >>= flip shouldBe False
560+ e <- WD.findElem $ WD.ByTag "textarea"
865561 WD.click e
866− readRef focusRef `shouldBeWithRetryM` True
562+ liftIO $ threadDelay 100000
563+ readRef focusRef >>= flip shouldBe True
867564 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
868565 e <- textAreaElement def
869566 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -872,15 +569,17 @@ tests withDebugging wdConfig caps _selenium = do
872569 valueRef :: IORef Text <- newRef ""
873570 setValueChan :: Chan Text <- liftIO newChan
874571 let checkValue = do
875− readRef valueByUIRef `shouldBeWithRetryM` ""
876− readRef valueRef `shouldBeWithRetryM` ""
877− e <- findElemWithRetry $ WD.ByTag "textarea"
572+ readRef valueByUIRef >>= flip shouldBe ""
573+ readRef valueRef >>= flip shouldBe ""
574+ e <- WD.findElem $ WD.ByTag "textarea"
878575 WD.sendKeys "hello" e
879− readRef valueByUIRef `shouldBeWithRetryM` "hello"
880− readRef valueRef `shouldBeWithRetryM` "hello"
576+ liftIO $ threadDelay 100000
577+ readRef valueByUIRef >>= flip shouldBe "hello"
578+ readRef valueRef >>= flip shouldBe "hello"
881579 liftIO $ writeChan setValueChan "world"
882− readRef valueByUIRef `shouldBeWithRetryM` "hello"
883− readRef valueRef `shouldBeWithRetryM` "world"
580+ liftIO $ threadDelay 100000
581+ readRef valueByUIRef >>= flip shouldBe "hello"
582+ readRef valueRef >>= flip shouldBe "world"
884583 testWidget (pure ()) checkValue $ do
885584 setValue' <- triggerEventWithChan setValueChan
886585 prerender_ (pure ()) $ do
@@ -888,26 +587,26 @@ tests withDebugging wdConfig caps _selenium = do
888587 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
889588 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
890589
891− session' "selectElement" $ do
590+ describe "selectElement" $ do
892591 let options :: DomBuilder t m => m ()
893592 options = do
894593 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
895594 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
896595 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
897− describe "hydration" $ do
596+ describe "hydration" $ session' $ do
898597 it "sets initial value correctly" $ runWD $ do
899598 inputRef <- newRef ("" :: Text)
900599 let setup = do
901− e <- findElemWithRetry $ WD.ByTag "select"
600+ e <- WD.findElem $ WD.ByTag "select"
902601 assertAttr e "value" (Just "three")
903− WD.click =<< findElemWithRetry (WD.ById "two")
602+ WD.click <=< WD.findElem $ WD.ById "two"
904603 pure e
905604 check e = do
906605 assertAttr e "value" (Just "two")
907− readRef inputRef `shouldBeWithRetryM` "three"
908− WD.click =<< findElemWithRetry (WD.ByTag "button")
606+ readRef inputRef >>= (`shouldBe` "three")
607+ WD.click <=< WD.findElem $ WD.ByTag "button"
909608 assertAttr e "value" (Just "two")
910− readRef inputRef `shouldBeWithRetryM` "two"
609+ readRef inputRef >>= (`shouldBe` "two")
911610 testWidget' setup check $ do
912611 (e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options
913612 click <- button "save"
@@ -916,12 +615,12 @@ tests withDebugging wdConfig caps _selenium = do
916615 it "captures user input after switchover" $ runWD $ do
917616 inputRef <- newRef ("" :: Text)
918617 let checkValue = do
919− e <- findElemWithRetry $ WD.ByTag "select"
618+ e <- WD.findElem $ WD.ByTag "select"
920619 assertAttr e "value" (Just "one")
921− WD.click =<< findElemWithRetry (WD.ById "two")
620+ WD.click <=< WD.findElem $ WD.ById "two"
922621 assertAttr e "value" (Just "two")
923− WD.click =<< findElemWithRetry (WD.ByTag "button")
924− readRef inputRef `shouldBeWithRetryM` "two"
622+ WD.click <=< WD.findElem $ WD.ByTag "button"
623+ readRef inputRef >>= (`shouldBe` "two")
925624 testWidget (pure ()) checkValue $ do
926625 (e, ()) <- selectElement def options
927626 click <- button "save"
@@ -929,21 +628,23 @@ tests withDebugging wdConfig caps _selenium = do
929628 it "sets focus appropriately" $ runWD $ do
930629 focusRef <- newRef False
931630 let checkValue = do
932− readRef focusRef `shouldBeWithRetryM` False
933− e <- findElemWithRetry $ WD.ByTag "select"
631+ readRef focusRef >>= flip shouldBe False
632+ e <- WD.findElem $ WD.ByTag "select"
934633 WD.click e
935− readRef focusRef `shouldBeWithRetryM` True
634+ liftIO $ threadDelay 100000
635+ readRef focusRef >>= flip shouldBe True
936636 testWidget (pure ()) checkValue $ do
937637 (e, ()) <- selectElement def options
938638 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
939639 it "sets focus when focus occurs before hydration" $ runWD $ do
940640 focusRef <- newRef False
941641 let setup = do
942− e <- findElemWithRetry $ WD.ByTag "select"
642+ e <- WD.findElem $ WD.ByTag "select"
943643 WD.click e
944− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
945− readRef focusRef `shouldBeWithRetryM` False
946− check = readRef focusRef `shouldBeWithRetryM` True
644+ hasFocus <- (== e) <$> WD.activeElem
645+ hasFocus `shouldBe` True
646+ readRef focusRef >>= flip shouldBe False
647+ check = readRef focusRef >>= flip shouldBe True
947648 testWidget setup check $ do
948649 (e, ()) <- selectElement def options
949650 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
@@ -952,29 +653,31 @@ tests withDebugging wdConfig caps _selenium = do
952653 valueRef <- newRef ("" :: Text)
953654 setValueChan :: Chan Text <- liftIO newChan
954655 let checkValue = do
955− e <- findElemWithRetry $ WD.ByTag "select"
656+ e <- WD.findElem $ WD.ByTag "select"
956657 assertAttr e "value" (Just "one")
957− readRef valueByUIRef `shouldBeWithRetryM` "one"
958− readRef valueRef `shouldBeWithRetryM` "one"
959− WD.click <=< findElemWithRetry $ WD.ById "two"
960− readRef valueByUIRef `shouldBeWithRetryM` "two"
961− readRef valueRef `shouldBeWithRetryM` "two"
658+ readRef valueByUIRef >>= flip shouldBe "one"
659+ readRef valueRef >>= flip shouldBe "one"
660+ WD.click <=< WD.findElem $ WD.ById "two"
661+ liftIO $ threadDelay 100000
662+ readRef valueByUIRef >>= flip shouldBe "two"
663+ readRef valueRef >>= flip shouldBe "two"
962664 liftIO $ writeChan setValueChan "three"
963− readRef valueByUIRef `shouldBeWithRetryM` "two"
964− readRef valueRef `shouldBeWithRetryM` "three"
665+ liftIO $ threadDelay 100000
666+ readRef valueByUIRef >>= flip shouldBe "two"
667+ readRef valueRef >>= flip shouldBe "three"
965668 testWidget (pure ()) checkValue $ do
966669 setValue' <- triggerEventWithChan setValueChan
967670 (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
968671 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
969672 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
970673
971− describe "hydration/immediate" $ do
674+ describe "hydration/immediate" $ session' $ do
972675 it "captures user input after switchover" $ runWD $ do
973676 inputRef :: IORef Text <- newRef ""
974677 let checkValue = do
975− WD.click <=< findElemWithRetry $ WD.ById "two"
976− WD.click <=< findElemWithRetry $ WD.ByTag "button"
977− readRef inputRef `shouldBeWithRetryM` "two"
678+ WD.click <=< WD.findElem $ WD.ById "two"
679+ WD.click <=< WD.findElem $ WD.ByTag "button"
680+ readRef inputRef >>= flip shouldBe "two"
978681 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
979682 (e, ()) <- selectElement def options
980683 click <- button "save"
@@ -982,16 +685,17 @@ tests withDebugging wdConfig caps _selenium = do
982685 it "sets focus appropriately" $ runWD $ do
983686 focusRef <- newRef False
984687 let checkValue = do
985− readRef focusRef `shouldBeWithRetryM` False
986− e <- findElemWithRetry $ WD.ByTag "select"
688+ readRef focusRef >>= flip shouldBe False
689+ e <- WD.findElem $ WD.ByTag "select"
987690 WD.click e
988− readRef focusRef `shouldBeWithRetryM` True
691+ liftIO $ threadDelay 100000
692+ readRef focusRef >>= flip shouldBe True
989693 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
990694 (e, ()) <- selectElement def options
991695 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
992696 it "has correct initial value" $ runWD $ do
993697 valueRef :: IORef Text <- newRef ""
994− let checkValue = readRef valueRef `shouldBeWithRetryM` "one"
698+ let checkValue = readRef valueRef >>= flip shouldBe "one"
995699 testWidget (pure ()) checkValue $ do
996700 prerender_ (pure ()) $ do
997701 (e, ()) <- selectElement def { _selectElementConfig_initialValue = "one" } options
@@ -1001,12 +705,14 @@ tests withDebugging wdConfig caps _selenium = do
1001705 valueRef :: IORef Text <- newRef ""
1002706 setValueChan :: Chan Text <- liftIO newChan
1003707 let checkValue = do
1004− WD.click =<< findElemWithRetry (WD.ById "two")
1005− readRef valueByUIRef `shouldBeWithRetryM` "two"
1006− readRef valueRef `shouldBeWithRetryM` "two"
708+ WD.click <=< WD.findElem $ WD.ById "two"
709+ liftIO $ threadDelay 100000
710+ readRef valueByUIRef >>= flip shouldBe "two"
711+ readRef valueRef >>= flip shouldBe "two"
1007712 liftIO $ writeChan setValueChan "three"
1008− readRef valueByUIRef `shouldBeWithRetryM` "two"
1009− readRef valueRef `shouldBeWithRetryM` "three"
713+ liftIO $ threadDelay 100000
714+ readRef valueByUIRef >>= flip shouldBe "two"
715+ readRef valueRef >>= flip shouldBe "three"
1010716 testWidget (pure ()) checkValue $ do
1011717 setValue' <- triggerEventWithChan setValueChan
1012718 prerender_ (pure ()) $ do
@@ -1014,12 +720,12 @@ tests withDebugging wdConfig caps _selenium = do
1014720 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
1015721 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
1016722
1017− session' "prerender" $ do
723+ describe "prerender" $ session' $ do
1018724 it "works in simple case" $ runWD $ do
1019725 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
1020726 prerender_ (text "One") (text "Two")
1021727 it "removes element correctly" $ runWD $ do
1022− testWidget' (findElemWithRetry $ WD.ByTag "span") elementShouldBeRemoved $ do
728+ testWidget' (WD.findElem $ WD.ByTag "span") elementShouldBeRemoved $ do
1023729 prerender_ (el "span" $ text "One") (text "Two")
1024730 it "can be nested in server widget" $ runWD $ do
1025731 testWidget (checkBodyText "One") (checkBodyText "Three") $ do
@@ -1059,9 +765,9 @@ tests withDebugging wdConfig caps _selenium = do
1059765 pb <- getPostBuild
1060766 performEvent_ $ liftIO (putMVar lock ()) <$ pb
1061767 it "result Dynamic is updated *after* switchover" $ runWD $ do
1062− let preSwitchover = checkBodyText "PostBuild"
1063− check = checkBodyText "Client"
1064− testWidget preSwitchover check $ void $ do
768+ let static = shouldContainText "PostBuild" =<< WD.findElem (WD.ByTag "body")
769+ check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
770+ testWidget static check $ void $ do
1065771 d <- prerender (pure "Initial") (pure "Client")
1066772 pb <- getPostBuild
1067773 initial <- sample $ current d
@@ -1069,39 +775,32 @@ tests withDebugging wdConfig caps _selenium = do
1069775 -- This essentially checks that the client IO runs *after* switchover/postBuild,
1070776 -- thus can't create conflicting DOM
1071777 it "can't exploit IO to break hydration" $ runWD $ do
1072− let preSwitchover = checkBodyText "Initial"
1073− testWidgetStatic preSwitchover $ void $ do
778+ let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
779+ testWidgetStatic static $ void $ do
1074780 ref <- liftIO $ newRef "Initial"
1075781 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
1076782 text <=< liftIO $ readRef ref
1077783 -- As above, so below
1078784 it "can't exploit triggerEvent to break hydration" $ runWD $ do
1079− let preSwitchover = checkBodyText "Initial"
1080− check = checkBodyText "Client"
1081− testWidget preSwitchover check $ void $ do
785+ let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
786+ check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
787+ testWidget static check $ void $ do
1082788 (e, trigger) <- newTriggerEvent
1083789 prerender_ (pure ()) (liftIO $ trigger "Client")
1084790 textNode $ TextNodeConfig "Initial" $ Just e
1085791
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 ()
1094−
1095− session' "runWithReplace" $ do
792+ describe "runWithReplace" $ session' $ do
1096793 it "works" $ runWD $ do
1097794 replaceChan :: Chan Text <- liftIO newChan
1098− let setup = findElemWithRetry $ WD.ByTag "div"
795+ let setup = WD.findElem $ WD.ByTag "div"
1099796 check ssr = do
1100797 -- Check that the original element still exists and has the correct text
1101− shouldContainText "two" ssr
1102− liftIO $ writeChan replaceChan "three"
798+ WD.getText ssr >>= flip shouldBe "two"
799+ liftIO $ do
800+ writeChan replaceChan "three"
801+ threadDelay 100000
1103802 elementShouldBeRemoved ssr
1104− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
803+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1105804 testWidget' setup check $ do
1106805 replace <- triggerEventWithChan replaceChan
1107806 pb <- getPostBuild
@@ -1111,13 +810,15 @@ tests withDebugging wdConfig caps _selenium = do
1111810 ]
1112811 it "can be nested in initial widget" $ runWD $ do
1113812 replaceChan :: Chan Text <- liftIO newChan
1114− let setup = findElemWithRetry $ WD.ByTag "div"
813+ let setup = WD.findElem $ WD.ByTag "div"
1115814 check ssr = do
1116815 -- Check that the original element still exists and has the correct text
1117− shouldContainText "two" ssr
1118− liftIO $ writeChan replaceChan "three"
816+ WD.getText ssr >>= flip shouldBe "two"
817+ liftIO $ do
818+ writeChan replaceChan "three"
819+ threadDelay 100000
1119820 elementShouldBeRemoved ssr
1120− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
821+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1121822 testWidget' setup check $ void $ flip runWithReplace never $ do
1122823 replace <- triggerEventWithChan replaceChan
1123824 pb <- getPostBuild
@@ -1126,14 +827,16 @@ tests withDebugging wdConfig caps _selenium = do
1126827 , el "span" . text <$> replace
1127828 ]
1128829 it "can be nested in postBuild widget" $ runWD $ do
1129− replaceChan :: Chan Text <- liftIO newChan
1130− let setup = findElemWithRetry $ WD.ByTag "div"
830+ replaceChan <- liftIO newChan
831+ let setup = WD.findElem $ WD.ByTag "div"
1131832 check ssr = do
1132833 -- Check that the original element still exists and has the correct text
1133− shouldContainText "two" ssr
1134− liftIO $ writeChan replaceChan "three"
834+ WD.getText ssr >>= flip shouldBe "two"
835+ liftIO $ do
836+ writeChan replaceChan "three"
837+ threadDelay 100000
1135838 elementShouldBeRemoved ssr
1136− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
839+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1137840 testWidget' setup check $ void $ do
1138841 pb <- getPostBuild
1139842 runWithReplace (pure ()) $ ffor pb $ \() -> do
@@ -1159,15 +862,17 @@ tests withDebugging wdConfig caps _selenium = do
1159862 replaceChan2 :: Chan Text <- liftIO newChan
1160863 lock :: MVar () <- liftIO newEmptyMVar
1161864 let check = do
1162− shouldContainText "" =<< findElemWithRetry (WD.ByTag "body")
865+ shouldContainText "" =<< WD.findElem (WD.ByTag "body")
1163866 liftIO $ do
1164867 writeChan replaceChan1 "one"
1165868 takeMVar lock
1166− one <- findElemWithRetry $ WD.ByTag "div"
1167− shouldContainText "pb" one
1168− liftIO $ writeChan replaceChan2 "two"
869+ one <- WD.findElem $ WD.ByTag "div"
870+ WD.getText one >>= flip shouldBe "pb"
871+ liftIO $ do
872+ writeChan replaceChan2 "two"
873+ threadDelay 100000
1169874 elementShouldBeRemoved one
1170− shouldContainText "two" =<< findElemWithRetry (WD.ByTag "span")
875+ shouldContainText "two" =<< WD.findElem (WD.ByTag "span")
1171876 testWidget (pure ()) check $ void $ do
1172877 replace1 <- triggerEventWithChan replaceChan1
1173878 runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
@@ -1208,12 +913,14 @@ tests withDebugging wdConfig caps _selenium = do
1208913 it "works in immediate mode (RHS of prerender)" $ runWD $ do
1209914 replaceChan :: Chan Text <- liftIO newChan
1210915 let check = do
1211− checkBodyText "one"
1212− one <- findElemWithRetry $ WD.ByTag "div"
1213− shouldContainText "one" one
1214− liftIO $ writeChan replaceChan "pb"
916+ one <- WD.findElem $ WD.ByTag "div"
917+ shouldContainText "one" =<< WD.findElem (WD.ByTag "body")
918+ WD.getText one >>= flip shouldBe "one"
919+ liftIO $ do
920+ writeChan replaceChan "pb"
921+ threadDelay 100000
1215922 elementShouldBeRemoved one
1216− shouldContainText "pb" =<< findElemWithRetry (WD.ByTag "span")
923+ shouldContainText "pb" =<< WD.findElem (WD.ByTag "span")
1217924 testWidget (pure ()) check $ void $ do
1218925 replace <- triggerEventWithChan replaceChan
1219926 prerender_ blank $ do
@@ -1221,12 +928,14 @@ tests withDebugging wdConfig caps _selenium = do
1221928 it "works with postBuild in immediate mode (RHS of prerender)" $ runWD $ do
1222929 replaceChan :: Chan Text <- liftIO newChan
1223930 let check = do
1224− checkBodyText "two"
1225− two <- findElemWithRetry $ WD.ByTag "div"
1226− shouldContainText "two" two
1227− liftIO $ writeChan replaceChan "three"
931+ two <- WD.findElem $ WD.ByTag "div"
932+ shouldContainText "two" =<< WD.findElem (WD.ByTag "body")
933+ WD.getText two >>= flip shouldBe "two"
934+ liftIO $ do
935+ writeChan replaceChan "three"
936+ threadDelay 100000
1228937 elementShouldBeRemoved two
1229− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
938+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1230939 testWidget (pure ()) check $ void $ do
1231940 replace <- triggerEventWithChan replaceChan
1232941 prerender_ blank $ do
@@ -1236,61 +945,7 @@ tests withDebugging wdConfig caps _selenium = do
1236945 , el "span" . text <$> replace
1237946 ]
1238947
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
1242− let
1243− preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
1244− check () = do
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
1250− el "div" $ do
1251− text "before|"
1252− _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
1253− text "|after"
1254− it "ignores extra ending bracketing comment" $ runWD $ do
1255− replaceChan :: Chan () <- liftIO newChan
1256− let
1257− preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"
1258− check () = do
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
1264− el "div" $ do
1265− text "before|"
1266− _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
1267− text "|after"
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
1273− let
1274− preSwitchover = do
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
1282− check () = do
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
1288− el "div" $ do
1289− text "before|"
1290− _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
1291− text "|after"
1292−
1293− session' "traverseDMapWithKeyWithAdjust" $ do
948+ describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1294949 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
1295950 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1296951 elClass "span" "key" $ text $ textKey k
@@ -1298,58 +953,58 @@ tests withDebugging wdConfig caps _selenium = do
1298953 pure (Identity v)
1299954 checkItem :: WD.Element -> Text -> Text -> WD ()
1300955 checkItem li k v = do
1301− putStrLnDebug "checkItem"
1302− shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1303− shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
956+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
957+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1304958 checkInitialItems dm xs = do
1305− putStrLnDebug "checkInitialItems"
1306959 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1307960 forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
1308− getAndCheckInitialItems dm = withRetry $ do
1309− putStrLnDebug "getAndCheckInitialItems"
961+ getAndCheckInitialItems dm = do
1310962 xs <- WD.findElems (WD.ByTag "li")
1311963 checkInitialItems dm xs
1312964 pure xs
1313965 checkRemoval chan k = do
1314− putStrLnDebug "checkRemoval"
1315− e <- findElemWithRetry (WD.ById $ textKey k)
1316− liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
966+ e <- WD.findElem (WD.ById $ textKey k)
967+ liftIO $ do
968+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
969+ threadDelay 100000
1317970 elementShouldBeRemoved e
1318971 checkReplace chan k v = do
1319− putStrLnDebug "checkReplace"
1320− e <- findElemWithRetry (WD.ById $ textKey k)
1321− liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
972+ e <- WD.findElem (WD.ById $ textKey k)
973+ liftIO $ do
974+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
975+ threadDelay 100000
1322976 elementShouldBeRemoved e
1323− e' <- findElemWithRetry $ WD.ById $ textKey k
977+ e' <- WD.findElem (WD.ById $ textKey k)
1324978 checkItem e' (textKey k) (T.pack $ show v)
1325979 checkInsert chan k v = do
1326− putStrLnDebug "checkInsert"
1327− liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
1328− e <- findElemWithRetry (WD.ById $ textKey k)
980+ liftIO $ do
981+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
982+ threadDelay 100000
983+ e <- WD.findElem (WD.ById $ textKey k)
1329984 checkItem e (textKey k) (T.pack $ show v)
1330985 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
1331986 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1332987 chan <- liftIO newChan
1333− let preSwitchover :: WD [WD.Element]
1334− preSwitchover = getAndCheckInitialItems keyMap
988+ let static :: WD [WD.Element]
989+ static = getAndCheckInitialItems keyMap
1335990 check :: [WD.Element] -> WD ()
1336991 check xs = do
1337992 checkInitialItems keyMap xs
1338993 checkRemoval chan Key_Int
1339994 checkReplace chan Key_Char 'B'
1340995 checkInsert chan Key_Bool True
1341− testWidget' preSwitchover check $ do
996+ testWidget' static check $ do
1342997 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1343998 liftIO $ dmap `H.shouldBe` keyMap
1344999 it "handles postBuild correctly" $ runWD $ do
13451000 chan <- liftIO newChan
1346− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1001+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
13471002 check xs = do
1348− withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1003+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch keyMap) xs
13491004 checkRemoval chan Key_Int
13501005 checkInsert chan Key_Char 'B'
13511006 checkReplace chan Key_Bool True
1352− testWidget' preSwitchover check $ void $ do
1007+ testWidget' static check $ void $ do
13531008 pb <- getPostBuild
13541009 replace <- triggerEventWithChan chan
13551010 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1382,7 +1037,7 @@ tests withDebugging wdConfig caps _selenium = do
13821037 it "handles postBuild correctly in prerender" $ runWD $ do
13831038 chan <- liftIO newChan
13841039 let check = do
1385− _ <- getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1040+ _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
13861041 checkRemoval chan Key_Int
13871042 checkInsert chan Key_Char 'B'
13881043 checkReplace chan Key_Bool True
@@ -1393,7 +1048,7 @@ tests withDebugging wdConfig caps _selenium = do
13931048 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
13941049 liftIO $ dmap `H.shouldBe` keyMap
13951050
1396− session' "traverseIntMapWithKeyWithAdjust" $ do
1051+ describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
13971052 let textKeyInt k = "key" <> T.pack (show k)
13981053 intMap = IntMap.fromList
13991054 [ (1, "one")
@@ -1407,89 +1062,89 @@ tests withDebugging wdConfig caps _selenium = do
14071062 pure v
14081063 checkItem :: WD.Element -> Text -> Text -> WD ()
14091064 checkItem li k v = do
1410− putStrLnDebug "checkItem"
1411− shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1412− shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
1065+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1066+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
14131067 checkInitialItems dm xs = do
1414− putStrLnDebug "checkInitialItems"
14151068 liftIO $ assertEqual "Wrong amount of items in DOM" (IntMap.size dm) (length xs)
14161069 forM_ (zip xs (IntMap.toList dm)) $ \(e, (k, v)) -> checkItem e (textKeyInt k) v
1417− getAndCheckInitialItems dm = withRetry $ do
1418− putStrLnDebug "getAndCheckInitialItems"
1070+ getAndCheckInitialItems dm = do
14191071 xs <- WD.findElems (WD.ByTag "li")
14201072 checkInitialItems dm xs
14211073 pure xs
14221074 checkRemoval chan k = do
1423− putStrLnDebug "checkRemoval"
1424− e <- findElemWithRetry (WD.ById $ textKeyInt k)
1425− liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1075+ e <- WD.findElem (WD.ById $ textKeyInt k)
1076+ liftIO $ do
1077+ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1078+ threadDelay 100000
14261079 elementShouldBeRemoved e
14271080 checkReplace chan k v = do
1428− putStrLnDebug "checkReplace"
1429− e <- findElemWithRetry (WD.ById $ textKeyInt k)
1430− liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1081+ e <- WD.findElem (WD.ById $ textKeyInt k)
1082+ liftIO $ do
1083+ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1084+ threadDelay 100000
14311085 elementShouldBeRemoved e
1432− e' <- findElemWithRetry (WD.ById $ textKeyInt k)
1433− withRetry $ checkItem e' (textKeyInt k) v
1086+ e' <- WD.findElem (WD.ById $ textKeyInt k)
1087+ checkItem e' (textKeyInt k) v
14341088 checkInsert chan k v = do
1435− putStrLnDebug "checkInsert"
1436− liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1437− e <- findElemWithRetry (WD.ById $ textKeyInt k)
1089+ liftIO $ do
1090+ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1091+ threadDelay 100000
1092+ e <- WD.findElem (WD.ById $ textKeyInt k)
14381093 checkItem e (textKeyInt k) v
14391094 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
1095+ it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
14411096 chan <- liftIO newChan
1442− let preSwitchover = getAndCheckInitialItems intMap
1097+ let static = getAndCheckInitialItems intMap
14431098 check xs = do
14441099 checkInitialItems intMap xs
14451100 checkRemoval chan 1
14461101 checkReplace chan 2 "deux"
14471102 checkInsert chan 4 "four"
1448− testWidget' preSwitchover check $ void $ do
1103+ testWidget' static check $ void $ do
14491104 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
14501105 liftIO $ im `H.shouldBe` intMap
1451− xit "handles postBuild correctly" $ runWD $ do
1106+ it "handles postBuild correctly" $ runWD $ do
14521107 chan <- liftIO newChan
1453− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1108+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
14541109 check xs = do
1455− withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1110+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch intMap) xs
14561111 checkRemoval chan 1
14571112 checkInsert chan 2 "deux"
14581113 checkReplace chan 3 "trois"
1459− testWidget' preSwitchover check $ void $ do
1114+ testWidget' static check $ void $ do
14601115 pb <- getPostBuild
14611116 replace <- triggerEventWithChan chan
14621117 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
14631118 liftIO $ dmap `H.shouldBe` intMap
1464− xit "can delete/update/insert when built in prerender" $ runWD $ do
1119+ it "can delete/update/insert when built in prerender" $ runWD $ do
14651120 chan <- liftIO newChan
14661121 let check = do
14671122 _ <- getAndCheckInitialItems intMap
14681123 checkRemoval chan 1
14691124 checkReplace chan 2 "deux"
1470− checkInsert chan 4 "quatre"
1125+ checkInsert chan 3 "trois"
14711126 testWidget (pure ()) check $ do
14721127 replace <- triggerEventWithChan chan
14731128 prerender_ (pure ()) $ do
14741129 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap replace
14751130 liftIO $ dmap `H.shouldBe` intMap
1476− xit "can delete/update/insert when built in immediate mode" $ runWD $ do
1131+ it "can delete/update/insert when built in immediate mode" $ runWD $ do
14771132 chan <- liftIO newChan
14781133 let check = do
14791134 _ <- getAndCheckInitialItems intMap
14801135 checkRemoval chan 1
14811136 checkReplace chan 2 "deux"
1482− checkInsert chan 4 "quatre"
1137+ checkInsert chan 3 "trois"
14831138 testWidget (pure ()) check $ void $ do
14841139 pb <- getPostBuild
14851140 runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
14861141 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
14871142 liftIO $ dmap `H.shouldBe` intMap
14881143 -- Should be fixed by prerender changes!
1489− xit "handles postBuild correctly in prerender" $ runWD $ do
1144+ it "handles postBuild correctly in prerender" $ runWD $ do
14901145 chan <- liftIO newChan
14911146 let check = do
1492− _ <- getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1147+ _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
14931148 checkRemoval chan 1
14941149 checkInsert chan 2 "deux"
14951150 checkReplace chan 3 "trois"
@@ -1500,30 +1155,47 @@ tests withDebugging wdConfig caps _selenium = do
15001155 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
15011156 liftIO $ dmap `H.shouldBe` intMap
15021157
1503− session' "traverseDMapWithKeyWithAdjustWithMove" $ do
1158+ describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
15041159 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1505− widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1506− elClass "span" "key" $ text $ textKey2 k
1160+ widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1161+ elClass "span" "key" $ text $ textKey k
15071162 elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
15081163 pure (Identity v)
1509− textKey2 :: Key2 a -> Text
1510− textKey2 = \case
1164+ textKey :: Key2 a -> Text
1165+ textKey = \case
15111166 Key2_Int i -> "i" <> T.pack (show i)
15121167 Key2_Char c -> "c" <> T.pack [c]
15131168 checkItem :: WD.Element -> Text -> Text -> WD ()
15141169 checkItem li k v = do
1515− shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1516− shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
1170+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1171+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
15171172 checkInitialItems dm xs = do
15181173 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)
1520− getAndCheckInitialItems dm = withRetry $ do
1174+ forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
1175+ getAndCheckInitialItems dm = do
15211176 xs <- WD.findElems (WD.ByTag "li")
15221177 checkInitialItems dm xs
15231178 pure xs
1524− moveSpec
1525− :: (DMap Key2 Identity -> (WD.Element -> Chan (PatchDMapWithMove Key2 Identity) -> WD ()) -> WD ())
1526− -> H.SpecM (WdTestSession ()) ()
1179+ checkRemoval chan k = do
1180+ e <- WD.findElem (WD.ById $ textKey k)
1181+ liftIO $ do
1182+ writeChan chan $ deleteDMapKey k
1183+ threadDelay 100000
1184+ elementShouldBeRemoved e
1185+ checkReplace chan k v = do
1186+ e <- WD.findElem (WD.ById $ textKey k)
1187+ liftIO $ do
1188+ writeChan chan $ insertDMapKey k (Identity v)
1189+ threadDelay 100000
1190+ elementShouldBeRemoved e
1191+ e' <- WD.findElem (WD.ById $ textKey k)
1192+ checkItem e' (textKey k) (T.pack $ show v)
1193+ checkInsert chan k v = do
1194+ liftIO $ do
1195+ writeChan chan $ insertDMapKey k (Identity v)
1196+ threadDelay 100000
1197+ e <- WD.findElem (WD.ById $ textKey k)
1198+ checkItem e (textKey k) (T.pack $ show v)
15271199 moveSpec testMove = do
15281200 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
15291201 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
@@ -1551,26 +1223,26 @@ tests withDebugging wdConfig caps _selenium = do
15511223
15521224 describe "hydration" $ moveSpec $ \initMap test -> do
15531225 chan <- liftIO newChan
1554− let preSwitchover = getAndCheckInitialItems initMap
1226+ let static = getAndCheckInitialItems initMap
15551227 check xs = do
15561228 checkInitialItems initMap xs
1557− body <- getBody
1229+ body <- WD.findElem (WD.ByTag "body")
15581230 test body chan
1559− testWidget' preSwitchover check $ void $ do
1231+ testWidget' static check $ void $ do
15601232 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
15611233 liftIO $ assertEqual "DMap" initMap dmap
15621234
15631235 describe "hydration/immediate" $ moveSpec $ \initMap test -> do
15641236 chan <- liftIO newChan
15651237 replace <- liftIO newChan
1566− lock :: MVar () <- liftIO newEmptyMVar
1238+ lock <- liftIO newEmptyMVar
15671239 let check = do
15681240 liftIO $ do
15691241 writeChan replace ()
15701242 takeMVar lock
15711243 xs <- getAndCheckInitialItems initMap
15721244 checkInitialItems initMap xs
1573− body <- getBody
1245+ body <- WD.findElem (WD.ByTag "body")
15741246 test body chan
15751247 testWidget (pure ()) check $ void $ do
15761248 e <- triggerEventWithChan replace
@@ -1580,26 +1252,24 @@ tests withDebugging wdConfig caps _selenium = do
15801252 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
15811253 liftIO $ assertEqual "DMap" initMap dmap
15821254
1583− session' "hydrating invalid HTML" $ do
1584− xit "can hydrate list in paragraph" $ runWD $ do
1585− let preSwitchover = do
1586− checkBodyText "before\ninner\nafter"
1255+ describe "hydrating invalid HTML" $ session' $ do
1256+ it "can hydrate list in paragraph" $ runWD $ do
1257+ let static = do
1258+ body <- WD.findElem (WD.ByTag "body")
1259+ shouldContainText "before\ninner\nafter" body
15871260 -- Two <p> tags should be present
1588− (p1, p2) <- WD.findElems (WD.ByTag "p") >>= \case
1589− [p1, p2] -> pure (p1, p2)
1590− _ -> error "Unexpected number of `p` tags (expected 2)"
1591− ol <- findElemWithRetry (WD.ByTag "ol")
1261+ [p1, p2] <- WD.findElems (WD.ByTag "p")
1262+ ol <- WD.findElem (WD.ByTag "ol")
15921263 shouldContainText "before" p1
15931264 shouldContainText "inner" ol
15941265 shouldContainText "" p2
1595− pure (p1, ol, p2)
1596− check (p1, ol, p2) = do
1597− checkBodyText "before\ninner\nafter"
1266+ pure (body, p1, ol, p2)
1267+ check (body, p1, ol, p2) = do
1268+ shouldContainText "before\ninner\nafter" body
15981269 shouldContainText "before\ninner\nafter" p1
15991270 elementShouldBeRemoved ol
16001271 elementShouldBeRemoved p2
1601− -- Don't fail fatally when hydration encounters the invalid DOM
1602− testWidgetDebug' False withDebugging preSwitchover check $ do
1272+ testWidget' static check $ do
16031273 -- This is deliberately invalid HTML, the browser will interpret it as
16041274 -- <p>before</p><ol>inner</ol>after<p></p>
16051275 el "p" $ do
@@ -1607,29 +1277,6 @@ tests withDebugging wdConfig caps _selenium = do
16071277 el "ol" $ text "inner"
16081278 text "after"
16091279
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
1615− let doCheck = 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"
1632−
16331280data Selenium = Selenium
16341281 { _selenium_portNumber :: PortNumber
16351282 , _selenium_stopServer :: IO ()
@@ -1646,10 +1293,11 @@ startSeleniumServer port = do
16461293
16471294withSeleniumServer :: (Selenium -> IO ()) -> IO ()
16481295withSeleniumServer f = do
1649− stopServer <- startSeleniumServer seleniumPort
1296+ port <- getFreePort
1297+ stopServer <- startSeleniumServer port
16501298 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
16511299 f $ Selenium
1652− { _selenium_portNumber = seleniumPort
1300+ { _selenium_portNumber = port
16531301 , _selenium_stopServer = stopServer
16541302 }
16551303
@@ -1660,163 +1308,121 @@ triggerEventWithChan chan = do
16601308 prerender_ (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
16611309 pure e
16621310
1663−shouldBeWithRetryM :: (Eq a, Show a) => WD a -> a -> WD ()
1664−shouldBeWithRetryM m expected = withRetry $ do
1665− got <- m
1666− got `shouldBe` expected
1667−
16681311assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
16691312assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
16701313
16711314elementShouldBeRemoved :: WD.Element -> WD ()
1672−elementShouldBeRemoved e = withRetry $ do
1315+elementShouldBeRemoved e = do
16731316 try (WD.getText e) >>= \case
16741317 Left (WD.FailedCommand WD.StaleElementReference _) -> return ()
16751318 Left err -> throwM err
16761319 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
16771320
16781321shouldContainText :: Text -> WD.Element -> WD ()
1679−shouldContainText t = withRetry . shouldContainTextNoRetry t
1680−
1681−shouldContainTextNoRetry :: Text -> WD.Element -> WD ()
1682−shouldContainTextNoRetry t = flip shouldBe t <=< WD.getText
1322+shouldContainText t = flip shouldBe t <=< WD.getText
16831323
16841324checkBodyText :: Text -> WD ()
16851325checkBodyText = checkTextInTag "body"
16861326
16871327checkTextInTag :: Text -> Text -> WD ()
1688−checkTextInTag t expected = do
1689− e <- findElemWithRetry (WD.ByTag t)
1690− shouldContainText expected e
1328+checkTextInTag t expected = WD.findElem (WD.ByTag t) >>= shouldContainText expected
16911329
16921330checkTextInId :: Text -> Text -> WD ()
1693−checkTextInId i expected = do
1694− e <- findElemWithRetry (WD.ById i)
1695− shouldContainText expected e
1696−
1697−findElemWithRetry :: Selector -> WD WD.Element
1698−findElemWithRetry = withRetry . WD.findElem
1699−
1700−findElemsWithRetry :: Selector -> WD [WD.Element]
1701−findElemsWithRetry = withRetry . WD.findElems
1702−
1703−getBody :: WD WD.Element
1704−getBody = WD.findElem $ WD.ByTag "body"
1705−
1706−withRetry :: forall a. WD a -> WD a
1707−withRetry a = wait 300
1708− where wait :: Int -> WD a
1709− wait 0 = a
1710− wait n = try a >>= \case
1711− Left (e :: SomeException) -> do
1712− liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
1713− wait $ n - 1
1714− Right v -> return v
1331+checkTextInId i expected = WD.findElem (WD.ById i) >>= shouldContainText expected
17151332
17161333divId :: DomBuilder t m => Text -> m a -> m a
17171334divId i = elAttr "div" ("id" =: i)
17181335
17191336type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js t m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadIO m)
17201337
1721−testWidgetStaticDebug
1722− :: Bool
1723− -> WD b
1338+testWidgetStatic
1339+ :: WD b
17241340 -- ^ Webdriver commands to run before JS runs and after hydration switchover
17251341 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17261342 -- ^ Widget we are testing
17271343 -> WD b
1728−testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
1344+testWidgetStatic w = testWidget (void w) w
17291345
17301346-- | TODO: do something about JSExceptions not causing tests to fail
1731−testWidgetDebug
1732− :: Bool
1733− -> Bool
1734− -> WD ()
1347+testWidget
1348+ :: WD ()
17351349 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
17361350 -> WD b
17371351 -- ^ Webdriver commands to run after hydration switchover
17381352 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17391353 -- ^ Widget we are testing
17401354 -> WD b
1741−testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =
1742− testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)
1743−
1744−data HydrationFailedException = HydrationFailedException deriving Show
1745−instance Exception HydrationFailedException
1355+testWidget beforeJS afterSwitchover = testWidget' beforeJS (const afterSwitchover)
17461356
17471357-- | TODO: do something about JSExceptions not causing tests to fail
1748−testWidgetDebug'
1749− :: Bool
1750− -> Bool
1751− -> WD a
1358+testWidget'
1359+ :: WD a
17521360 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
17531361 -> (a -> WD b)
17541362 -- ^ Webdriver commands to run after hydration switchover
17551363 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17561364 -- ^ Widget we are testing (contents of body)
17571365 -> WD b
1758−testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
1759− let putStrLnDebug :: MonadIO m => Text -> m ()
1760− putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1761− staticApp = do
1366+testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out") pure <=< timeout testTimeLimit $ do
1367+ let staticApp = do
17621368 el "head" $ pure ()
17631369 el "body" $ do
17641370 bodyWidget
17651371 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1766− putStrLnDebug "rendering static"
1767− ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1768− putStrLnDebug "rendered static"
1372+ ((), html) <- liftIO $ renderStatic staticApp
17691373 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1770− onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
17711374 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
17721375 let entryPoint = do
1773− putStrLnDebug "taking waitBeforeJS"
17741376 liftIO $ takeMVar waitBeforeJS
1775− let switchOverAction = do
1776− putStrLnDebug "switchover syncPoint"
1777− syncPoint
1778− putStrLnDebug "putting waitUntilSwitchover"
1779− liftIO $ putMVar waitUntilSwitchover ()
1780− putStrLnDebug "put waitUntilSwitchover"
1781− putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1782− mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
1783− putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1377+ mainHydrationWidgetWithSwitchoverAction (liftIO $ putMVar waitUntilSwitchover ()) (pure ()) bodyWidget
17841378 syncPoint
1785− application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
1786− putStrLnDebug "sending response"
1787− r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1788− putStrLnDebug "sent response"
1789− return r
1379+ application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse ->
1380+ sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1381+ port <- getFreePort
17901382 waitJSaddle <- liftIO newEmptyMVar
17911383 let settings = foldr ($) Warp.defaultSettings
1792− [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
1793− , Warp.setBeforeMainLoop $ do
1794− putStrLnDebug "putting waitJSaddle"
1795− putMVar waitJSaddle ()
1796− putStrLnDebug "put waitJSaddle"
1384+ [ Warp.setPort $ fromIntegral (toInteger port)
1385+ , Warp.setBeforeMainLoop $ putMVar waitJSaddle ()
17971386 ]
17981387 -- hSilence to get rid of ConnectionClosed logs
1799− silenceIfDebug = if withDebugging then id else hSilence [stderr]
1800− jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
1801− withAsync' jsaddleWarp $ do
1802− putStrLnDebug "taking waitJSaddle"
1803− liftIO $ takeMVar waitJSaddle
1804− putStrLnDebug "opening page"
1805− WD.openPage $ "http://localhost:" <> show jsaddlePort
1806− putStrLnDebug "running beforeJS"
1807− a <- beforeJS
1808− putStrLnDebug "putting waitBeforeJS"
1809− liftIO $ putMVar waitBeforeJS ()
1810− putStrLnDebug "taking waitUntilSwitchover"
1811− liftIO $ takeMVar waitUntilSwitchover
1812− putStrLnDebug "running afterSwitchover"
1813− afterSwitchover a
1388+ jsaddleWarp = forkIO $ hSilence [stderr] $ Warp.runSettings settings application
1389+ jsaddleTid <- liftIO jsaddleWarp
1390+ liftIO $ takeMVar waitJSaddle
1391+ WD.openPage $ "http://localhost:" <> show port
1392+ a <- beforeJS
1393+ liftIO $ putMVar waitBeforeJS ()
1394+ liftIO $ takeMVar waitUntilSwitchover
1395+ liftIO $ threadDelay 100000 -- wait a bit
1396+ b <- afterSwitchover a
1397+ liftIO $ killThread jsaddleTid
1398+ return b
18141399
1815−withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
1816−withAsync' f g = bracket
1817− (liftIO $ Async.async f)
1818− (liftIO . Async.uninterruptibleCancel)
1819− (const g)
1400+
1401+-- TODO: Should this be part of more widely used module?
1402+-- TODO: Ensure port is not taken
1403+getFreePort :: MonadIO m => m PortNumber
1404+getFreePort = liftIO $ withSocketsDo $ do
1405+ addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
1406+ bracket (open addr) close socketPort
1407+ where
1408+ open addr = do
1409+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
1410+ bind sock (addrAddress addr)
1411+ return sock
1412+
1413+testWidgetDebug :: MonadIO n => (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> n ()
1414+testWidgetDebug bodyWidget = liftIO $ do
1415+ let staticApp = do
1416+ el "head" $ pure ()
1417+ el "body" $ do
1418+ bodyWidget
1419+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1420+ ((), html) <- renderStatic staticApp
1421+ let entryPoint = do
1422+ mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) bodyWidget
1423+ syncPoint
1424+ application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1425+ Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application
18201426
18211427data Key2 a where
18221428 Key2_Int :: Int -> Key2 Int
@@ -1826,3 +1432,12 @@ deriveGEq ''Key2
18261432deriveGCompare ''Key2
18271433deriveGShow ''Key2
18281434deriveArgDict ''Key2
1435+
1436+instance ShowTag Key2 Identity where
1437+ showTaggedPrec = \case
1438+ Key2_Int _ -> showsPrec
1439+ Key2_Char _ -> showsPrec
1440+
1441+instance EqTag Key2 Identity where
1442+ eqTagged (Key2_Int _) (Key2_Int _) = (==)
1443+ eqTagged (Key2_Char _) (Key2_Char _) = (==)