@@ -1,54 +1,39 @@
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 #-}
10−{-# LANGUAGE PolyKinds #-}
1112{-# LANGUAGE RankNTypes #-}
1213{-# LANGUAGE RecursiveDo #-}
1314{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE StandaloneDeriving #-}
1515{-# LANGUAGE TemplateHaskell #-}
1616{-# LANGUAGE TupleSections #-}
1717{-# LANGUAGE TypeApplications #-}
1818{-# LANGUAGE TypeFamilies #-}
19−{-# LANGUAGE UndecidableInstances #-}
20−
21−{-# OPTIONS_GHC -fno-warn-orphans #-}
22−
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.
3019
31−import Prelude hiding (fail)
3220import Control.Concurrent
33−import qualified Control.Concurrent.Async as Async
34−import Control.Lens.Operators
35−import Control.Monad hiding (fail)
21+import Control.Monad
3622import Control.Monad.Catch
37−import Control.Monad.Fail
3823import Control.Monad.Fix
3924import Control.Monad.IO.Class
4025import Control.Monad.Ref
26+import Data.Constraint (Dict(..))
4127import Data.Constraint.Extras
42−import Data.Constraint.Extras.TH
4328import Data.Dependent.Map (DMap)
44−import Data.Dependent.Sum (DSum(..), (==>))
29+import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
30+import Data.Foldable (traverse_)
4531import Data.Functor.Identity
4632import Data.Functor.Misc
4733import Data.GADT.Compare.TH
4834import Data.GADT.Show.TH
4935import Data.IORef (IORef)
50−import Data.List (sort)
51−import Data.Maybe
36+import Data.Maybe (fromMaybe, fromJust)
5237import Data.Proxy
5338import Data.Text (Text)
5439import Language.Javascript.JSaddle (syncPoint, liftJSM)
@@ -58,22 +43,18 @@ import Network.Socket
5843import Network.Wai
5944import Network.WebSockets
6045import Reflex.Dom.Core
61−import Reflex.Dom.Widget.Input (dropdown)
6246import Reflex.Patch.DMapWithMove
6347import System.Directory
64−import System.Environment
6548import System.IO (stderr)
6649import System.IO.Silently
6750import System.IO.Temp
6851import System.Process
69−import System.Which (staticWhich)
70−import qualified Test.HUnit as HUnit
52+import System.Timeout.Lifted
53+import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
7154import 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)
55+import Test.Hspec.WebDriver hiding (runWD)
7556import qualified Test.Hspec.WebDriver as WD
76−import Test.WebDriver (WD(..))
57+import Test.WebDriver (WD)
7758
7859import qualified Data.ByteString.Lazy as LBS
7960import qualified Data.Dependent.Map as DMap
@@ -86,37 +67,20 @@ import qualified System.FilePath as FilePath
8667import qualified Test.WebDriver as WD
8768import qualified Test.WebDriver.Capabilities as WD
8869
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−
10270-- 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
71+deriving instance MonadRef WD
10872
10973assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
110−assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
74+assertEqual a b = liftIO . HUnit.assertEqual a b
11175
11276assertFailure :: MonadIO m => String -> m ()
11377assertFailure = liftIO . HUnit.assertFailure
11478
115−assertBool :: (MonadIO m) => String -> Bool -> m ()
116−assertBool msg bool = liftIO $ HUnit.assertBool msg bool
79+testTimeLimit :: Int
80+testTimeLimit = 5 * 1000 * 1000
11781
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
82+chromeConfig :: Text -> WD.WDConfig
83+chromeConfig fp = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = ["--headless"] }) WD.defaultConfig
12084
12185keyMap :: DMap DKey Identity
12286keyMap = DMap.fromList
@@ -129,6 +93,14 @@ data DKey a where
12993 Key_Char :: DKey Char
13094 Key_Bool :: DKey Bool
13195
96+instance ArgDict DKey where
97+ type ConstraintsFor DKey c = (c Int, c Char, c Bool)
98+ type ConstraintsFor' DKey c g = (c (g Int), c (g Char), c (g Bool))
99+ argDict = \case
100+ Key_Int -> Dict
101+ Key_Char -> Dict
102+ Key_Bool -> Dict
103+ argDict' = undefined -- Missing constraints?
132104
133105textKey :: DKey a -> Text
134106textKey = \case
@@ -136,43 +108,34 @@ textKey = \case
136108 Key_Char -> "Key_Char"
137109 Key_Bool -> "Key_Bool"
138110
139−deriveArgDict ''DKey
140111deriveGEq ''DKey
141112deriveGCompare ''DKey
142113deriveGShow ''DKey
143114
144−deriving instance MonadFail WD
115+instance ShowTag DKey Identity where
116+ showTaggedPrec = \case
117+ Key_Int -> showsPrec
118+ Key_Char -> showsPrec
119+ Key_Bool -> showsPrec
120+
121+instance EqTag DKey Identity where
122+ eqTagged Key_Int Key_Int = (==)
123+ eqTagged Key_Char Key_Char = (==)
124+ eqTagged Key_Bool Key_Bool = (==)
145125
146126main :: 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
127+main = withSeleniumServer $ \selenium -> do
128+ browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
129+ when (T.null browserPath) $ fail "No browser found"
130+ let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
131+ chromeCaps' = WD.getCaps $ chromeConfig browserPath
132+ hspec (tests wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
158133
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
134+tests :: WD.WDConfig -> [Capabilities] -> Selenium -> Spec
135+tests wdConfig caps _selenium = do
136+ let session' = sessionWith wdConfig "" . using (map (,"") caps)
137+ runWD = runWDOptions (WdOptions False)
138+ describe "text" $ session' $ do
176139 it "works" $ runWD $ do
177140 testWidgetStatic (checkBodyText "hello world") $ do
178141 text "hello world"
@@ -227,25 +190,27 @@ tests withDebugging wdConfig caps _selenium = do
227190 it "updates in immediate mode" $ runWD $ do
228191 let checkUpdated = do
229192 checkBodyText "initial"
230− WD.click =<< findElemWithRetry (WD.ByTag "button")
193+ WD.click =<< WD.findElem (WD.ByTag "button")
194+ liftIO $ threadDelay 100000 -- wait for update
231195 checkBodyText "after"
232196 testWidget (pure ()) checkUpdated $ prerender_ (pure ()) $ do
233197 click <- button ""
234198 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
235199
236− session' "element" $ do
200+ describe "element" $ session' $ do
237201 it "works with domEvent Click" $ runWD $ do
238202 clickedRef <- liftIO $ newRef False
239− testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
203+ testWidget' (WD.findElem $ WD.ByTag "div") WD.click $ do
240204 (e, _) <- el' "div" $ text "hello world"
241205 performEvent_ $ liftIO (writeRef clickedRef True) <$ domEvent Click e
242− readRef clickedRef `shouldBeWithRetryM` True
206+ clicked <- liftIO $ readRef clickedRef
207+ liftIO $ assertEqual "Not clicked" True clicked
243208 it "works with eventFlags stopPropagation" $ runWD $ do
244209 firstClickedRef <- newRef False
245210 secondClickedRef <- newRef False
246211 let clickBoth = do
247− findElemWithRetry (WD.ById "first") >>= WD.click
248− findElemWithRetry (WD.ById "second") >>= WD.click
212+ WD.findElem (WD.ById "first") >>= WD.click
213+ WD.findElem (WD.ById "second") >>= WD.click
249214 testWidget (pure ()) clickBoth $ do
250215 (firstDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do
251216 void $ elAttr "span" ("id" =: "first") $ text "hello world"
@@ -262,7 +227,7 @@ tests withDebugging wdConfig caps _selenium = do
262227 assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)
263228 it "works with eventFlags preventDefault" $ runWD $ do
264229 let click = do
265− e <- findElemWithRetry $ WD.ByTag "input"
230+ e <- WD.findElem $ WD.ByTag "input"
266231 s0 <- WD.isSelected e
267232 WD.click e
268233 s1 <- WD.isSelected e
@@ -276,7 +241,7 @@ tests withDebugging wdConfig caps _selenium = do
276241 assertEqual "Click not prevented" (False, False) clicked
277242 it "can add/update/remove attributes" $ runWD $ do
278243 let checkInitialAttrs = do
279− e <- findElemWithRetry $ WD.ByTag "div"
244+ e <- WD.findElem $ WD.ByTag "div"
280245 assertAttr e "const" (Just "const")
281246 assertAttr e "delete" (Just "delete")
282247 assertAttr e "init" (Just "init")
@@ -284,11 +249,11 @@ tests withDebugging wdConfig caps _selenium = do
284249 pure e
285250 checkModifyAttrs e = do
286251 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")
252+ liftIO $ threadDelay 100000
253+ assertAttr e "const" (Just "const")
254+ assertAttr e "delete" Nothing
255+ assertAttr e "init" (Just "click")
256+ assertAttr e "click" (Just "click")
292257 testWidget' checkInitialAttrs checkModifyAttrs $ mdo
293258 let conf = def
294259 & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"
@@ -296,87 +261,40 @@ tests withDebugging wdConfig caps _selenium = do
296261 (e, ()) <- element "div" conf $ text "hello world"
297262 let click = domEvent Click e
298263 return ()
264+ -- TODO check this is the correct solution
265+ it "has ssr attribute, removes ssr attribute" $ runWD $ do
266+ let checkSSRAttr = do
267+ e <- WD.findElem $ WD.ByTag "div"
268+ assertAttr e "data-ssr" (Just "")
269+ pure e
270+ testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world"
299271
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
272+ describe "inputElement" $ do
273+ describe "hydration" $ session' $ do
359274 it "doesn't wipe user input when switching over" $ runWD $ do
360− inputRef <- newRef ("hello " :: Text)
275+ inputRef <- newRef ("" :: Text)
361276 testWidget'
362277 (do
363− e <- findElemWithRetry $ WD.ByTag "input"
364− WD.sendKeys "world" e
278+ e <- WD.findElem $ WD.ByTag "input"
279+ WD.sendKeys "hello world" e
365280 pure e)
366281 (\e -> do
367− WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
368− WD.click =<< findElemWithRetry (WD.ByTag "button")
369− readRef inputRef `shouldBeWithRetryM` "hello world"
282+ t <- WD.attr e "value"
283+ t `shouldBe` Just "hello world"
284+ WD.click <=< WD.findElem $ WD.ByTag "button"
285+ input <- liftIO $ readRef inputRef
286+ input `shouldBe` "hello world"
370287 ) $ do
371− e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
288+ e <- inputElement def
372289 click <- button "save"
373290 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
374291 it "captures user input after switchover" $ runWD $ do
375292 inputRef <- newRef ("" :: Text)
376293 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"
294+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
295+ WD.click <=< WD.findElem $ WD.ByTag "button"
296+ input <- liftIO $ readRef inputRef
297+ input `shouldBe` "hello world"
380298 testWidget (pure ()) checkValue $ do
381299 e <- inputElement def
382300 click <- button "save"
@@ -384,21 +302,23 @@ tests withDebugging wdConfig caps _selenium = do
384302 it "sets focus appropriately" $ runWD $ do
385303 focusRef <- newRef False
386304 let checkValue = do
387− readRef focusRef `shouldBeWithRetryM` False
388− e <- findElemWithRetry $ WD.ByTag "input"
305+ readRef focusRef >>= flip shouldBe False
306+ e <- WD.findElem $ WD.ByTag "input"
389307 WD.click e
390− readRef focusRef `shouldBeWithRetryM` True
308+ liftIO $ threadDelay 100000
309+ readRef focusRef >>= flip shouldBe True
391310 testWidget (pure ()) checkValue $ do
392311 e <- inputElement def
393312 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
394313 it "sets focus when focus occurs before hydration" $ runWD $ do
395314 focusRef <- newRef False
396315 let setup = do
397− e <- findElemWithRetry $ WD.ByTag "input"
316+ e <- WD.findElem $ WD.ByTag "input"
398317 WD.click e
399− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
400− readRef focusRef `shouldBeWithRetryM` False
401− check = readRef focusRef `shouldBeWithRetryM` True
318+ hasFocus <- (== e) <$> WD.activeElem
319+ hasFocus `shouldBe` True
320+ readRef focusRef >>= flip shouldBe False
321+ check = readRef focusRef >>= flip shouldBe True
402322 testWidget setup check $ do
403323 e <- inputElement def
404324 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -407,15 +327,17 @@ tests withDebugging wdConfig caps _selenium = do
407327 valueRef <- newRef ("" :: Text)
408328 setValueChan :: Chan Text <- liftIO newChan
409329 let checkValue = do
410− readRef valueByUIRef `shouldBeWithRetryM` ""
411− readRef valueRef `shouldBeWithRetryM` ""
412− e <- findElemWithRetry $ WD.ByTag "input"
330+ readRef valueByUIRef >>= flip shouldBe ""
331+ readRef valueRef >>= flip shouldBe ""
332+ e <- WD.findElem $ WD.ByTag "input"
413333 WD.sendKeys "hello" e
414− readRef valueByUIRef `shouldBeWithRetryM` "hello"
415− readRef valueRef `shouldBeWithRetryM` "hello"
334+ liftIO $ threadDelay 100000
335+ readRef valueByUIRef >>= flip shouldBe "hello"
336+ readRef valueRef >>= flip shouldBe "hello"
416337 liftIO $ writeChan setValueChan "world"
417− readRef valueByUIRef `shouldBeWithRetryM` "hello"
418− readRef valueRef `shouldBeWithRetryM` "world"
338+ liftIO $ threadDelay 100000
339+ readRef valueByUIRef >>= flip shouldBe "hello"
340+ readRef valueRef >>= flip shouldBe "world"
419341 testWidget (pure ()) checkValue $ do
420342 update <- triggerEventWithChan setValueChan
421343 e <- inputElement $ def & inputElementConfig_setValue .~ update
@@ -425,181 +347,51 @@ tests withDebugging wdConfig caps _selenium = do
425347 checkedByUIRef <- newRef False
426348 checkedRef <- newRef False
427349 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
350+ let checkValue = do
351+ readRef checkedByUIRef >>= flip shouldBe False
352+ readRef checkedRef >>= flip shouldBe False
353+ e <- WD.findElem $ WD.ByTag "input"
436354 WD.moveToCenter e
437355 WD.click e
438− readRef checkedByUIRef `shouldBeWithRetryM` True
439− readRef checkedRef `shouldBeWithRetryM` True
440− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
356+ liftIO $ threadDelay 100000
357+ readRef checkedByUIRef >>= flip shouldBe True
358+ readRef checkedRef >>= flip shouldBe True
441359 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
360+ liftIO $ threadDelay 100000
361+ readRef checkedByUIRef >>= flip shouldBe True
362+ readRef checkedRef >>= flip shouldBe False
363+ testWidget (pure ()) checkValue $ do
446364 setChecked <- triggerEventWithChan setCheckedChan
447365 e <- inputElement $ def
448366 & initialAttributes .~ "type" =: "checkbox"
449367 & inputElementConfig_setChecked .~ setChecked
450368 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
451369 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)
471370 it "captures file uploads" $ runWD $ do
472371 filesRef :: IORef [Text] <- newRef []
473372 let uploadFile = do
474− e <- findElemWithRetry $ WD.ByTag "input"
373+ e <- WD.findElem $ WD.ByTag "input"
475374 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
476375 WD.sendKeys (T.pack path) e
477− WD.click =<< findElemWithRetry (WD.ByTag "button")
376+ WD.click <=< WD.findElem $ WD.ByTag "button"
478377 liftIO $ removeFile path
479− readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
378+ input <- readRef filesRef
379+ input `shouldBe` [T.pack $ FilePath.takeFileName path]
480380 testWidget (pure ()) uploadFile $ do
481381 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
482382 click <- button "save"
483383 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
484384 names <- liftJSM $ traverse File.getName fs
485385 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
386+
387+ describe "hydration/immediate" $ session' $ do
597388 it "captures user input after switchover" $ runWD $ do
598389 inputRef :: IORef Text <- newRef ""
599390 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"
391+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
392+ WD.click <=< WD.findElem $ WD.ByTag "button"
393+ input <- readRef inputRef
394+ input `shouldBe` "hello world"
603395 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
604396 e <- inputElement def
605397 click <- button "save"
@@ -607,10 +399,11 @@ tests withDebugging wdConfig caps _selenium = do
607399 it "sets focus appropriately" $ runWD $ do
608400 focusRef <- newRef False
609401 let checkValue = do
610− readRef focusRef `shouldBeWithRetryM` False
611− e <- findElemWithRetry $ WD.ByTag "input"
402+ readRef focusRef >>= flip shouldBe False
403+ e <- WD.findElem $ WD.ByTag "input"
612404 WD.click e
613− readRef focusRef `shouldBeWithRetryM` True
405+ liftIO $ threadDelay 100000
406+ readRef focusRef >>= flip shouldBe True
614407 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
615408 e <- inputElement def
616409 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -619,15 +412,17 @@ tests withDebugging wdConfig caps _selenium = do
619412 valueRef :: IORef Text <- newRef ""
620413 setValueChan :: Chan Text <- liftIO newChan
621414 let checkValue = do
622− readRef valueByUIRef `shouldBeWithRetryM` ""
623− readRef valueRef `shouldBeWithRetryM` ""
624− e <- findElemWithRetry $ WD.ByTag "input"
415+ readRef valueByUIRef >>= flip shouldBe ""
416+ readRef valueRef >>= flip shouldBe ""
417+ e <- WD.findElem $ WD.ByTag "input"
625418 WD.sendKeys "hello" e
626− readRef valueByUIRef `shouldBeWithRetryM` "hello"
627− readRef valueRef `shouldBeWithRetryM` "hello"
419+ liftIO $ threadDelay 100000
420+ readRef valueByUIRef >>= flip shouldBe "hello"
421+ readRef valueRef >>= flip shouldBe "hello"
628422 liftIO $ writeChan setValueChan "world"
629− readRef valueByUIRef `shouldBeWithRetryM` "hello"
630− readRef valueRef `shouldBeWithRetryM` "world"
423+ liftIO $ threadDelay 100000
424+ readRef valueByUIRef >>= flip shouldBe "hello"
425+ readRef valueRef >>= flip shouldBe "world"
631426 testWidget (pure ()) checkValue $ do
632427 update <- triggerEventWithChan setValueChan
633428 prerender_ (pure ()) $ do
@@ -639,16 +434,18 @@ tests withDebugging wdConfig caps _selenium = do
639434 checkedRef <- newRef False
640435 setCheckedChan <- liftIO newChan
641436 let checkValue = do
642− readRef checkedByUIRef `shouldBeWithRetryM` False
643− readRef checkedRef `shouldBeWithRetryM` False
644− e <- findElemWithRetry $ WD.ByTag "input"
437+ readRef checkedByUIRef >>= flip shouldBe False
438+ readRef checkedRef >>= flip shouldBe False
439+ e <- WD.findElem $ WD.ByTag "input"
645440 WD.moveToCenter e
646441 WD.click e
647− readRef checkedByUIRef `shouldBeWithRetryM` True
648− readRef checkedRef `shouldBeWithRetryM` True
442+ liftIO $ threadDelay 100000
443+ readRef checkedByUIRef >>= flip shouldBe True
444+ readRef checkedRef >>= flip shouldBe True
649445 liftIO $ writeChan setCheckedChan False
650− readRef checkedByUIRef `shouldBeWithRetryM` True
651− readRef checkedRef `shouldBeWithRetryM` False
446+ liftIO $ threadDelay 100000
447+ readRef checkedByUIRef >>= flip shouldBe True
448+ readRef checkedRef >>= flip shouldBe False
652449 testWidget (pure ()) checkValue $ do
653450 setChecked <- triggerEventWithChan setCheckedChan
654451 prerender_ (pure ()) $ do
@@ -660,12 +457,13 @@ tests withDebugging wdConfig caps _selenium = do
660457 it "captures file uploads" $ runWD $ do
661458 filesRef :: IORef [Text] <- newRef []
662459 let uploadFile = do
663− e <- findElemWithRetry $ WD.ByTag "input"
460+ e <- WD.findElem $ WD.ByTag "input"
664461 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
665462 WD.sendKeys (T.pack path) e
666− WD.click =<< findElemWithRetry (WD.ByTag "button")
463+ WD.click <=< WD.findElem $ WD.ByTag "button"
667464 liftIO $ removeFile path
668− readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
465+ input <- liftIO $ readRef filesRef
466+ input `shouldBe` [T.pack $ FilePath.takeFileName path]
669467 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
670468 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
671469 click <- button "save"
@@ -673,42 +471,21 @@ tests withDebugging wdConfig caps _selenium = do
673471 names <- liftJSM $ traverse File.getName fs
674472 liftIO $ writeRef filesRef names
675473
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
474+ describe "textAreaElement" $ do
475+ describe "hydration" $ session' $ do
701476 it "doesn't wipe user input when switching over" $ runWD $ do
702477 inputRef <- newRef ("" :: Text)
703478 testWidget'
704479 (do
705− e <- findElemWithRetry $ WD.ByTag "textarea"
480+ e <- WD.findElem $ WD.ByTag "textarea"
706481 WD.sendKeys "hello world" e
707482 pure e)
708483 (\e -> do
709− WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
710− WD.click <=< findElemWithRetry $ WD.ByTag "button"
711− readRef inputRef `shouldBeWithRetryM` "hello world"
484+ t <- WD.attr e "value"
485+ t `shouldBe` Just "hello world"
486+ WD.click <=< WD.findElem $ WD.ByTag "button"
487+ input <- readRef inputRef
488+ input `shouldBe` "hello world"
712489 ) $ do
713490 e <- textAreaElement def
714491 click <- button "save"
@@ -716,9 +493,10 @@ tests withDebugging wdConfig caps _selenium = do
716493 it "captures user input after switchover" $ runWD $ do
717494 inputRef <- newRef ("" :: Text)
718495 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"
496+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
497+ WD.click <=< WD.findElem $ WD.ByTag "button"
498+ input <- readRef inputRef
499+ input `shouldBe` "hello world"
722500 testWidget (pure ()) checkValue $ do
723501 e <- textAreaElement def
724502 click <- button "save"
@@ -726,21 +504,23 @@ tests withDebugging wdConfig caps _selenium = do
726504 it "sets focus appropriately" $ runWD $ do
727505 focusRef <- newRef False
728506 let checkValue = do
729− readRef focusRef `shouldBeWithRetryM` False
730− e <- findElemWithRetry $ WD.ByTag "textarea"
507+ readRef focusRef >>= flip shouldBe False
508+ e <- WD.findElem $ WD.ByTag "textarea"
731509 WD.click e
732− readRef focusRef `shouldBeWithRetryM` True
510+ liftIO $ threadDelay 100000
511+ readRef focusRef >>= flip shouldBe True
733512 testWidget (pure ()) checkValue $ do
734513 e <- textAreaElement def
735514 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
736515 it "sets focus when focus occurs before hydration" $ runWD $ do
737516 focusRef <- newRef False
738517 let setup = do
739− e <- findElemWithRetry $ WD.ByTag "textarea"
518+ e <- WD.findElem $ WD.ByTag "textarea"
740519 WD.click e
741− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
742− readRef focusRef `shouldBeWithRetryM` False
743− check = readRef focusRef `shouldBeWithRetryM` True
520+ hasFocus <- (== e) <$> WD.activeElem
521+ hasFocus `shouldBe` True
522+ readRef focusRef >>= flip shouldBe False
523+ check = readRef focusRef >>= flip shouldBe True
744524 testWidget setup check $ do
745525 e <- textAreaElement def
746526 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -749,110 +529,31 @@ tests withDebugging wdConfig caps _selenium = do
749529 valueRef <- newRef ("" :: Text)
750530 setValueChan :: Chan Text <- liftIO newChan
751531 let checkValue = do
752− readRef valueByUIRef `shouldBeWithRetryM` ""
753− readRef valueRef `shouldBeWithRetryM` ""
754− e <- findElemWithRetry $ WD.ByTag "textarea"
532+ readRef valueByUIRef >>= flip shouldBe ""
533+ readRef valueRef >>= flip shouldBe ""
534+ e <- WD.findElem $ WD.ByTag "textarea"
755535 WD.sendKeys "hello" e
756− readRef valueByUIRef `shouldBeWithRetryM` "hello"
757− readRef valueRef `shouldBeWithRetryM` "hello"
536+ liftIO $ threadDelay 100000
537+ readRef valueByUIRef >>= flip shouldBe "hello"
538+ readRef valueRef >>= flip shouldBe "hello"
758539 liftIO $ writeChan setValueChan "world"
759− readRef valueByUIRef `shouldBeWithRetryM` "hello"
760− readRef valueRef `shouldBeWithRetryM` "world"
540+ liftIO $ threadDelay 100000
541+ readRef valueByUIRef >>= flip shouldBe "hello"
542+ readRef valueRef >>= flip shouldBe "world"
761543 testWidget (pure ()) checkValue $ do
762544 setValue' <- triggerEventWithChan setValueChan
763545 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
764546 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
765547 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
848548
849− describe "hydration/immediate" $ do
549+ describe "hydration/immediate" $ session' $ do
850550 it "captures user input after switchover" $ runWD $ do
851551 inputRef :: IORef Text <- newRef ""
852552 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"
553+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
554+ WD.click <=< WD.findElem $ WD.ByTag "button"
555+ input <- liftIO $ readRef inputRef
556+ input `shouldBe` "hello world"
856557 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
857558 e <- textAreaElement def
858559 click <- button "save"
@@ -860,10 +561,11 @@ tests withDebugging wdConfig caps _selenium = do
860561 it "sets focus appropriately" $ runWD $ do
861562 focusRef <- newRef False
862563 let checkValue = do
863− readRef focusRef `shouldBeWithRetryM` False
864− e <- findElemWithRetry $ WD.ByTag "textarea"
564+ readRef focusRef >>= flip shouldBe False
565+ e <- WD.findElem $ WD.ByTag "textarea"
865566 WD.click e
866− readRef focusRef `shouldBeWithRetryM` True
567+ liftIO $ threadDelay 100000
568+ readRef focusRef >>= flip shouldBe True
867569 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
868570 e <- textAreaElement def
869571 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -872,15 +574,17 @@ tests withDebugging wdConfig caps _selenium = do
872574 valueRef :: IORef Text <- newRef ""
873575 setValueChan :: Chan Text <- liftIO newChan
874576 let checkValue = do
875− readRef valueByUIRef `shouldBeWithRetryM` ""
876− readRef valueRef `shouldBeWithRetryM` ""
877− e <- findElemWithRetry $ WD.ByTag "textarea"
577+ readRef valueByUIRef >>= flip shouldBe ""
578+ readRef valueRef >>= flip shouldBe ""
579+ e <- WD.findElem $ WD.ByTag "textarea"
878580 WD.sendKeys "hello" e
879− readRef valueByUIRef `shouldBeWithRetryM` "hello"
880− readRef valueRef `shouldBeWithRetryM` "hello"
581+ liftIO $ threadDelay 100000
582+ readRef valueByUIRef >>= flip shouldBe "hello"
583+ readRef valueRef >>= flip shouldBe "hello"
881584 liftIO $ writeChan setValueChan "world"
882− readRef valueByUIRef `shouldBeWithRetryM` "hello"
883− readRef valueRef `shouldBeWithRetryM` "world"
585+ liftIO $ threadDelay 100000
586+ readRef valueByUIRef >>= flip shouldBe "hello"
587+ readRef valueRef >>= flip shouldBe "world"
884588 testWidget (pure ()) checkValue $ do
885589 setValue' <- triggerEventWithChan setValueChan
886590 prerender_ (pure ()) $ do
@@ -888,26 +592,26 @@ tests withDebugging wdConfig caps _selenium = do
888592 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
889593 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
890594
891− session' "selectElement" $ do
595+ describe "selectElement" $ do
892596 let options :: DomBuilder t m => m ()
893597 options = do
894598 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
895599 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
896600 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
897− describe "hydration" $ do
601+ describe "hydration" $ session' $ do
898602 it "sets initial value correctly" $ runWD $ do
899603 inputRef <- newRef ("" :: Text)
900604 let setup = do
901− e <- findElemWithRetry $ WD.ByTag "select"
605+ e <- WD.findElem $ WD.ByTag "select"
902606 assertAttr e "value" (Just "three")
903− WD.click =<< findElemWithRetry (WD.ById "two")
607+ WD.click <=< WD.findElem $ WD.ById "two"
904608 pure e
905609 check e = do
906610 assertAttr e "value" (Just "two")
907− readRef inputRef `shouldBeWithRetryM` "three"
908− WD.click =<< findElemWithRetry (WD.ByTag "button")
611+ readRef inputRef >>= (`shouldBe` "three")
612+ WD.click <=< WD.findElem $ WD.ByTag "button"
909613 assertAttr e "value" (Just "two")
910− readRef inputRef `shouldBeWithRetryM` "two"
614+ readRef inputRef >>= (`shouldBe` "two")
911615 testWidget' setup check $ do
912616 (e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options
913617 click <- button "save"
@@ -916,12 +620,12 @@ tests withDebugging wdConfig caps _selenium = do
916620 it "captures user input after switchover" $ runWD $ do
917621 inputRef <- newRef ("" :: Text)
918622 let checkValue = do
919− e <- findElemWithRetry $ WD.ByTag "select"
623+ e <- WD.findElem $ WD.ByTag "select"
920624 assertAttr e "value" (Just "one")
921− WD.click =<< findElemWithRetry (WD.ById "two")
625+ WD.click <=< WD.findElem $ WD.ById "two"
922626 assertAttr e "value" (Just "two")
923− WD.click =<< findElemWithRetry (WD.ByTag "button")
924− readRef inputRef `shouldBeWithRetryM` "two"
627+ WD.click <=< WD.findElem $ WD.ByTag "button"
628+ readRef inputRef >>= (`shouldBe` "two")
925629 testWidget (pure ()) checkValue $ do
926630 (e, ()) <- selectElement def options
927631 click <- button "save"
@@ -929,21 +633,23 @@ tests withDebugging wdConfig caps _selenium = do
929633 it "sets focus appropriately" $ runWD $ do
930634 focusRef <- newRef False
931635 let checkValue = do
932− readRef focusRef `shouldBeWithRetryM` False
933− e <- findElemWithRetry $ WD.ByTag "select"
636+ readRef focusRef >>= flip shouldBe False
637+ e <- WD.findElem $ WD.ByTag "select"
934638 WD.click e
935− readRef focusRef `shouldBeWithRetryM` True
639+ liftIO $ threadDelay 100000
640+ readRef focusRef >>= flip shouldBe True
936641 testWidget (pure ()) checkValue $ do
937642 (e, ()) <- selectElement def options
938643 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
939644 it "sets focus when focus occurs before hydration" $ runWD $ do
940645 focusRef <- newRef False
941646 let setup = do
942− e <- findElemWithRetry $ WD.ByTag "select"
647+ e <- WD.findElem $ WD.ByTag "select"
943648 WD.click e
944− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
945− readRef focusRef `shouldBeWithRetryM` False
946− check = readRef focusRef `shouldBeWithRetryM` True
649+ hasFocus <- (== e) <$> WD.activeElem
650+ hasFocus `shouldBe` True
651+ readRef focusRef >>= flip shouldBe False
652+ check = readRef focusRef >>= flip shouldBe True
947653 testWidget setup check $ do
948654 (e, ()) <- selectElement def options
949655 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
@@ -952,29 +658,31 @@ tests withDebugging wdConfig caps _selenium = do
952658 valueRef <- newRef ("" :: Text)
953659 setValueChan :: Chan Text <- liftIO newChan
954660 let checkValue = do
955− e <- findElemWithRetry $ WD.ByTag "select"
661+ e <- WD.findElem $ WD.ByTag "select"
956662 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"
663+ readRef valueByUIRef >>= flip shouldBe "one"
664+ readRef valueRef >>= flip shouldBe "one"
665+ WD.click <=< WD.findElem $ WD.ById "two"
666+ liftIO $ threadDelay 100000
667+ readRef valueByUIRef >>= flip shouldBe "two"
668+ readRef valueRef >>= flip shouldBe "two"
962669 liftIO $ writeChan setValueChan "three"
963− readRef valueByUIRef `shouldBeWithRetryM` "two"
964− readRef valueRef `shouldBeWithRetryM` "three"
670+ liftIO $ threadDelay 100000
671+ readRef valueByUIRef >>= flip shouldBe "two"
672+ readRef valueRef >>= flip shouldBe "three"
965673 testWidget (pure ()) checkValue $ do
966674 setValue' <- triggerEventWithChan setValueChan
967675 (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
968676 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
969677 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
970678
971− describe "hydration/immediate" $ do
679+ describe "hydration/immediate" $ session' $ do
972680 it "captures user input after switchover" $ runWD $ do
973681 inputRef :: IORef Text <- newRef ""
974682 let checkValue = do
975− WD.click <=< findElemWithRetry $ WD.ById "two"
976− WD.click <=< findElemWithRetry $ WD.ByTag "button"
977− readRef inputRef `shouldBeWithRetryM` "two"
683+ WD.click <=< WD.findElem $ WD.ById "two"
684+ WD.click <=< WD.findElem $ WD.ByTag "button"
685+ readRef inputRef >>= flip shouldBe "two"
978686 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
979687 (e, ()) <- selectElement def options
980688 click <- button "save"
@@ -982,16 +690,17 @@ tests withDebugging wdConfig caps _selenium = do
982690 it "sets focus appropriately" $ runWD $ do
983691 focusRef <- newRef False
984692 let checkValue = do
985− readRef focusRef `shouldBeWithRetryM` False
986− e <- findElemWithRetry $ WD.ByTag "select"
693+ readRef focusRef >>= flip shouldBe False
694+ e <- WD.findElem $ WD.ByTag "select"
987695 WD.click e
988− readRef focusRef `shouldBeWithRetryM` True
696+ liftIO $ threadDelay 100000
697+ readRef focusRef >>= flip shouldBe True
989698 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
990699 (e, ()) <- selectElement def options
991700 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
992701 it "has correct initial value" $ runWD $ do
993702 valueRef :: IORef Text <- newRef ""
994− let checkValue = readRef valueRef `shouldBeWithRetryM` "one"
703+ let checkValue = readRef valueRef >>= flip shouldBe "one"
995704 testWidget (pure ()) checkValue $ do
996705 prerender_ (pure ()) $ do
997706 (e, ()) <- selectElement def { _selectElementConfig_initialValue = "one" } options
@@ -1001,12 +710,14 @@ tests withDebugging wdConfig caps _selenium = do
1001710 valueRef :: IORef Text <- newRef ""
1002711 setValueChan :: Chan Text <- liftIO newChan
1003712 let checkValue = do
1004− WD.click =<< findElemWithRetry (WD.ById "two")
1005− readRef valueByUIRef `shouldBeWithRetryM` "two"
1006− readRef valueRef `shouldBeWithRetryM` "two"
713+ WD.click <=< WD.findElem $ WD.ById "two"
714+ liftIO $ threadDelay 100000
715+ readRef valueByUIRef >>= flip shouldBe "two"
716+ readRef valueRef >>= flip shouldBe "two"
1007717 liftIO $ writeChan setValueChan "three"
1008− readRef valueByUIRef `shouldBeWithRetryM` "two"
1009− readRef valueRef `shouldBeWithRetryM` "three"
718+ liftIO $ threadDelay 100000
719+ readRef valueByUIRef >>= flip shouldBe "two"
720+ readRef valueRef >>= flip shouldBe "three"
1010721 testWidget (pure ()) checkValue $ do
1011722 setValue' <- triggerEventWithChan setValueChan
1012723 prerender_ (pure ()) $ do
@@ -1014,12 +725,12 @@ tests withDebugging wdConfig caps _selenium = do
1014725 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
1015726 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
1016727
1017− session' "prerender" $ do
728+ describe "prerender" $ session' $ do
1018729 it "works in simple case" $ runWD $ do
1019730 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
1020731 prerender_ (text "One") (text "Two")
1021732 it "removes element correctly" $ runWD $ do
1022− testWidget' (findElemWithRetry $ WD.ByTag "span") elementShouldBeRemoved $ do
733+ testWidget' (WD.findElem $ WD.ByTag "span") elementShouldBeRemoved $ do
1023734 prerender_ (el "span" $ text "One") (text "Two")
1024735 it "can be nested in server widget" $ runWD $ do
1025736 testWidget (checkBodyText "One") (checkBodyText "Three") $ do
@@ -1059,9 +770,9 @@ tests withDebugging wdConfig caps _selenium = do
1059770 pb <- getPostBuild
1060771 performEvent_ $ liftIO (putMVar lock ()) <$ pb
1061772 it "result Dynamic is updated *after* switchover" $ runWD $ do
1062− let preSwitchover = checkBodyText "PostBuild"
1063− check = checkBodyText "Client"
1064− testWidget preSwitchover check $ void $ do
773+ let static = shouldContainText "PostBuild" =<< WD.findElem (WD.ByTag "body")
774+ check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
775+ testWidget static check $ void $ do
1065776 d <- prerender (pure "Initial") (pure "Client")
1066777 pb <- getPostBuild
1067778 initial <- sample $ current d
@@ -1069,39 +780,32 @@ tests withDebugging wdConfig caps _selenium = do
1069780 -- This essentially checks that the client IO runs *after* switchover/postBuild,
1070781 -- thus can't create conflicting DOM
1071782 it "can't exploit IO to break hydration" $ runWD $ do
1072− let preSwitchover = checkBodyText "Initial"
1073− testWidgetStatic preSwitchover $ void $ do
783+ let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
784+ testWidgetStatic static $ void $ do
1074785 ref <- liftIO $ newRef "Initial"
1075786 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
1076787 text <=< liftIO $ readRef ref
1077788 -- As above, so below
1078789 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
790+ let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
791+ check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
792+ testWidget static check $ void $ do
1082793 (e, trigger) <- newTriggerEvent
1083794 prerender_ (pure ()) (liftIO $ trigger "Client")
1084795 textNode $ TextNodeConfig "Initial" $ Just e
1085796
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
797+ describe "runWithReplace" $ session' $ do
1096798 it "works" $ runWD $ do
1097799 replaceChan :: Chan Text <- liftIO newChan
1098− let setup = findElemWithRetry $ WD.ByTag "div"
800+ let setup = WD.findElem $ WD.ByTag "div"
1099801 check ssr = do
1100802 -- Check that the original element still exists and has the correct text
1101− shouldContainText "two" ssr
1102− liftIO $ writeChan replaceChan "three"
803+ WD.getText ssr >>= flip shouldBe "two"
804+ liftIO $ do
805+ writeChan replaceChan "three"
806+ threadDelay 100000
1103807 elementShouldBeRemoved ssr
1104− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
808+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1105809 testWidget' setup check $ do
1106810 replace <- triggerEventWithChan replaceChan
1107811 pb <- getPostBuild
@@ -1111,13 +815,15 @@ tests withDebugging wdConfig caps _selenium = do
1111815 ]
1112816 it "can be nested in initial widget" $ runWD $ do
1113817 replaceChan :: Chan Text <- liftIO newChan
1114− let setup = findElemWithRetry $ WD.ByTag "div"
818+ let setup = WD.findElem $ WD.ByTag "div"
1115819 check ssr = do
1116820 -- Check that the original element still exists and has the correct text
1117− shouldContainText "two" ssr
1118− liftIO $ writeChan replaceChan "three"
821+ WD.getText ssr >>= flip shouldBe "two"
822+ liftIO $ do
823+ writeChan replaceChan "three"
824+ threadDelay 100000
1119825 elementShouldBeRemoved ssr
1120− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
826+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1121827 testWidget' setup check $ void $ flip runWithReplace never $ do
1122828 replace <- triggerEventWithChan replaceChan
1123829 pb <- getPostBuild
@@ -1126,14 +832,16 @@ tests withDebugging wdConfig caps _selenium = do
1126832 , el "span" . text <$> replace
1127833 ]
1128834 it "can be nested in postBuild widget" $ runWD $ do
1129− replaceChan :: Chan Text <- liftIO newChan
1130− let setup = findElemWithRetry $ WD.ByTag "div"
835+ replaceChan <- liftIO newChan
836+ let setup = WD.findElem $ WD.ByTag "div"
1131837 check ssr = do
1132838 -- Check that the original element still exists and has the correct text
1133− shouldContainText "two" ssr
1134− liftIO $ writeChan replaceChan "three"
839+ WD.getText ssr >>= flip shouldBe "two"
840+ liftIO $ do
841+ writeChan replaceChan "three"
842+ threadDelay 100000
1135843 elementShouldBeRemoved ssr
1136− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
844+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1137845 testWidget' setup check $ void $ do
1138846 pb <- getPostBuild
1139847 runWithReplace (pure ()) $ ffor pb $ \() -> do
@@ -1159,15 +867,17 @@ tests withDebugging wdConfig caps _selenium = do
1159867 replaceChan2 :: Chan Text <- liftIO newChan
1160868 lock :: MVar () <- liftIO newEmptyMVar
1161869 let check = do
1162− shouldContainText "" =<< findElemWithRetry (WD.ByTag "body")
870+ shouldContainText "" =<< WD.findElem (WD.ByTag "body")
1163871 liftIO $ do
1164872 writeChan replaceChan1 "one"
1165873 takeMVar lock
1166− one <- findElemWithRetry $ WD.ByTag "div"
1167− shouldContainText "pb" one
1168− liftIO $ writeChan replaceChan2 "two"
874+ one <- WD.findElem $ WD.ByTag "div"
875+ WD.getText one >>= flip shouldBe "pb"
876+ liftIO $ do
877+ writeChan replaceChan2 "two"
878+ threadDelay 100000
1169879 elementShouldBeRemoved one
1170− shouldContainText "two" =<< findElemWithRetry (WD.ByTag "span")
880+ shouldContainText "two" =<< WD.findElem (WD.ByTag "span")
1171881 testWidget (pure ()) check $ void $ do
1172882 replace1 <- triggerEventWithChan replaceChan1
1173883 runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
@@ -1208,12 +918,14 @@ tests withDebugging wdConfig caps _selenium = do
1208918 it "works in immediate mode (RHS of prerender)" $ runWD $ do
1209919 replaceChan :: Chan Text <- liftIO newChan
1210920 let check = do
1211− checkBodyText "one"
1212− one <- findElemWithRetry $ WD.ByTag "div"
1213− shouldContainText "one" one
1214− liftIO $ writeChan replaceChan "pb"
921+ one <- WD.findElem $ WD.ByTag "div"
922+ shouldContainText "one" =<< WD.findElem (WD.ByTag "body")
923+ WD.getText one >>= flip shouldBe "one"
924+ liftIO $ do
925+ writeChan replaceChan "pb"
926+ threadDelay 100000
1215927 elementShouldBeRemoved one
1216− shouldContainText "pb" =<< findElemWithRetry (WD.ByTag "span")
928+ shouldContainText "pb" =<< WD.findElem (WD.ByTag "span")
1217929 testWidget (pure ()) check $ void $ do
1218930 replace <- triggerEventWithChan replaceChan
1219931 prerender_ blank $ do
@@ -1221,12 +933,14 @@ tests withDebugging wdConfig caps _selenium = do
1221933 it "works with postBuild in immediate mode (RHS of prerender)" $ runWD $ do
1222934 replaceChan :: Chan Text <- liftIO newChan
1223935 let check = do
1224− checkBodyText "two"
1225− two <- findElemWithRetry $ WD.ByTag "div"
1226− shouldContainText "two" two
1227− liftIO $ writeChan replaceChan "three"
936+ two <- WD.findElem $ WD.ByTag "div"
937+ shouldContainText "two" =<< WD.findElem (WD.ByTag "body")
938+ WD.getText two >>= flip shouldBe "two"
939+ liftIO $ do
940+ writeChan replaceChan "three"
941+ threadDelay 100000
1228942 elementShouldBeRemoved two
1229− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
943+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1230944 testWidget (pure ()) check $ void $ do
1231945 replace <- triggerEventWithChan replaceChan
1232946 prerender_ blank $ do
@@ -1236,61 +950,7 @@ tests withDebugging wdConfig caps _selenium = do
1236950 , el "span" . text <$> replace
1237951 ]
1238952
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
953+ describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1294954 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
1295955 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1296956 elClass "span" "key" $ text $ textKey k
@@ -1298,58 +958,58 @@ tests withDebugging wdConfig caps _selenium = do
1298958 pure (Identity v)
1299959 checkItem :: WD.Element -> Text -> Text -> WD ()
1300960 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")
961+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
962+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1304963 checkInitialItems dm xs = do
1305− putStrLnDebug "checkInitialItems"
1306964 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1307965 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"
966+ getAndCheckInitialItems dm = do
1310967 xs <- WD.findElems (WD.ByTag "li")
1311968 checkInitialItems dm xs
1312969 pure xs
1313970 checkRemoval chan k = do
1314− putStrLnDebug "checkRemoval"
1315− e <- findElemWithRetry (WD.ById $ textKey k)
1316− liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
971+ e <- WD.findElem (WD.ById $ textKey k)
972+ liftIO $ do
973+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
974+ threadDelay 100000
1317975 elementShouldBeRemoved e
1318976 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)
977+ e <- WD.findElem (WD.ById $ textKey k)
978+ liftIO $ do
979+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
980+ threadDelay 100000
1322981 elementShouldBeRemoved e
1323− e' <- findElemWithRetry $ WD.ById $ textKey k
982+ e' <- WD.findElem (WD.ById $ textKey k)
1324983 checkItem e' (textKey k) (T.pack $ show v)
1325984 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)
985+ liftIO $ do
986+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
987+ threadDelay 100000
988+ e <- WD.findElem (WD.ById $ textKey k)
1329989 checkItem e (textKey k) (T.pack $ show v)
1330990 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
1331991 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1332992 chan <- liftIO newChan
1333− let preSwitchover :: WD [WD.Element]
1334− preSwitchover = getAndCheckInitialItems keyMap
993+ let static :: WD [WD.Element]
994+ static = getAndCheckInitialItems keyMap
1335995 check :: [WD.Element] -> WD ()
1336996 check xs = do
1337997 checkInitialItems keyMap xs
1338998 checkRemoval chan Key_Int
1339999 checkReplace chan Key_Char 'B'
13401000 checkInsert chan Key_Bool True
1341− testWidget' preSwitchover check $ do
1001+ testWidget' static check $ do
13421002 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
13431003 liftIO $ dmap `H.shouldBe` keyMap
13441004 it "handles postBuild correctly" $ runWD $ do
13451005 chan <- liftIO newChan
1346− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1006+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
13471007 check xs = do
1348− withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1008+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch keyMap) xs
13491009 checkRemoval chan Key_Int
13501010 checkInsert chan Key_Char 'B'
13511011 checkReplace chan Key_Bool True
1352− testWidget' preSwitchover check $ void $ do
1012+ testWidget' static check $ void $ do
13531013 pb <- getPostBuild
13541014 replace <- triggerEventWithChan chan
13551015 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1382,7 +1042,7 @@ tests withDebugging wdConfig caps _selenium = do
13821042 it "handles postBuild correctly in prerender" $ runWD $ do
13831043 chan <- liftIO newChan
13841044 let check = do
1385− _ <- getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1045+ _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
13861046 checkRemoval chan Key_Int
13871047 checkInsert chan Key_Char 'B'
13881048 checkReplace chan Key_Bool True
@@ -1393,7 +1053,7 @@ tests withDebugging wdConfig caps _selenium = do
13931053 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
13941054 liftIO $ dmap `H.shouldBe` keyMap
13951055
1396− session' "traverseIntMapWithKeyWithAdjust" $ do
1056+ describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
13971057 let textKeyInt k = "key" <> T.pack (show k)
13981058 intMap = IntMap.fromList
13991059 [ (1, "one")
@@ -1407,89 +1067,89 @@ tests withDebugging wdConfig caps _selenium = do
14071067 pure v
14081068 checkItem :: WD.Element -> Text -> Text -> WD ()
14091069 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")
1070+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1071+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
14131072 checkInitialItems dm xs = do
1414− putStrLnDebug "checkInitialItems"
14151073 liftIO $ assertEqual "Wrong amount of items in DOM" (IntMap.size dm) (length xs)
14161074 forM_ (zip xs (IntMap.toList dm)) $ \(e, (k, v)) -> checkItem e (textKeyInt k) v
1417− getAndCheckInitialItems dm = withRetry $ do
1418− putStrLnDebug "getAndCheckInitialItems"
1075+ getAndCheckInitialItems dm = do
14191076 xs <- WD.findElems (WD.ByTag "li")
14201077 checkInitialItems dm xs
14211078 pure xs
14221079 checkRemoval chan k = do
1423− putStrLnDebug "checkRemoval"
1424− e <- findElemWithRetry (WD.ById $ textKeyInt k)
1425− liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1080+ e <- WD.findElem (WD.ById $ textKeyInt k)
1081+ liftIO $ do
1082+ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1083+ threadDelay 100000
14261084 elementShouldBeRemoved e
14271085 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
1086+ e <- WD.findElem (WD.ById $ textKeyInt k)
1087+ liftIO $ do
1088+ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1089+ threadDelay 100000
14311090 elementShouldBeRemoved e
1432− e' <- findElemWithRetry (WD.ById $ textKeyInt k)
1433− withRetry $ checkItem e' (textKeyInt k) v
1091+ e' <- WD.findElem (WD.ById $ textKeyInt k)
1092+ checkItem e' (textKeyInt k) v
14341093 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)
1094+ liftIO $ do
1095+ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1096+ threadDelay 100000
1097+ e <- WD.findElem (WD.ById $ textKeyInt k)
14381098 checkItem e (textKeyInt k) v
14391099 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1440− xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1100+ it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
14411101 chan <- liftIO newChan
1442− let preSwitchover = getAndCheckInitialItems intMap
1102+ let static = getAndCheckInitialItems intMap
14431103 check xs = do
14441104 checkInitialItems intMap xs
14451105 checkRemoval chan 1
14461106 checkReplace chan 2 "deux"
14471107 checkInsert chan 4 "four"
1448− testWidget' preSwitchover check $ void $ do
1108+ testWidget' static check $ void $ do
14491109 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
14501110 liftIO $ im `H.shouldBe` intMap
1451− xit "handles postBuild correctly" $ runWD $ do
1111+ it "handles postBuild correctly" $ runWD $ do
14521112 chan <- liftIO newChan
1453− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1113+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
14541114 check xs = do
1455− withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1115+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch intMap) xs
14561116 checkRemoval chan 1
14571117 checkInsert chan 2 "deux"
14581118 checkReplace chan 3 "trois"
1459− testWidget' preSwitchover check $ void $ do
1119+ testWidget' static check $ void $ do
14601120 pb <- getPostBuild
14611121 replace <- triggerEventWithChan chan
14621122 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
14631123 liftIO $ dmap `H.shouldBe` intMap
1464− xit "can delete/update/insert when built in prerender" $ runWD $ do
1124+ it "can delete/update/insert when built in prerender" $ runWD $ do
14651125 chan <- liftIO newChan
14661126 let check = do
14671127 _ <- getAndCheckInitialItems intMap
14681128 checkRemoval chan 1
14691129 checkReplace chan 2 "deux"
1470− checkInsert chan 4 "quatre"
1130+ checkInsert chan 3 "trois"
14711131 testWidget (pure ()) check $ do
14721132 replace <- triggerEventWithChan chan
14731133 prerender_ (pure ()) $ do
14741134 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap replace
14751135 liftIO $ dmap `H.shouldBe` intMap
1476− xit "can delete/update/insert when built in immediate mode" $ runWD $ do
1136+ it "can delete/update/insert when built in immediate mode" $ runWD $ do
14771137 chan <- liftIO newChan
14781138 let check = do
14791139 _ <- getAndCheckInitialItems intMap
14801140 checkRemoval chan 1
14811141 checkReplace chan 2 "deux"
1482− checkInsert chan 4 "quatre"
1142+ checkInsert chan 3 "trois"
14831143 testWidget (pure ()) check $ void $ do
14841144 pb <- getPostBuild
14851145 runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
14861146 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
14871147 liftIO $ dmap `H.shouldBe` intMap
14881148 -- Should be fixed by prerender changes!
1489− xit "handles postBuild correctly in prerender" $ runWD $ do
1149+ it "handles postBuild correctly in prerender" $ runWD $ do
14901150 chan <- liftIO newChan
14911151 let check = do
1492− _ <- getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1152+ _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
14931153 checkRemoval chan 1
14941154 checkInsert chan 2 "deux"
14951155 checkReplace chan 3 "trois"
@@ -1500,30 +1160,47 @@ tests withDebugging wdConfig caps _selenium = do
15001160 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
15011161 liftIO $ dmap `H.shouldBe` intMap
15021162
1503− session' "traverseDMapWithKeyWithAdjustWithMove" $ do
1163+ describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
15041164 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
1165+ widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1166+ elClass "span" "key" $ text $ textKey k
15071167 elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
15081168 pure (Identity v)
1509− textKey2 :: Key2 a -> Text
1510− textKey2 = \case
1169+ textKey :: Key2 a -> Text
1170+ textKey = \case
15111171 Key2_Int i -> "i" <> T.pack (show i)
15121172 Key2_Char c -> "c" <> T.pack [c]
15131173 checkItem :: WD.Element -> Text -> Text -> WD ()
15141174 checkItem li k v = do
1515− shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1516− shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
1175+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1176+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
15171177 checkInitialItems dm xs = do
15181178 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
1179+ forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
1180+ getAndCheckInitialItems dm = do
15211181 xs <- WD.findElems (WD.ByTag "li")
15221182 checkInitialItems dm xs
15231183 pure xs
1524− moveSpec
1525− :: (DMap Key2 Identity -> (WD.Element -> Chan (PatchDMapWithMove Key2 Identity) -> WD ()) -> WD ())
1526− -> H.SpecM (WdTestSession ()) ()
1184+ checkRemoval chan k = do
1185+ e <- WD.findElem (WD.ById $ textKey k)
1186+ liftIO $ do
1187+ writeChan chan $ deleteDMapKey k
1188+ threadDelay 100000
1189+ elementShouldBeRemoved e
1190+ checkReplace chan k v = do
1191+ e <- WD.findElem (WD.ById $ textKey k)
1192+ liftIO $ do
1193+ writeChan chan $ insertDMapKey k (Identity v)
1194+ threadDelay 100000
1195+ elementShouldBeRemoved e
1196+ e' <- WD.findElem (WD.ById $ textKey k)
1197+ checkItem e' (textKey k) (T.pack $ show v)
1198+ checkInsert chan k v = do
1199+ liftIO $ do
1200+ writeChan chan $ insertDMapKey k (Identity v)
1201+ threadDelay 100000
1202+ e <- WD.findElem (WD.ById $ textKey k)
1203+ checkItem e (textKey k) (T.pack $ show v)
15271204 moveSpec testMove = do
15281205 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
15291206 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
@@ -1551,26 +1228,26 @@ tests withDebugging wdConfig caps _selenium = do
15511228
15521229 describe "hydration" $ moveSpec $ \initMap test -> do
15531230 chan <- liftIO newChan
1554− let preSwitchover = getAndCheckInitialItems initMap
1231+ let static = getAndCheckInitialItems initMap
15551232 check xs = do
15561233 checkInitialItems initMap xs
1557− body <- getBody
1234+ body <- WD.findElem (WD.ByTag "body")
15581235 test body chan
1559− testWidget' preSwitchover check $ void $ do
1236+ testWidget' static check $ void $ do
15601237 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
15611238 liftIO $ assertEqual "DMap" initMap dmap
15621239
15631240 describe "hydration/immediate" $ moveSpec $ \initMap test -> do
15641241 chan <- liftIO newChan
15651242 replace <- liftIO newChan
1566− lock :: MVar () <- liftIO newEmptyMVar
1243+ lock <- liftIO newEmptyMVar
15671244 let check = do
15681245 liftIO $ do
15691246 writeChan replace ()
15701247 takeMVar lock
15711248 xs <- getAndCheckInitialItems initMap
15721249 checkInitialItems initMap xs
1573− body <- getBody
1250+ body <- WD.findElem (WD.ByTag "body")
15741251 test body chan
15751252 testWidget (pure ()) check $ void $ do
15761253 e <- triggerEventWithChan replace
@@ -1580,26 +1257,24 @@ tests withDebugging wdConfig caps _selenium = do
15801257 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
15811258 liftIO $ assertEqual "DMap" initMap dmap
15821259
1583− session' "hydrating invalid HTML" $ do
1584− xit "can hydrate list in paragraph" $ runWD $ do
1585− let preSwitchover = do
1586− checkBodyText "before\ninner\nafter"
1260+ describe "hydrating invalid HTML" $ session' $ do
1261+ it "can hydrate list in paragraph" $ runWD $ do
1262+ let static = do
1263+ body <- WD.findElem (WD.ByTag "body")
1264+ shouldContainText "before\ninner\nafter" body
15871265 -- 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")
1266+ [p1, p2] <- WD.findElems (WD.ByTag "p")
1267+ ol <- WD.findElem (WD.ByTag "ol")
15921268 shouldContainText "before" p1
15931269 shouldContainText "inner" ol
15941270 shouldContainText "" p2
1595− pure (p1, ol, p2)
1596− check (p1, ol, p2) = do
1597− checkBodyText "before\ninner\nafter"
1271+ pure (body, p1, ol, p2)
1272+ check (body, p1, ol, p2) = do
1273+ shouldContainText "before\ninner\nafter" body
15981274 shouldContainText "before\ninner\nafter" p1
15991275 elementShouldBeRemoved ol
16001276 elementShouldBeRemoved p2
1601− -- Don't fail fatally when hydration encounters the invalid DOM
1602− testWidgetDebug' False withDebugging preSwitchover check $ do
1277+ testWidget' static check $ do
16031278 -- This is deliberately invalid HTML, the browser will interpret it as
16041279 -- <p>before</p><ol>inner</ol>after<p></p>
16051280 el "p" $ do
@@ -1607,29 +1282,6 @@ tests withDebugging wdConfig caps _selenium = do
16071282 el "ol" $ text "inner"
16081283 text "after"
16091284
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−
16331285data Selenium = Selenium
16341286 { _selenium_portNumber :: PortNumber
16351287 , _selenium_stopServer :: IO ()
@@ -1646,10 +1298,11 @@ startSeleniumServer port = do
16461298
16471299withSeleniumServer :: (Selenium -> IO ()) -> IO ()
16481300withSeleniumServer f = do
1649− stopServer <- startSeleniumServer seleniumPort
1301+ port <- getFreePort
1302+ stopServer <- startSeleniumServer port
16501303 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
16511304 f $ Selenium
1652− { _selenium_portNumber = seleniumPort
1305+ { _selenium_portNumber = port
16531306 , _selenium_stopServer = stopServer
16541307 }
16551308
@@ -1660,163 +1313,121 @@ triggerEventWithChan chan = do
16601313 prerender_ (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
16611314 pure e
16621315
1663−shouldBeWithRetryM :: (Eq a, Show a) => WD a -> a -> WD ()
1664−shouldBeWithRetryM m expected = withRetry $ do
1665− got <- m
1666− got `shouldBe` expected
1667−
16681316assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
16691317assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
16701318
16711319elementShouldBeRemoved :: WD.Element -> WD ()
1672−elementShouldBeRemoved e = withRetry $ do
1320+elementShouldBeRemoved e = do
16731321 try (WD.getText e) >>= \case
16741322 Left (WD.FailedCommand WD.StaleElementReference _) -> return ()
16751323 Left err -> throwM err
16761324 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
16771325
16781326shouldContainText :: 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
1327+shouldContainText t = flip shouldBe t <=< WD.getText
16831328
16841329checkBodyText :: Text -> WD ()
16851330checkBodyText = checkTextInTag "body"
16861331
16871332checkTextInTag :: Text -> Text -> WD ()
1688−checkTextInTag t expected = do
1689− e <- findElemWithRetry (WD.ByTag t)
1690− shouldContainText expected e
1333+checkTextInTag t expected = WD.findElem (WD.ByTag t) >>= shouldContainText expected
16911334
16921335checkTextInId :: 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
1336+checkTextInId i expected = WD.findElem (WD.ById i) >>= shouldContainText expected
17151337
17161338divId :: DomBuilder t m => Text -> m a -> m a
17171339divId i = elAttr "div" ("id" =: i)
17181340
17191341type 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)
17201342
1721−testWidgetStaticDebug
1722− :: Bool
1723− -> WD b
1343+testWidgetStatic
1344+ :: WD b
17241345 -- ^ Webdriver commands to run before JS runs and after hydration switchover
17251346 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17261347 -- ^ Widget we are testing
17271348 -> WD b
1728−testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
1349+testWidgetStatic w = testWidget (void w) w
17291350
17301351-- | TODO: do something about JSExceptions not causing tests to fail
1731−testWidgetDebug
1732− :: Bool
1733− -> Bool
1734− -> WD ()
1352+testWidget
1353+ :: WD ()
17351354 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
17361355 -> WD b
17371356 -- ^ Webdriver commands to run after hydration switchover
17381357 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17391358 -- ^ Widget we are testing
17401359 -> 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
1360+testWidget beforeJS afterSwitchover = testWidget' beforeJS (const afterSwitchover)
17461361
17471362-- | TODO: do something about JSExceptions not causing tests to fail
1748−testWidgetDebug'
1749− :: Bool
1750− -> Bool
1751− -> WD a
1363+testWidget'
1364+ :: WD a
17521365 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
17531366 -> (a -> WD b)
17541367 -- ^ Webdriver commands to run after hydration switchover
17551368 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17561369 -- ^ Widget we are testing (contents of body)
17571370 -> 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
1371+testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out") pure <=< timeout testTimeLimit $ do
1372+ let staticApp = do
17621373 el "head" $ pure ()
17631374 el "body" $ do
17641375 bodyWidget
17651376 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1766− putStrLnDebug "rendering static"
1767− ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1768− putStrLnDebug "rendered static"
1377+ ((), html) <- liftIO $ renderStatic staticApp
17691378 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1770− onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
17711379 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
17721380 let entryPoint = do
1773− putStrLnDebug "taking waitBeforeJS"
17741381 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"
1382+ mainHydrationWidgetWithSwitchoverAction (putMVar waitUntilSwitchover ()) (pure ()) bodyWidget
17841383 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
1384+ application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse ->
1385+ sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1386+ port <- getFreePort
17901387 waitJSaddle <- liftIO newEmptyMVar
17911388 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"
1389+ [ Warp.setPort $ fromIntegral (toInteger port)
1390+ , Warp.setBeforeMainLoop $ putMVar waitJSaddle ()
17971391 ]
17981392 -- 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
1393+ jsaddleWarp = forkIO $ hSilence [stderr] $ Warp.runSettings settings application
1394+ jsaddleTid <- liftIO jsaddleWarp
1395+ liftIO $ takeMVar waitJSaddle
1396+ WD.openPage $ "http://localhost:" <> show port
1397+ a <- beforeJS
1398+ liftIO $ putMVar waitBeforeJS ()
1399+ liftIO $ takeMVar waitUntilSwitchover
1400+ liftIO $ threadDelay 100000 -- wait a bit
1401+ b <- afterSwitchover a
1402+ liftIO $ killThread jsaddleTid
1403+ return b
1404+
18141405
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)
1406+-- TODO: Should this be part of more widely used module?
1407+-- TODO: Ensure port is not taken
1408+getFreePort :: MonadIO m => m PortNumber
1409+getFreePort = liftIO $ withSocketsDo $ do
1410+ addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
1411+ bracket (open addr) close socketPort
1412+ where
1413+ open addr = do
1414+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
1415+ bind sock (addrAddress addr)
1416+ return sock
1417+
1418+testWidgetDebug :: MonadIO n => (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> n ()
1419+testWidgetDebug bodyWidget = liftIO $ do
1420+ let staticApp = do
1421+ el "head" $ pure ()
1422+ el "body" $ do
1423+ bodyWidget
1424+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1425+ ((), html) <- renderStatic staticApp
1426+ let entryPoint = do
1427+ mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) bodyWidget
1428+ syncPoint
1429+ application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1430+ Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application
18201431
18211432data Key2 a where
18221433 Key2_Int :: Int -> Key2 Int
@@ -1825,4 +1436,18 @@ data Key2 a where
18251436deriveGEq ''Key2
18261437deriveGCompare ''Key2
18271438deriveGShow ''Key2
1828−deriveArgDict ''Key2
1439+
1440+instance ShowTag Key2 Identity where
1441+ showTaggedPrec = \case
1442+ Key2_Int _ -> showsPrec
1443+ Key2_Char _ -> showsPrec
1444+
1445+instance EqTag Key2 Identity where
1446+ eqTagged (Key2_Int _) (Key2_Int _) = (==)
1447+ eqTagged (Key2_Char _) (Key2_Char _) = (==)
1448+
1449+instance ArgDict Key2 where
1450+ type ConstraintsFor Key2 c = (c Int, c Char)
1451+ argDict = \case
1452+ Key2_Int _ -> Dict
1453+ Key2_Char _ -> Dict