@@ -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"
@@ -214,38 +177,39 @@ tests withDebugging wdConfig caps _selenium = do
214177 el "div" $ do
215178 el "span" $ text "hello world"
216179 text ""
217−-- TODO I think these two tests are broken
218−-- it "updates after postBuild" $ runWD $ do
219−-- testWidget (checkBodyText "initial") (checkBodyText "after") $ do
220−-- after <- delay 0 =<< getPostBuild
221−-- void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ after
222−-- it "updates immediately after postBuild" $ runWD $ do
223−-- testWidget (checkBodyText "pb") (checkBodyText "after") $ do
224−-- pb <- getPostBuild
225−-- after <- delay 0 pb
226−-- void $ textNode $ TextNodeConfig "initial" $ Just $ leftmost ["pb" <$ pb, "after" <$ after]
180+ it "updates after postBuild" $ runWD $ do -- TODO I think these two tests are broken
181+ testWidget (checkBodyText "initial") (checkBodyText "after") $ do
182+ after <- delay 0 =<< getPostBuild
183+ void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ after
184+ it "updates immediately after postBuild" $ runWD $ do
185+ testWidget (checkBodyText "pb") (checkBodyText "after") $ do
186+ pb <- getPostBuild
187+ after <- delay 0 pb
188+ void $ textNode $ TextNodeConfig "initial" $ Just $ leftmost ["pb" <$ pb, "after" <$ after]
227189 it "updates in immediate mode" $ runWD $ do
228190 let checkUpdated = do
229191 checkBodyText "initial"
230− WD.click =<< findElemWithRetry (WD.ByTag "button")
192+ WD.click =<< WD.findElem (WD.ByTag "button")
193+ liftIO $ threadDelay 100000 -- wait for update
231194 checkBodyText "after"
232195 testWidget (pure ()) checkUpdated $ prerender_ (pure ()) $ do
233196 click <- button ""
234197 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
235198
236− session' "element" $ do
199+ describe "element" $ session' $ do
237200 it "works with domEvent Click" $ runWD $ do
238201 clickedRef <- liftIO $ newRef False
239− testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
202+ testWidget' (WD.findElem $ WD.ByTag "div") WD.click $ do
240203 (e, _) <- el' "div" $ text "hello world"
241204 performEvent_ $ liftIO (writeRef clickedRef True) <$ domEvent Click e
242− readRef clickedRef `shouldBeWithRetryM` True
205+ clicked <- liftIO $ readRef clickedRef
206+ liftIO $ assertEqual "Not clicked" True clicked
243207 it "works with eventFlags stopPropagation" $ runWD $ do
244208 firstClickedRef <- newRef False
245209 secondClickedRef <- newRef False
246210 let clickBoth = do
247− findElemWithRetry (WD.ById "first") >>= WD.click
248− findElemWithRetry (WD.ById "second") >>= WD.click
211+ WD.findElem (WD.ById "first") >>= WD.click
212+ WD.findElem (WD.ById "second") >>= WD.click
249213 testWidget (pure ()) clickBoth $ do
250214 (firstDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do
251215 void $ elAttr "span" ("id" =: "first") $ text "hello world"
@@ -262,7 +226,7 @@ tests withDebugging wdConfig caps _selenium = do
262226 assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)
263227 it "works with eventFlags preventDefault" $ runWD $ do
264228 let click = do
265− e <- findElemWithRetry $ WD.ByTag "input"
229+ e <- WD.findElem $ WD.ByTag "input"
266230 s0 <- WD.isSelected e
267231 WD.click e
268232 s1 <- WD.isSelected e
@@ -276,7 +240,7 @@ tests withDebugging wdConfig caps _selenium = do
276240 assertEqual "Click not prevented" (False, False) clicked
277241 it "can add/update/remove attributes" $ runWD $ do
278242 let checkInitialAttrs = do
279− e <- findElemWithRetry $ WD.ByTag "div"
243+ e <- WD.findElem $ WD.ByTag "div"
280244 assertAttr e "const" (Just "const")
281245 assertAttr e "delete" (Just "delete")
282246 assertAttr e "init" (Just "init")
@@ -284,11 +248,11 @@ tests withDebugging wdConfig caps _selenium = do
284248 pure e
285249 checkModifyAttrs e = do
286250 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")
251+ liftIO $ threadDelay 100000
252+ assertAttr e "const" (Just "const")
253+ assertAttr e "delete" Nothing
254+ assertAttr e "init" (Just "click")
255+ assertAttr e "click" (Just "click")
292256 testWidget' checkInitialAttrs checkModifyAttrs $ mdo
293257 let conf = def
294258 & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"
@@ -296,87 +260,40 @@ tests withDebugging wdConfig caps _selenium = do
296260 (e, ()) <- element "div" conf $ text "hello world"
297261 let click = domEvent Click e
298262 return ()
263+ -- TODO check this is the correct solution
264+ it "has ssr attribute, removes ssr attribute" $ runWD $ do
265+ let checkSSRAttr = do
266+ e <- WD.findElem $ WD.ByTag "div"
267+ assertAttr e "data-ssr" (Just "")
268+ pure e
269+ testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world"
299270
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
271+ describe "inputElement" $ do
272+ describe "hydration" $ session' $ do
359273 it "doesn't wipe user input when switching over" $ runWD $ do
360− inputRef <- newRef ("hello " :: Text)
274+ inputRef <- newRef ("" :: Text)
361275 testWidget'
362276 (do
363− e <- findElemWithRetry $ WD.ByTag "input"
364− WD.sendKeys "world" e
277+ e <- WD.findElem $ WD.ByTag "input"
278+ WD.sendKeys "hello world" e
365279 pure e)
366280 (\e -> do
367− WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
368− WD.click =<< findElemWithRetry (WD.ByTag "button")
369− readRef inputRef `shouldBeWithRetryM` "hello world"
281+ t <- WD.attr e "value"
282+ t `shouldBe` Just "hello world"
283+ WD.click <=< WD.findElem $ WD.ByTag "button"
284+ input <- liftIO $ readRef inputRef
285+ input `shouldBe` "hello world"
370286 ) $ do
371− e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
287+ e <- inputElement def
372288 click <- button "save"
373289 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
374290 it "captures user input after switchover" $ runWD $ do
375291 inputRef <- newRef ("" :: Text)
376292 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"
293+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
294+ WD.click <=< WD.findElem $ WD.ByTag "button"
295+ input <- liftIO $ readRef inputRef
296+ input `shouldBe` "hello world"
380297 testWidget (pure ()) checkValue $ do
381298 e <- inputElement def
382299 click <- button "save"
@@ -384,21 +301,23 @@ tests withDebugging wdConfig caps _selenium = do
384301 it "sets focus appropriately" $ runWD $ do
385302 focusRef <- newRef False
386303 let checkValue = do
387− readRef focusRef `shouldBeWithRetryM` False
388− e <- findElemWithRetry $ WD.ByTag "input"
304+ readRef focusRef >>= flip shouldBe False
305+ e <- WD.findElem $ WD.ByTag "input"
389306 WD.click e
390− readRef focusRef `shouldBeWithRetryM` True
307+ liftIO $ threadDelay 100000
308+ readRef focusRef >>= flip shouldBe True
391309 testWidget (pure ()) checkValue $ do
392310 e <- inputElement def
393311 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
394312 it "sets focus when focus occurs before hydration" $ runWD $ do
395313 focusRef <- newRef False
396314 let setup = do
397− e <- findElemWithRetry $ WD.ByTag "input"
315+ e <- WD.findElem $ WD.ByTag "input"
398316 WD.click e
399− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
400− readRef focusRef `shouldBeWithRetryM` False
401− check = readRef focusRef `shouldBeWithRetryM` True
317+ hasFocus <- (== e) <$> WD.activeElem
318+ hasFocus `shouldBe` True
319+ readRef focusRef >>= flip shouldBe False
320+ check = readRef focusRef >>= flip shouldBe True
402321 testWidget setup check $ do
403322 e <- inputElement def
404323 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -407,15 +326,17 @@ tests withDebugging wdConfig caps _selenium = do
407326 valueRef <- newRef ("" :: Text)
408327 setValueChan :: Chan Text <- liftIO newChan
409328 let checkValue = do
410− readRef valueByUIRef `shouldBeWithRetryM` ""
411− readRef valueRef `shouldBeWithRetryM` ""
412− e <- findElemWithRetry $ WD.ByTag "input"
329+ readRef valueByUIRef >>= flip shouldBe ""
330+ readRef valueRef >>= flip shouldBe ""
331+ e <- WD.findElem $ WD.ByTag "input"
413332 WD.sendKeys "hello" e
414− readRef valueByUIRef `shouldBeWithRetryM` "hello"
415− readRef valueRef `shouldBeWithRetryM` "hello"
333+ liftIO $ threadDelay 100000
334+ readRef valueByUIRef >>= flip shouldBe "hello"
335+ readRef valueRef >>= flip shouldBe "hello"
416336 liftIO $ writeChan setValueChan "world"
417− readRef valueByUIRef `shouldBeWithRetryM` "hello"
418− readRef valueRef `shouldBeWithRetryM` "world"
337+ liftIO $ threadDelay 100000
338+ readRef valueByUIRef >>= flip shouldBe "hello"
339+ readRef valueRef >>= flip shouldBe "world"
419340 testWidget (pure ()) checkValue $ do
420341 update <- triggerEventWithChan setValueChan
421342 e <- inputElement $ def & inputElementConfig_setValue .~ update
@@ -425,181 +346,51 @@ tests withDebugging wdConfig caps _selenium = do
425346 checkedByUIRef <- newRef False
426347 checkedRef <- newRef False
427348 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
349+ let checkValue = do
350+ readRef checkedByUIRef >>= flip shouldBe False
351+ readRef checkedRef >>= flip shouldBe False
352+ e <- WD.findElem $ WD.ByTag "input"
436353 WD.moveToCenter e
437354 WD.click e
438− readRef checkedByUIRef `shouldBeWithRetryM` True
439− readRef checkedRef `shouldBeWithRetryM` True
440− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
355+ liftIO $ threadDelay 100000
356+ readRef checkedByUIRef >>= flip shouldBe True
357+ readRef checkedRef >>= flip shouldBe True
441358 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
359+ liftIO $ threadDelay 100000
360+ readRef checkedByUIRef >>= flip shouldBe True
361+ readRef checkedRef >>= flip shouldBe False
362+ testWidget (pure ()) checkValue $ do
446363 setChecked <- triggerEventWithChan setCheckedChan
447364 e <- inputElement $ def
448365 & initialAttributes .~ "type" =: "checkbox"
449366 & inputElementConfig_setChecked .~ setChecked
450367 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
451368 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)
471369 it "captures file uploads" $ runWD $ do
472370 filesRef :: IORef [Text] <- newRef []
473371 let uploadFile = do
474− e <- findElemWithRetry $ WD.ByTag "input"
372+ e <- WD.findElem $ WD.ByTag "input"
475373 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
476374 WD.sendKeys (T.pack path) e
477− WD.click =<< findElemWithRetry (WD.ByTag "button")
375+ WD.click <=< WD.findElem $ WD.ByTag "button"
478376 liftIO $ removeFile path
479− readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
377+ input <- readRef filesRef
378+ input `shouldBe` [T.pack $ FilePath.takeFileName path]
480379 testWidget (pure ()) uploadFile $ do
481380 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
482381 click <- button "save"
483382 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
484383 names <- liftJSM $ traverse File.getName fs
485384 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
385+
386+ describe "hydration/immediate" $ session' $ do
597387 it "captures user input after switchover" $ runWD $ do
598388 inputRef :: IORef Text <- newRef ""
599389 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"
390+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
391+ WD.click <=< WD.findElem $ WD.ByTag "button"
392+ input <- readRef inputRef
393+ input `shouldBe` "hello world"
603394 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
604395 e <- inputElement def
605396 click <- button "save"
@@ -607,10 +398,11 @@ tests withDebugging wdConfig caps _selenium = do
607398 it "sets focus appropriately" $ runWD $ do
608399 focusRef <- newRef False
609400 let checkValue = do
610− readRef focusRef `shouldBeWithRetryM` False
611− e <- findElemWithRetry $ WD.ByTag "input"
401+ readRef focusRef >>= flip shouldBe False
402+ e <- WD.findElem $ WD.ByTag "input"
612403 WD.click e
613− readRef focusRef `shouldBeWithRetryM` True
404+ liftIO $ threadDelay 100000
405+ readRef focusRef >>= flip shouldBe True
614406 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
615407 e <- inputElement def
616408 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -619,15 +411,17 @@ tests withDebugging wdConfig caps _selenium = do
619411 valueRef :: IORef Text <- newRef ""
620412 setValueChan :: Chan Text <- liftIO newChan
621413 let checkValue = do
622− readRef valueByUIRef `shouldBeWithRetryM` ""
623− readRef valueRef `shouldBeWithRetryM` ""
624− e <- findElemWithRetry $ WD.ByTag "input"
414+ readRef valueByUIRef >>= flip shouldBe ""
415+ readRef valueRef >>= flip shouldBe ""
416+ e <- WD.findElem $ WD.ByTag "input"
625417 WD.sendKeys "hello" e
626− readRef valueByUIRef `shouldBeWithRetryM` "hello"
627− readRef valueRef `shouldBeWithRetryM` "hello"
418+ liftIO $ threadDelay 100000
419+ readRef valueByUIRef >>= flip shouldBe "hello"
420+ readRef valueRef >>= flip shouldBe "hello"
628421 liftIO $ writeChan setValueChan "world"
629− readRef valueByUIRef `shouldBeWithRetryM` "hello"
630− readRef valueRef `shouldBeWithRetryM` "world"
422+ liftIO $ threadDelay 100000
423+ readRef valueByUIRef >>= flip shouldBe "hello"
424+ readRef valueRef >>= flip shouldBe "world"
631425 testWidget (pure ()) checkValue $ do
632426 update <- triggerEventWithChan setValueChan
633427 prerender_ (pure ()) $ do
@@ -639,16 +433,18 @@ tests withDebugging wdConfig caps _selenium = do
639433 checkedRef <- newRef False
640434 setCheckedChan <- liftIO newChan
641435 let checkValue = do
642− readRef checkedByUIRef `shouldBeWithRetryM` False
643− readRef checkedRef `shouldBeWithRetryM` False
644− e <- findElemWithRetry $ WD.ByTag "input"
436+ readRef checkedByUIRef >>= flip shouldBe False
437+ readRef checkedRef >>= flip shouldBe False
438+ e <- WD.findElem $ WD.ByTag "input"
645439 WD.moveToCenter e
646440 WD.click e
647− readRef checkedByUIRef `shouldBeWithRetryM` True
648− readRef checkedRef `shouldBeWithRetryM` True
441+ liftIO $ threadDelay 100000
442+ readRef checkedByUIRef >>= flip shouldBe True
443+ readRef checkedRef >>= flip shouldBe True
649444 liftIO $ writeChan setCheckedChan False
650− readRef checkedByUIRef `shouldBeWithRetryM` True
651− readRef checkedRef `shouldBeWithRetryM` False
445+ liftIO $ threadDelay 100000
446+ readRef checkedByUIRef >>= flip shouldBe True
447+ readRef checkedRef >>= flip shouldBe False
652448 testWidget (pure ()) checkValue $ do
653449 setChecked <- triggerEventWithChan setCheckedChan
654450 prerender_ (pure ()) $ do
@@ -660,12 +456,13 @@ tests withDebugging wdConfig caps _selenium = do
660456 it "captures file uploads" $ runWD $ do
661457 filesRef :: IORef [Text] <- newRef []
662458 let uploadFile = do
663− e <- findElemWithRetry $ WD.ByTag "input"
459+ e <- WD.findElem $ WD.ByTag "input"
664460 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
665461 WD.sendKeys (T.pack path) e
666− WD.click =<< findElemWithRetry (WD.ByTag "button")
462+ WD.click <=< WD.findElem $ WD.ByTag "button"
667463 liftIO $ removeFile path
668− readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
464+ input <- liftIO $ readRef filesRef
465+ input `shouldBe` [T.pack $ FilePath.takeFileName path]
669466 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
670467 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
671468 click <- button "save"
@@ -673,42 +470,21 @@ tests withDebugging wdConfig caps _selenium = do
673470 names <- liftJSM $ traverse File.getName fs
674471 liftIO $ writeRef filesRef names
675472
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
473+ describe "textAreaElement" $ do
474+ describe "hydration" $ session' $ do
701475 it "doesn't wipe user input when switching over" $ runWD $ do
702476 inputRef <- newRef ("" :: Text)
703477 testWidget'
704478 (do
705− e <- findElemWithRetry $ WD.ByTag "textarea"
479+ e <- WD.findElem $ WD.ByTag "textarea"
706480 WD.sendKeys "hello world" e
707481 pure e)
708482 (\e -> do
709− WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
710− WD.click <=< findElemWithRetry $ WD.ByTag "button"
711− readRef inputRef `shouldBeWithRetryM` "hello world"
483+ t <- WD.attr e "value"
484+ t `shouldBe` Just "hello world"
485+ WD.click <=< WD.findElem $ WD.ByTag "button"
486+ input <- readRef inputRef
487+ input `shouldBe` "hello world"
712488 ) $ do
713489 e <- textAreaElement def
714490 click <- button "save"
@@ -716,9 +492,10 @@ tests withDebugging wdConfig caps _selenium = do
716492 it "captures user input after switchover" $ runWD $ do
717493 inputRef <- newRef ("" :: Text)
718494 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"
495+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
496+ WD.click <=< WD.findElem $ WD.ByTag "button"
497+ input <- readRef inputRef
498+ input `shouldBe` "hello world"
722499 testWidget (pure ()) checkValue $ do
723500 e <- textAreaElement def
724501 click <- button "save"
@@ -726,21 +503,23 @@ tests withDebugging wdConfig caps _selenium = do
726503 it "sets focus appropriately" $ runWD $ do
727504 focusRef <- newRef False
728505 let checkValue = do
729− readRef focusRef `shouldBeWithRetryM` False
730− e <- findElemWithRetry $ WD.ByTag "textarea"
506+ readRef focusRef >>= flip shouldBe False
507+ e <- WD.findElem $ WD.ByTag "textarea"
731508 WD.click e
732− readRef focusRef `shouldBeWithRetryM` True
509+ liftIO $ threadDelay 100000
510+ readRef focusRef >>= flip shouldBe True
733511 testWidget (pure ()) checkValue $ do
734512 e <- textAreaElement def
735513 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
736514 it "sets focus when focus occurs before hydration" $ runWD $ do
737515 focusRef <- newRef False
738516 let setup = do
739− e <- findElemWithRetry $ WD.ByTag "textarea"
517+ e <- WD.findElem $ WD.ByTag "textarea"
740518 WD.click e
741− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
742− readRef focusRef `shouldBeWithRetryM` False
743− check = readRef focusRef `shouldBeWithRetryM` True
519+ hasFocus <- (== e) <$> WD.activeElem
520+ hasFocus `shouldBe` True
521+ readRef focusRef >>= flip shouldBe False
522+ check = readRef focusRef >>= flip shouldBe True
744523 testWidget setup check $ do
745524 e <- textAreaElement def
746525 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -749,110 +528,31 @@ tests withDebugging wdConfig caps _selenium = do
749528 valueRef <- newRef ("" :: Text)
750529 setValueChan :: Chan Text <- liftIO newChan
751530 let checkValue = do
752− readRef valueByUIRef `shouldBeWithRetryM` ""
753− readRef valueRef `shouldBeWithRetryM` ""
754− e <- findElemWithRetry $ WD.ByTag "textarea"
531+ readRef valueByUIRef >>= flip shouldBe ""
532+ readRef valueRef >>= flip shouldBe ""
533+ e <- WD.findElem $ WD.ByTag "textarea"
755534 WD.sendKeys "hello" e
756− readRef valueByUIRef `shouldBeWithRetryM` "hello"
757− readRef valueRef `shouldBeWithRetryM` "hello"
535+ liftIO $ threadDelay 100000
536+ readRef valueByUIRef >>= flip shouldBe "hello"
537+ readRef valueRef >>= flip shouldBe "hello"
758538 liftIO $ writeChan setValueChan "world"
759− readRef valueByUIRef `shouldBeWithRetryM` "hello"
760− readRef valueRef `shouldBeWithRetryM` "world"
539+ liftIO $ threadDelay 100000
540+ readRef valueByUIRef >>= flip shouldBe "hello"
541+ readRef valueRef >>= flip shouldBe "world"
761542 testWidget (pure ()) checkValue $ do
762543 setValue' <- triggerEventWithChan setValueChan
763544 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
764545 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
765546 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
848547
849− describe "hydration/immediate" $ do
548+ describe "hydration/immediate" $ session' $ do
850549 it "captures user input after switchover" $ runWD $ do
851550 inputRef :: IORef Text <- newRef ""
852551 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"
552+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
553+ WD.click <=< WD.findElem $ WD.ByTag "button"
554+ input <- liftIO $ readRef inputRef
555+ input `shouldBe` "hello world"
856556 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
857557 e <- textAreaElement def
858558 click <- button "save"
@@ -860,10 +560,11 @@ tests withDebugging wdConfig caps _selenium = do
860560 it "sets focus appropriately" $ runWD $ do
861561 focusRef <- newRef False
862562 let checkValue = do
863− readRef focusRef `shouldBeWithRetryM` False
864− e <- findElemWithRetry $ WD.ByTag "textarea"
563+ readRef focusRef >>= flip shouldBe False
564+ e <- WD.findElem $ WD.ByTag "textarea"
865565 WD.click e
866− readRef focusRef `shouldBeWithRetryM` True
566+ liftIO $ threadDelay 100000
567+ readRef focusRef >>= flip shouldBe True
867568 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
868569 e <- textAreaElement def
869570 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -872,15 +573,17 @@ tests withDebugging wdConfig caps _selenium = do
872573 valueRef :: IORef Text <- newRef ""
873574 setValueChan :: Chan Text <- liftIO newChan
874575 let checkValue = do
875− readRef valueByUIRef `shouldBeWithRetryM` ""
876− readRef valueRef `shouldBeWithRetryM` ""
877− e <- findElemWithRetry $ WD.ByTag "textarea"
576+ readRef valueByUIRef >>= flip shouldBe ""
577+ readRef valueRef >>= flip shouldBe ""
578+ e <- WD.findElem $ WD.ByTag "textarea"
878579 WD.sendKeys "hello" e
879− readRef valueByUIRef `shouldBeWithRetryM` "hello"
880− readRef valueRef `shouldBeWithRetryM` "hello"
580+ liftIO $ threadDelay 100000
581+ readRef valueByUIRef >>= flip shouldBe "hello"
582+ readRef valueRef >>= flip shouldBe "hello"
881583 liftIO $ writeChan setValueChan "world"
882− readRef valueByUIRef `shouldBeWithRetryM` "hello"
883− readRef valueRef `shouldBeWithRetryM` "world"
584+ liftIO $ threadDelay 100000
585+ readRef valueByUIRef >>= flip shouldBe "hello"
586+ readRef valueRef >>= flip shouldBe "world"
884587 testWidget (pure ()) checkValue $ do
885588 setValue' <- triggerEventWithChan setValueChan
886589 prerender_ (pure ()) $ do
@@ -888,26 +591,26 @@ tests withDebugging wdConfig caps _selenium = do
888591 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
889592 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
890593
891− session' "selectElement" $ do
594+ describe "selectElement" $ do
892595 let options :: DomBuilder t m => m ()
893596 options = do
894597 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
895598 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
896599 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
897− describe "hydration" $ do
600+ describe "hydration" $ session' $ do
898601 it "sets initial value correctly" $ runWD $ do
899602 inputRef <- newRef ("" :: Text)
900603 let setup = do
901− e <- findElemWithRetry $ WD.ByTag "select"
604+ e <- WD.findElem $ WD.ByTag "select"
902605 assertAttr e "value" (Just "three")
903− WD.click =<< findElemWithRetry (WD.ById "two")
606+ WD.click <=< WD.findElem $ WD.ById "two"
904607 pure e
905608 check e = do
906609 assertAttr e "value" (Just "two")
907− readRef inputRef `shouldBeWithRetryM` "three"
908− WD.click =<< findElemWithRetry (WD.ByTag "button")
610+ readRef inputRef >>= (`shouldBe` "three")
611+ WD.click <=< WD.findElem $ WD.ByTag "button"
909612 assertAttr e "value" (Just "two")
910− readRef inputRef `shouldBeWithRetryM` "two"
613+ readRef inputRef >>= (`shouldBe` "two")
911614 testWidget' setup check $ do
912615 (e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options
913616 click <- button "save"
@@ -916,12 +619,12 @@ tests withDebugging wdConfig caps _selenium = do
916619 it "captures user input after switchover" $ runWD $ do
917620 inputRef <- newRef ("" :: Text)
918621 let checkValue = do
919− e <- findElemWithRetry $ WD.ByTag "select"
622+ e <- WD.findElem $ WD.ByTag "select"
920623 assertAttr e "value" (Just "one")
921− WD.click =<< findElemWithRetry (WD.ById "two")
624+ WD.click <=< WD.findElem $ WD.ById "two"
922625 assertAttr e "value" (Just "two")
923− WD.click =<< findElemWithRetry (WD.ByTag "button")
924− readRef inputRef `shouldBeWithRetryM` "two"
626+ WD.click <=< WD.findElem $ WD.ByTag "button"
627+ readRef inputRef >>= (`shouldBe` "two")
925628 testWidget (pure ()) checkValue $ do
926629 (e, ()) <- selectElement def options
927630 click <- button "save"
@@ -929,21 +632,23 @@ tests withDebugging wdConfig caps _selenium = do
929632 it "sets focus appropriately" $ runWD $ do
930633 focusRef <- newRef False
931634 let checkValue = do
932− readRef focusRef `shouldBeWithRetryM` False
933− e <- findElemWithRetry $ WD.ByTag "select"
635+ readRef focusRef >>= flip shouldBe False
636+ e <- WD.findElem $ WD.ByTag "select"
934637 WD.click e
935− readRef focusRef `shouldBeWithRetryM` True
638+ liftIO $ threadDelay 100000
639+ readRef focusRef >>= flip shouldBe True
936640 testWidget (pure ()) checkValue $ do
937641 (e, ()) <- selectElement def options
938642 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
939643 it "sets focus when focus occurs before hydration" $ runWD $ do
940644 focusRef <- newRef False
941645 let setup = do
942− e <- findElemWithRetry $ WD.ByTag "select"
646+ e <- WD.findElem $ WD.ByTag "select"
943647 WD.click e
944− ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
945− readRef focusRef `shouldBeWithRetryM` False
946− check = readRef focusRef `shouldBeWithRetryM` True
648+ hasFocus <- (== e) <$> WD.activeElem
649+ hasFocus `shouldBe` True
650+ readRef focusRef >>= flip shouldBe False
651+ check = readRef focusRef >>= flip shouldBe True
947652 testWidget setup check $ do
948653 (e, ()) <- selectElement def options
949654 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
@@ -952,29 +657,31 @@ tests withDebugging wdConfig caps _selenium = do
952657 valueRef <- newRef ("" :: Text)
953658 setValueChan :: Chan Text <- liftIO newChan
954659 let checkValue = do
955− e <- findElemWithRetry $ WD.ByTag "select"
660+ e <- WD.findElem $ WD.ByTag "select"
956661 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"
662+ readRef valueByUIRef >>= flip shouldBe "one"
663+ readRef valueRef >>= flip shouldBe "one"
664+ WD.click <=< WD.findElem $ WD.ById "two"
665+ liftIO $ threadDelay 100000
666+ readRef valueByUIRef >>= flip shouldBe "two"
667+ readRef valueRef >>= flip shouldBe "two"
962668 liftIO $ writeChan setValueChan "three"
963− readRef valueByUIRef `shouldBeWithRetryM` "two"
964− readRef valueRef `shouldBeWithRetryM` "three"
669+ liftIO $ threadDelay 100000
670+ readRef valueByUIRef >>= flip shouldBe "two"
671+ readRef valueRef >>= flip shouldBe "three"
965672 testWidget (pure ()) checkValue $ do
966673 setValue' <- triggerEventWithChan setValueChan
967674 (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
968675 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
969676 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
970677
971− describe "hydration/immediate" $ do
678+ describe "hydration/immediate" $ session' $ do
972679 it "captures user input after switchover" $ runWD $ do
973680 inputRef :: IORef Text <- newRef ""
974681 let checkValue = do
975− WD.click <=< findElemWithRetry $ WD.ById "two"
976− WD.click <=< findElemWithRetry $ WD.ByTag "button"
977− readRef inputRef `shouldBeWithRetryM` "two"
682+ WD.click <=< WD.findElem $ WD.ById "two"
683+ WD.click <=< WD.findElem $ WD.ByTag "button"
684+ readRef inputRef >>= flip shouldBe "two"
978685 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
979686 (e, ()) <- selectElement def options
980687 click <- button "save"
@@ -982,16 +689,17 @@ tests withDebugging wdConfig caps _selenium = do
982689 it "sets focus appropriately" $ runWD $ do
983690 focusRef <- newRef False
984691 let checkValue = do
985− readRef focusRef `shouldBeWithRetryM` False
986− e <- findElemWithRetry $ WD.ByTag "select"
692+ readRef focusRef >>= flip shouldBe False
693+ e <- WD.findElem $ WD.ByTag "select"
987694 WD.click e
988− readRef focusRef `shouldBeWithRetryM` True
695+ liftIO $ threadDelay 100000
696+ readRef focusRef >>= flip shouldBe True
989697 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
990698 (e, ()) <- selectElement def options
991699 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
992700 it "has correct initial value" $ runWD $ do
993701 valueRef :: IORef Text <- newRef ""
994− let checkValue = readRef valueRef `shouldBeWithRetryM` "one"
702+ let checkValue = readRef valueRef >>= flip shouldBe "one"
995703 testWidget (pure ()) checkValue $ do
996704 prerender_ (pure ()) $ do
997705 (e, ()) <- selectElement def { _selectElementConfig_initialValue = "one" } options
@@ -1001,12 +709,14 @@ tests withDebugging wdConfig caps _selenium = do
1001709 valueRef :: IORef Text <- newRef ""
1002710 setValueChan :: Chan Text <- liftIO newChan
1003711 let checkValue = do
1004− WD.click =<< findElemWithRetry (WD.ById "two")
1005− readRef valueByUIRef `shouldBeWithRetryM` "two"
1006− readRef valueRef `shouldBeWithRetryM` "two"
712+ WD.click <=< WD.findElem $ WD.ById "two"
713+ liftIO $ threadDelay 100000
714+ readRef valueByUIRef >>= flip shouldBe "two"
715+ readRef valueRef >>= flip shouldBe "two"
1007716 liftIO $ writeChan setValueChan "three"
1008− readRef valueByUIRef `shouldBeWithRetryM` "two"
1009− readRef valueRef `shouldBeWithRetryM` "three"
717+ liftIO $ threadDelay 100000
718+ readRef valueByUIRef >>= flip shouldBe "two"
719+ readRef valueRef >>= flip shouldBe "three"
1010720 testWidget (pure ()) checkValue $ do
1011721 setValue' <- triggerEventWithChan setValueChan
1012722 prerender_ (pure ()) $ do
@@ -1014,12 +724,12 @@ tests withDebugging wdConfig caps _selenium = do
1014724 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
1015725 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
1016726
1017− session' "prerender" $ do
727+ describe "prerender" $ session' $ do
1018728 it "works in simple case" $ runWD $ do
1019729 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
1020730 prerender_ (text "One") (text "Two")
1021731 it "removes element correctly" $ runWD $ do
1022− testWidget' (findElemWithRetry $ WD.ByTag "span") elementShouldBeRemoved $ do
732+ testWidget' (WD.findElem $ WD.ByTag "span") elementShouldBeRemoved $ do
1023733 prerender_ (el "span" $ text "One") (text "Two")
1024734 it "can be nested in server widget" $ runWD $ do
1025735 testWidget (checkBodyText "One") (checkBodyText "Three") $ do
@@ -1037,15 +747,14 @@ tests withDebugging wdConfig caps _selenium = do
1037747 it "works inside other element" $ runWD $ do
1038748 testWidget (checkTextInTag "div" "One") (checkTextInTag "div" "Two") $ do
1039749 el "div" $ prerender_ (text "One") (text "Two")
1040−-- TODO re-enable this
1041−-- it "places fences and removes them" $ runWD $ do
1042−-- testWidget'
1043−-- (do
1044−-- scripts <- WD.findElems $ WD.ByTag "script"
1045−-- filterM (\s -> maybe False (\t -> "prerender" `T.isPrefixOf` t) <$> WD.attr s "type") scripts
1046−-- )
1047−-- (traverse_ elementShouldBeRemoved)
1048−-- (el "span" $ prerender_ (text "One") (text "Two"))
750+ it "places fences and removes them" $ runWD $ do
751+ testWidget'
752+ (do
753+ scripts <- WD.findElems $ WD.ByTag "script"
754+ filterM (\s -> maybe False (\t -> "prerender" `T.isPrefixOf` t) <$> WD.attr s "type") scripts
755+ )
756+ (traverse_ elementShouldBeRemoved)
757+ (el "span" $ prerender_ (text "One") (text "Two"))
1049758 it "postBuild works on server side" $ runWD $ do
1050759 lock :: MVar () <- liftIO newEmptyMVar
1051760 testWidget (liftIO $ takeMVar lock) (pure ()) $ do
@@ -1059,9 +768,9 @@ tests withDebugging wdConfig caps _selenium = do
1059768 pb <- getPostBuild
1060769 performEvent_ $ liftIO (putMVar lock ()) <$ pb
1061770 it "result Dynamic is updated *after* switchover" $ runWD $ do
1062− let preSwitchover = checkBodyText "PostBuild"
1063− check = checkBodyText "Client"
1064− testWidget preSwitchover check $ void $ do
771+ let static = shouldContainText "PostBuild" =<< WD.findElem (WD.ByTag "body")
772+ check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
773+ testWidget static check $ void $ do
1065774 d <- prerender (pure "Initial") (pure "Client")
1066775 pb <- getPostBuild
1067776 initial <- sample $ current d
@@ -1069,39 +778,32 @@ tests withDebugging wdConfig caps _selenium = do
1069778 -- This essentially checks that the client IO runs *after* switchover/postBuild,
1070779 -- thus can't create conflicting DOM
1071780 it "can't exploit IO to break hydration" $ runWD $ do
1072− let preSwitchover = checkBodyText "Initial"
1073− testWidgetStatic preSwitchover $ void $ do
781+ let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
782+ testWidgetStatic static $ void $ do
1074783 ref <- liftIO $ newRef "Initial"
1075784 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
1076785 text <=< liftIO $ readRef ref
1077786 -- As above, so below
1078787 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
788+ let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
789+ check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
790+ testWidget static check $ void $ do
1082791 (e, trigger) <- newTriggerEvent
1083792 prerender_ (pure ()) (liftIO $ trigger "Client")
1084793 textNode $ TextNodeConfig "Initial" $ Just e
1085794
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
795+ describe "runWithReplace" $ session' $ do
1096796 it "works" $ runWD $ do
1097797 replaceChan :: Chan Text <- liftIO newChan
1098− let setup = findElemWithRetry $ WD.ByTag "div"
798+ let setup = WD.findElem $ WD.ByTag "div"
1099799 check ssr = do
1100800 -- Check that the original element still exists and has the correct text
1101− shouldContainText "two" ssr
1102− liftIO $ writeChan replaceChan "three"
801+ WD.getText ssr >>= flip shouldBe "two"
802+ liftIO $ do
803+ writeChan replaceChan "three"
804+ threadDelay 100000
1103805 elementShouldBeRemoved ssr
1104− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
806+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1105807 testWidget' setup check $ do
1106808 replace <- triggerEventWithChan replaceChan
1107809 pb <- getPostBuild
@@ -1111,13 +813,15 @@ tests withDebugging wdConfig caps _selenium = do
1111813 ]
1112814 it "can be nested in initial widget" $ runWD $ do
1113815 replaceChan :: Chan Text <- liftIO newChan
1114− let setup = findElemWithRetry $ WD.ByTag "div"
816+ let setup = WD.findElem $ WD.ByTag "div"
1115817 check ssr = do
1116818 -- Check that the original element still exists and has the correct text
1117− shouldContainText "two" ssr
1118− liftIO $ writeChan replaceChan "three"
819+ WD.getText ssr >>= flip shouldBe "two"
820+ liftIO $ do
821+ writeChan replaceChan "three"
822+ threadDelay 100000
1119823 elementShouldBeRemoved ssr
1120− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
824+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1121825 testWidget' setup check $ void $ flip runWithReplace never $ do
1122826 replace <- triggerEventWithChan replaceChan
1123827 pb <- getPostBuild
@@ -1126,14 +830,16 @@ tests withDebugging wdConfig caps _selenium = do
1126830 , el "span" . text <$> replace
1127831 ]
1128832 it "can be nested in postBuild widget" $ runWD $ do
1129− replaceChan :: Chan Text <- liftIO newChan
1130− let setup = findElemWithRetry $ WD.ByTag "div"
833+ replaceChan <- liftIO newChan
834+ let setup = WD.findElem $ WD.ByTag "div"
1131835 check ssr = do
1132836 -- Check that the original element still exists and has the correct text
1133− shouldContainText "two" ssr
1134− liftIO $ writeChan replaceChan "three"
837+ WD.getText ssr >>= flip shouldBe "two"
838+ liftIO $ do
839+ writeChan replaceChan "three"
840+ threadDelay 100000
1135841 elementShouldBeRemoved ssr
1136− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
842+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1137843 testWidget' setup check $ void $ do
1138844 pb <- getPostBuild
1139845 runWithReplace (pure ()) $ ffor pb $ \() -> do
@@ -1159,15 +865,17 @@ tests withDebugging wdConfig caps _selenium = do
1159865 replaceChan2 :: Chan Text <- liftIO newChan
1160866 lock :: MVar () <- liftIO newEmptyMVar
1161867 let check = do
1162− shouldContainText "" =<< findElemWithRetry (WD.ByTag "body")
868+ shouldContainText "" =<< WD.findElem (WD.ByTag "body")
1163869 liftIO $ do
1164870 writeChan replaceChan1 "one"
1165871 takeMVar lock
1166− one <- findElemWithRetry $ WD.ByTag "div"
1167− shouldContainText "pb" one
1168− liftIO $ writeChan replaceChan2 "two"
872+ one <- WD.findElem $ WD.ByTag "div"
873+ WD.getText one >>= flip shouldBe "pb"
874+ liftIO $ do
875+ writeChan replaceChan2 "two"
876+ threadDelay 100000
1169877 elementShouldBeRemoved one
1170− shouldContainText "two" =<< findElemWithRetry (WD.ByTag "span")
878+ shouldContainText "two" =<< WD.findElem (WD.ByTag "span")
1171879 testWidget (pure ()) check $ void $ do
1172880 replace1 <- triggerEventWithChan replaceChan1
1173881 runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
@@ -1208,12 +916,14 @@ tests withDebugging wdConfig caps _selenium = do
1208916 it "works in immediate mode (RHS of prerender)" $ runWD $ do
1209917 replaceChan :: Chan Text <- liftIO newChan
1210918 let check = do
1211− checkBodyText "one"
1212− one <- findElemWithRetry $ WD.ByTag "div"
1213− shouldContainText "one" one
1214− liftIO $ writeChan replaceChan "pb"
919+ one <- WD.findElem $ WD.ByTag "div"
920+ shouldContainText "one" =<< WD.findElem (WD.ByTag "body")
921+ WD.getText one >>= flip shouldBe "one"
922+ liftIO $ do
923+ writeChan replaceChan "pb"
924+ threadDelay 100000
1215925 elementShouldBeRemoved one
1216− shouldContainText "pb" =<< findElemWithRetry (WD.ByTag "span")
926+ shouldContainText "pb" =<< WD.findElem (WD.ByTag "span")
1217927 testWidget (pure ()) check $ void $ do
1218928 replace <- triggerEventWithChan replaceChan
1219929 prerender_ blank $ do
@@ -1221,12 +931,14 @@ tests withDebugging wdConfig caps _selenium = do
1221931 it "works with postBuild in immediate mode (RHS of prerender)" $ runWD $ do
1222932 replaceChan :: Chan Text <- liftIO newChan
1223933 let check = do
1224− checkBodyText "two"
1225− two <- findElemWithRetry $ WD.ByTag "div"
1226− shouldContainText "two" two
1227− liftIO $ writeChan replaceChan "three"
934+ two <- WD.findElem $ WD.ByTag "div"
935+ shouldContainText "two" =<< WD.findElem (WD.ByTag "body")
936+ WD.getText two >>= flip shouldBe "two"
937+ liftIO $ do
938+ writeChan replaceChan "three"
939+ threadDelay 100000
1228940 elementShouldBeRemoved two
1229− shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
941+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
1230942 testWidget (pure ()) check $ void $ do
1231943 replace <- triggerEventWithChan replaceChan
1232944 prerender_ blank $ do
@@ -1236,61 +948,7 @@ tests withDebugging wdConfig caps _selenium = do
1236948 , el "span" . text <$> replace
1237949 ]
1238950
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
951+ describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1294952 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
1295953 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1296954 elClass "span" "key" $ text $ textKey k
@@ -1298,58 +956,58 @@ tests withDebugging wdConfig caps _selenium = do
1298956 pure (Identity v)
1299957 checkItem :: WD.Element -> Text -> Text -> WD ()
1300958 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")
959+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
960+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1304961 checkInitialItems dm xs = do
1305− putStrLnDebug "checkInitialItems"
1306962 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1307963 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"
964+ getAndCheckInitialItems dm = do
1310965 xs <- WD.findElems (WD.ByTag "li")
1311966 checkInitialItems dm xs
1312967 pure xs
1313968 checkRemoval chan k = do
1314− putStrLnDebug "checkRemoval"
1315− e <- findElemWithRetry (WD.ById $ textKey k)
1316− liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
969+ e <- WD.findElem (WD.ById $ textKey k)
970+ liftIO $ do
971+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
972+ threadDelay 100000
1317973 elementShouldBeRemoved e
1318974 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)
975+ e <- WD.findElem (WD.ById $ textKey k)
976+ liftIO $ do
977+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
978+ threadDelay 100000
1322979 elementShouldBeRemoved e
1323− e' <- findElemWithRetry $ WD.ById $ textKey k
980+ e' <- WD.findElem (WD.ById $ textKey k)
1324981 checkItem e' (textKey k) (T.pack $ show v)
1325982 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)
983+ liftIO $ do
984+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
985+ threadDelay 100000
986+ e <- WD.findElem (WD.ById $ textKey k)
1329987 checkItem e (textKey k) (T.pack $ show v)
1330988 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
1331989 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1332990 chan <- liftIO newChan
1333− let preSwitchover :: WD [WD.Element]
1334− preSwitchover = getAndCheckInitialItems keyMap
991+ let static :: WD [WD.Element]
992+ static = getAndCheckInitialItems keyMap
1335993 check :: [WD.Element] -> WD ()
1336994 check xs = do
1337995 checkInitialItems keyMap xs
1338996 checkRemoval chan Key_Int
1339997 checkReplace chan Key_Char 'B'
1340998 checkInsert chan Key_Bool True
1341− testWidget' preSwitchover check $ do
999+ testWidget' static check $ do
13421000 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
13431001 liftIO $ dmap `H.shouldBe` keyMap
13441002 it "handles postBuild correctly" $ runWD $ do
13451003 chan <- liftIO newChan
1346− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1004+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
13471005 check xs = do
1348− withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1006+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch keyMap) xs
13491007 checkRemoval chan Key_Int
13501008 checkInsert chan Key_Char 'B'
13511009 checkReplace chan Key_Bool True
1352− testWidget' preSwitchover check $ void $ do
1010+ testWidget' static check $ void $ do
13531011 pb <- getPostBuild
13541012 replace <- triggerEventWithChan chan
13551013 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1382,7 +1040,7 @@ tests withDebugging wdConfig caps _selenium = do
13821040 it "handles postBuild correctly in prerender" $ runWD $ do
13831041 chan <- liftIO newChan
13841042 let check = do
1385− _ <- getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1043+ _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
13861044 checkRemoval chan Key_Int
13871045 checkInsert chan Key_Char 'B'
13881046 checkReplace chan Key_Bool True
@@ -1393,7 +1051,7 @@ tests withDebugging wdConfig caps _selenium = do
13931051 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
13941052 liftIO $ dmap `H.shouldBe` keyMap
13951053
1396− session' "traverseIntMapWithKeyWithAdjust" $ do
1054+ describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
13971055 let textKeyInt k = "key" <> T.pack (show k)
13981056 intMap = IntMap.fromList
13991057 [ (1, "one")
@@ -1407,89 +1065,89 @@ tests withDebugging wdConfig caps _selenium = do
14071065 pure v
14081066 checkItem :: WD.Element -> Text -> Text -> WD ()
14091067 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")
1068+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1069+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
14131070 checkInitialItems dm xs = do
1414− putStrLnDebug "checkInitialItems"
14151071 liftIO $ assertEqual "Wrong amount of items in DOM" (IntMap.size dm) (length xs)
14161072 forM_ (zip xs (IntMap.toList dm)) $ \(e, (k, v)) -> checkItem e (textKeyInt k) v
1417− getAndCheckInitialItems dm = withRetry $ do
1418− putStrLnDebug "getAndCheckInitialItems"
1073+ getAndCheckInitialItems dm = do
14191074 xs <- WD.findElems (WD.ByTag "li")
14201075 checkInitialItems dm xs
14211076 pure xs
14221077 checkRemoval chan k = do
1423− putStrLnDebug "checkRemoval"
1424− e <- findElemWithRetry (WD.ById $ textKeyInt k)
1425− liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1078+ e <- WD.findElem (WD.ById $ textKeyInt k)
1079+ liftIO $ do
1080+ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1081+ threadDelay 100000
14261082 elementShouldBeRemoved e
14271083 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
1084+ e <- WD.findElem (WD.ById $ textKeyInt k)
1085+ liftIO $ do
1086+ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1087+ threadDelay 100000
14311088 elementShouldBeRemoved e
1432− e' <- findElemWithRetry (WD.ById $ textKeyInt k)
1433− withRetry $ checkItem e' (textKeyInt k) v
1089+ e' <- WD.findElem (WD.ById $ textKeyInt k)
1090+ checkItem e' (textKeyInt k) v
14341091 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)
1092+ liftIO $ do
1093+ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1094+ threadDelay 100000
1095+ e <- WD.findElem (WD.ById $ textKeyInt k)
14381096 checkItem e (textKeyInt k) v
14391097 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
1098+ it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
14411099 chan <- liftIO newChan
1442− let preSwitchover = getAndCheckInitialItems intMap
1100+ let static = getAndCheckInitialItems intMap
14431101 check xs = do
14441102 checkInitialItems intMap xs
14451103 checkRemoval chan 1
14461104 checkReplace chan 2 "deux"
14471105 checkInsert chan 4 "four"
1448− testWidget' preSwitchover check $ void $ do
1106+ testWidget' static check $ void $ do
14491107 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
14501108 liftIO $ im `H.shouldBe` intMap
1451− xit "handles postBuild correctly" $ runWD $ do
1109+ it "handles postBuild correctly" $ runWD $ do
14521110 chan <- liftIO newChan
1453− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1111+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
14541112 check xs = do
1455− withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1113+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch intMap) xs
14561114 checkRemoval chan 1
14571115 checkInsert chan 2 "deux"
14581116 checkReplace chan 3 "trois"
1459− testWidget' preSwitchover check $ void $ do
1117+ testWidget' static check $ void $ do
14601118 pb <- getPostBuild
14611119 replace <- triggerEventWithChan chan
14621120 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
14631121 liftIO $ dmap `H.shouldBe` intMap
1464− xit "can delete/update/insert when built in prerender" $ runWD $ do
1122+ it "can delete/update/insert when built in prerender" $ runWD $ do
14651123 chan <- liftIO newChan
14661124 let check = do
14671125 _ <- getAndCheckInitialItems intMap
14681126 checkRemoval chan 1
14691127 checkReplace chan 2 "deux"
1470− checkInsert chan 4 "quatre"
1128+ checkInsert chan 3 "trois"
14711129 testWidget (pure ()) check $ do
14721130 replace <- triggerEventWithChan chan
14731131 prerender_ (pure ()) $ do
14741132 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap replace
14751133 liftIO $ dmap `H.shouldBe` intMap
1476− xit "can delete/update/insert when built in immediate mode" $ runWD $ do
1134+ it "can delete/update/insert when built in immediate mode" $ runWD $ do
14771135 chan <- liftIO newChan
14781136 let check = do
14791137 _ <- getAndCheckInitialItems intMap
14801138 checkRemoval chan 1
14811139 checkReplace chan 2 "deux"
1482− checkInsert chan 4 "quatre"
1140+ checkInsert chan 3 "trois"
14831141 testWidget (pure ()) check $ void $ do
14841142 pb <- getPostBuild
14851143 runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
14861144 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
14871145 liftIO $ dmap `H.shouldBe` intMap
14881146 -- Should be fixed by prerender changes!
1489− xit "handles postBuild correctly in prerender" $ runWD $ do
1147+ it "handles postBuild correctly in prerender" $ runWD $ do
14901148 chan <- liftIO newChan
14911149 let check = do
1492− _ <- getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1150+ _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
14931151 checkRemoval chan 1
14941152 checkInsert chan 2 "deux"
14951153 checkReplace chan 3 "trois"
@@ -1500,30 +1158,47 @@ tests withDebugging wdConfig caps _selenium = do
15001158 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
15011159 liftIO $ dmap `H.shouldBe` intMap
15021160
1503− session' "traverseDMapWithKeyWithAdjustWithMove" $ do
1161+ describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
15041162 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
1163+ widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1164+ elClass "span" "key" $ text $ textKey k
15071165 elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
15081166 pure (Identity v)
1509− textKey2 :: Key2 a -> Text
1510− textKey2 = \case
1167+ textKey :: Key2 a -> Text
1168+ textKey = \case
15111169 Key2_Int i -> "i" <> T.pack (show i)
15121170 Key2_Char c -> "c" <> T.pack [c]
15131171 checkItem :: WD.Element -> Text -> Text -> WD ()
15141172 checkItem li k v = do
1515− shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1516− shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
1173+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1174+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
15171175 checkInitialItems dm xs = do
15181176 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
1177+ forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
1178+ getAndCheckInitialItems dm = do
15211179 xs <- WD.findElems (WD.ByTag "li")
15221180 checkInitialItems dm xs
15231181 pure xs
1524− moveSpec
1525− :: (DMap Key2 Identity -> (WD.Element -> Chan (PatchDMapWithMove Key2 Identity) -> WD ()) -> WD ())
1526− -> H.SpecM (WdTestSession ()) ()
1182+ checkRemoval chan k = do
1183+ e <- WD.findElem (WD.ById $ textKey k)
1184+ liftIO $ do
1185+ writeChan chan $ deleteDMapKey k
1186+ threadDelay 100000
1187+ elementShouldBeRemoved e
1188+ checkReplace chan k v = do
1189+ e <- WD.findElem (WD.ById $ textKey k)
1190+ liftIO $ do
1191+ writeChan chan $ insertDMapKey k (Identity v)
1192+ threadDelay 100000
1193+ elementShouldBeRemoved e
1194+ e' <- WD.findElem (WD.ById $ textKey k)
1195+ checkItem e' (textKey k) (T.pack $ show v)
1196+ checkInsert chan k v = do
1197+ liftIO $ do
1198+ writeChan chan $ insertDMapKey k (Identity v)
1199+ threadDelay 100000
1200+ e <- WD.findElem (WD.ById $ textKey k)
1201+ checkItem e (textKey k) (T.pack $ show v)
15271202 moveSpec testMove = do
15281203 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
15291204 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
@@ -1537,40 +1212,39 @@ tests withDebugging wdConfig caps _selenium = do
15371212 shouldContainText (T.strip $ T.unlines ["i11","i22","i33","i44"]) body
15381213 liftIO $ writeChan chan (swapDMapKey (Key2_Int 2) (Key2_Int 3))
15391214 shouldContainText (T.strip $ T.unlines ["i11","i33","i22","i44"]) body
1540−-- TODO re-enable this
1541−-- it "can move items" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3, Key2_Int 4 ==> 4]) $ \body chan -> do
1542−-- shouldContainText (T.strip $ T.unlines ["i11","i22","i33", "i44"]) body
1543−-- liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3))
1544−-- shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
1545−-- liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- attempt a move to nonexistent key should delete
1546−-- shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
1547−-- liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- this causes a JSException in immediate builder too
1548−-- shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
1549−-- liftIO $ writeChan chan (insertDMapKey (Key2_Int 2) 2) -- this step will fail if the above caused an exception, thus works as a proxy for detecting the exception given we can't catch it
1550−-- shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
1215+ it "can move items" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3, Key2_Int 4 ==> 4]) $ \body chan -> do
1216+ shouldContainText (T.strip $ T.unlines ["i11","i22","i33", "i44"]) body
1217+ liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3))
1218+ shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
1219+ liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- attempt a move to nonexistent key should delete
1220+ shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
1221+ liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- this causes a JSException in immediate builder too
1222+ shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
1223+ liftIO $ writeChan chan (insertDMapKey (Key2_Int 2) 2) -- this step will fail if the above caused an exception, thus works as a proxy for detecting the exception given we can't catch it
1224+ shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
15511225
15521226 describe "hydration" $ moveSpec $ \initMap test -> do
15531227 chan <- liftIO newChan
1554− let preSwitchover = getAndCheckInitialItems initMap
1228+ let static = getAndCheckInitialItems initMap
15551229 check xs = do
15561230 checkInitialItems initMap xs
1557− body <- getBody
1231+ body <- WD.findElem (WD.ByTag "body")
15581232 test body chan
1559− testWidget' preSwitchover check $ void $ do
1233+ testWidget' static check $ void $ do
15601234 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
15611235 liftIO $ assertEqual "DMap" initMap dmap
15621236
15631237 describe "hydration/immediate" $ moveSpec $ \initMap test -> do
15641238 chan <- liftIO newChan
15651239 replace <- liftIO newChan
1566− lock :: MVar () <- liftIO newEmptyMVar
1240+ lock <- liftIO newEmptyMVar
15671241 let check = do
15681242 liftIO $ do
15691243 writeChan replace ()
15701244 takeMVar lock
15711245 xs <- getAndCheckInitialItems initMap
15721246 checkInitialItems initMap xs
1573− body <- getBody
1247+ body <- WD.findElem (WD.ByTag "body")
15741248 test body chan
15751249 testWidget (pure ()) check $ void $ do
15761250 e <- triggerEventWithChan replace
@@ -1580,56 +1254,6 @@ tests withDebugging wdConfig caps _selenium = do
15801254 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
15811255 liftIO $ assertEqual "DMap" initMap dmap
15821256
1583− session' "hydrating invalid HTML" $ do
1584− xit "can hydrate list in paragraph" $ runWD $ do
1585− let preSwitchover = do
1586− checkBodyText "before\ninner\nafter"
1587− -- 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")
1592− shouldContainText "before" p1
1593− shouldContainText "inner" ol
1594− shouldContainText "" p2
1595− pure (p1, ol, p2)
1596− check (p1, ol, p2) = do
1597− checkBodyText "before\ninner\nafter"
1598− shouldContainText "before\ninner\nafter" p1
1599− elementShouldBeRemoved ol
1600− elementShouldBeRemoved p2
1601− -- Don't fail fatally when hydration encounters the invalid DOM
1602− testWidgetDebug' False withDebugging preSwitchover check $ do
1603− -- This is deliberately invalid HTML, the browser will interpret it as
1604− -- <p>before</p><ol>inner</ol>after<p></p>
1605− el "p" $ do
1606− text "before"
1607− el "ol" $ text "inner"
1608− text "after"
1609−
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−
16331257data Selenium = Selenium
16341258 { _selenium_portNumber :: PortNumber
16351259 , _selenium_stopServer :: IO ()
@@ -1646,177 +1270,136 @@ startSeleniumServer port = do
16461270
16471271withSeleniumServer :: (Selenium -> IO ()) -> IO ()
16481272withSeleniumServer f = do
1649− stopServer <- startSeleniumServer seleniumPort
1273+ port <- getFreePort
1274+ stopServer <- startSeleniumServer port
16501275 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
16511276 f $ Selenium
1652− { _selenium_portNumber = seleniumPort
1277+ { _selenium_portNumber = port
16531278 , _selenium_stopServer = stopServer
16541279 }
16551280
1656−triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender js t m) => Chan a -> m (Event t a)
1281+triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender t m) => Chan a -> m (Event t a)
16571282triggerEventWithChan chan = do
16581283 (e, trigger) <- newTriggerEvent
16591284 -- In prerender because we only want to do this on the client
16601285 prerender_ (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
16611286 pure e
16621287
1663−shouldBeWithRetryM :: (Eq a, Show a) => WD a -> a -> WD ()
1664−shouldBeWithRetryM m expected = withRetry $ do
1665− got <- m
1666− got `shouldBe` expected
1667−
16681288assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
16691289assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
16701290
16711291elementShouldBeRemoved :: WD.Element -> WD ()
1672−elementShouldBeRemoved e = withRetry $ do
1292+elementShouldBeRemoved e = do
16731293 try (WD.getText e) >>= \case
16741294 Left (WD.FailedCommand WD.StaleElementReference _) -> return ()
16751295 Left err -> throwM err
16761296 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
16771297
16781298shouldContainText :: 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
1299+shouldContainText t = flip shouldBe t <=< WD.getText
16831300
16841301checkBodyText :: Text -> WD ()
16851302checkBodyText = checkTextInTag "body"
16861303
16871304checkTextInTag :: Text -> Text -> WD ()
1688−checkTextInTag t expected = do
1689− e <- findElemWithRetry (WD.ByTag t)
1690− shouldContainText expected e
1305+checkTextInTag t expected = WD.findElem (WD.ByTag t) >>= shouldContainText expected
16911306
16921307checkTextInId :: 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
1308+checkTextInId i expected = WD.findElem (WD.ById i) >>= shouldContainText expected
17151309
17161310divId :: DomBuilder t m => Text -> m a -> m a
17171311divId i = elAttr "div" ("id" =: i)
17181312
1719−type 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)
1313+type TestWidget n t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender t m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadIO m)
17201314
1721−testWidgetStaticDebug
1722− :: Bool
1723− -> WD b
1315+testWidgetStatic
1316+ :: WD b
17241317 -- ^ Webdriver commands to run before JS runs and after hydration switchover
17251318 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17261319 -- ^ Widget we are testing
17271320 -> WD b
1728−testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
1321+testWidgetStatic w = testWidget (void w) w
17291322
17301323-- | TODO: do something about JSExceptions not causing tests to fail
1731−testWidgetDebug
1732− :: Bool
1733− -> Bool
1734− -> WD ()
1324+testWidget
1325+ :: WD ()
17351326 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
17361327 -> WD b
17371328 -- ^ Webdriver commands to run after hydration switchover
17381329 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17391330 -- ^ Widget we are testing
17401331 -> 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
1332+testWidget beforeJS afterSwitchover = testWidget' beforeJS (const afterSwitchover)
17461333
17471334-- | TODO: do something about JSExceptions not causing tests to fail
1748−testWidgetDebug'
1749− :: Bool
1750− -> Bool
1751− -> WD a
1335+testWidget'
1336+ :: WD a
17521337 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
17531338 -> (a -> WD b)
17541339 -- ^ Webdriver commands to run after hydration switchover
17551340 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17561341 -- ^ Widget we are testing (contents of body)
17571342 -> 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
1343+testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out") pure <=< timeout testTimeLimit $ do
1344+ let staticApp = do
17621345 el "head" $ pure ()
17631346 el "body" $ do
17641347 bodyWidget
17651348 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1766− putStrLnDebug "rendering static"
1767− ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1768− putStrLnDebug "rendered static"
1349+ ((), html) <- liftIO $ renderStatic staticApp
17691350 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1770− onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
17711351 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
17721352 let entryPoint = do
1773− putStrLnDebug "taking waitBeforeJS"
17741353 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"
1354+ mainHydrationWidgetWithSwitchoverAction (putMVar waitUntilSwitchover ()) (pure ()) bodyWidget
17841355 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
1356+ application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse ->
1357+ sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1358+ port <- getFreePort
17901359 waitJSaddle <- liftIO newEmptyMVar
17911360 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"
1361+ [ Warp.setPort $ fromIntegral (toInteger port)
1362+ , Warp.setBeforeMainLoop $ putMVar waitJSaddle ()
17971363 ]
17981364 -- 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
1365+ jsaddleWarp = forkIO $ hSilence [stderr] $ Warp.runSettings settings application
1366+ jsaddleTid <- liftIO jsaddleWarp
1367+ liftIO $ takeMVar waitJSaddle
1368+ WD.openPage $ "http://localhost:" <> show port
1369+ a <- beforeJS
1370+ liftIO $ putMVar waitBeforeJS ()
1371+ liftIO $ takeMVar waitUntilSwitchover
1372+ liftIO $ threadDelay 100000 -- wait a bit
1373+ b <- afterSwitchover a
1374+ liftIO $ killThread jsaddleTid
1375+ return b
1376+
18141377
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)
1378+-- TODO: Should this be part of more widely used module?
1379+-- TODO: Ensure port is not taken
1380+getFreePort :: MonadIO m => m PortNumber
1381+getFreePort = liftIO $ withSocketsDo $ do
1382+ addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
1383+ bracket (open addr) close socketPort
1384+ where
1385+ open addr = do
1386+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
1387+ bind sock (addrAddress addr)
1388+ return sock
1389+
1390+testWidgetDebug :: MonadIO n => (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> n ()
1391+testWidgetDebug bodyWidget = liftIO $ do
1392+ let staticApp = do
1393+ el "head" $ pure ()
1394+ el "body" $ do
1395+ bodyWidget
1396+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1397+ ((), html) <- renderStatic staticApp
1398+ let entryPoint = do
1399+ mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) bodyWidget
1400+ syncPoint
1401+ application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1402+ Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application
18201403
18211404data Key2 a where
18221405 Key2_Int :: Int -> Key2 Int
@@ -1825,4 +1408,18 @@ data Key2 a where
18251408deriveGEq ''Key2
18261409deriveGCompare ''Key2
18271410deriveGShow ''Key2
1828−deriveArgDict ''Key2
1411+
1412+instance ShowTag Key2 Identity where
1413+ showTaggedPrec = \case
1414+ Key2_Int _ -> showsPrec
1415+ Key2_Char _ -> showsPrec
1416+
1417+instance EqTag Key2 Identity where
1418+ eqTagged (Key2_Int _) (Key2_Int _) = (==)
1419+ eqTagged (Key2_Char _) (Key2_Char _) = (==)
1420+
1421+instance ArgDict Key2 where
1422+ type ConstraintsFor Key2 c = (c Int, c Char)
1423+ argDict = \case
1424+ Key2_Int _ -> Dict
1425+ Key2_Char _ -> Dict