@@ -1,9 +1,13 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
12{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE StandaloneDeriving #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE UndecidableInstances #-}
26{-# LANGUAGE ConstraintKinds #-}
7+{-# LANGUAGE CPP #-}
38{-# LANGUAGE FlexibleContexts #-}
49{-# LANGUAGE FlexibleInstances #-}
510{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
711{-# LANGUAGE LambdaCase #-}
812{-# LANGUAGE MultiParamTypeClasses #-}
913{-# LANGUAGE OverloadedStrings #-}
@@ -11,43 +15,26 @@
1115{-# LANGUAGE RankNTypes #-}
1216{-# LANGUAGE RecursiveDo #-}
1317{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE StandaloneDeriving #-}
1518{-# LANGUAGE TemplateHaskell #-}
1619{-# LANGUAGE TupleSections #-}
1720{-# LANGUAGE TypeApplications #-}
1821{-# LANGUAGE TypeFamilies #-}
19−{-# LANGUAGE UndecidableInstances #-}
20−
21−{-# OPTIONS_GHC -fno-warn-orphans #-}
2222
23−-- Notice to those working on this test suite:
24−-- It doesn't appear to be possible to use --match to run a particular test, in
25−-- this situation the test may hang before reaching our code. This seems to
26−-- happen when the test is not the first test in the block. As a workaround, you
27−-- can just comment out the other tests. Also, using `xit` will cause the same
28−-- issue. `xit` tests must be the last tests in the session, or the session will
29−-- hang in the following test.
30−
31−import Prelude hiding (fail)
3223import Control.Concurrent
33−import qualified Control.Concurrent.Async as Async
34−import Control.Lens.Operators
35−import Control.Monad hiding (fail)
24+import Control.Monad
3625import Control.Monad.Catch
37−import Control.Monad.Fail
3826import Control.Monad.Fix
3927import Control.Monad.IO.Class
4028import Control.Monad.Ref
4129import Data.Constraint.Extras
4230import Data.Constraint.Extras.TH
4331import Data.Dependent.Map (DMap)
44−import Data.Dependent.Sum (DSum(..), (==>))
32+import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
4533import Data.Functor.Identity
4634import Data.Functor.Misc
4735import Data.GADT.Compare.TH
4836import Data.GADT.Show.TH
4937import Data.IORef (IORef)
50−import Data.List (sort)
5138import Data.Maybe
5239import Data.Proxy
5340import Data.Text (Text)
@@ -58,7 +45,6 @@ import Network.Socket
5845import Network.Wai
5946import Network.WebSockets
6047import Reflex.Dom.Core
61−import Reflex.Dom.Widget.Input (dropdown)
6248import Reflex.Patch.DMapWithMove
6349import System.Directory
6450import System.Environment
@@ -66,8 +52,7 @@ import System.IO (stderr)
6652import System.IO.Silently
6753import System.IO.Temp
6854import System.Process
69−import System.Which (staticWhich)
70−import qualified Test.HUnit as HUnit
55+import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
7156import qualified Test.Hspec as H
7257import qualified Test.Hspec.Core.Spec as H
7358import Test.Hspec (xit)
@@ -89,12 +74,6 @@ import qualified Test.WebDriver.Capabilities as WD
8974import Test.Util.ChromeFlags
9075import Test.Util.UnshareNetwork
9176
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−
9877seleniumPort, jsaddlePort :: PortNumber
9978seleniumPort = 8000
10079jsaddlePort = 8001
@@ -107,14 +86,11 @@ instance MonadRef WD where
10786 writeRef r = WD . writeRef r
10887
10988assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
110−assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
89+assertEqual a b = liftIO . HUnit.assertEqual a b
11190
11291assertFailure :: MonadIO m => String -> m ()
11392assertFailure = liftIO . HUnit.assertFailure
11493
115−assertBool :: (MonadIO m) => String -> Bool -> m ()
116−assertBool msg bool = liftIO $ HUnit.assertBool msg bool
117−
11894chromeConfig :: Text -> [Text] -> WD.WDConfig
11995chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
12096
@@ -141,26 +117,24 @@ deriveGEq ''DKey
141117deriveGCompare ''DKey
142118deriveGShow ''DKey
143119
144−deriving instance MonadFail WD
145−
146120main :: IO ()
147121main = do
148− unshareNetwork
122+ unshareNetork
149123 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
150124 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
151125 withSeleniumServer $ \selenium -> do
152− let browserPath = T.strip $ T.pack chromium
126+ browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
153127 when (T.null browserPath) $ fail "No browser found"
154128 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
155129 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
156130 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
157− hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
131+ hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
158132
159−tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
133+tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
160134tests withDebugging wdConfig caps _selenium = do
161135 let putStrLnDebug :: MonadIO m => Text -> m ()
162136 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
163− session' t = sessionWith wdConfig t . using caps
137+ session' = sessionWith wdConfig "" . using (map (,"") caps)
164138 runWD m = runWDOptions (WdOptions False) $ do
165139 putStrLnDebug "before"
166140 r <- m
@@ -169,10 +143,10 @@ tests withDebugging wdConfig caps _selenium = do
169143 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
170144 testWidgetStatic = testWidgetStaticDebug withDebugging
171145 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
172− testWidget = testWidgetDebug True withDebugging
146+ testWidget = testWidgetDebug withDebugging
173147 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
148+ testWidget' = testWidgetDebug' withDebugging
149+ describe "text" $ session' $ do
176150 it "works" $ runWD $ do
177151 testWidgetStatic (checkBodyText "hello world") $ do
178152 text "hello world"
@@ -233,7 +207,7 @@ tests withDebugging wdConfig caps _selenium = do
233207 click <- button ""
234208 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
235209
236− session' "element" $ do
210+ describe "element" $ session' $ do
237211 it "works with domEvent Click" $ runWD $ do
238212 clickedRef <- liftIO $ newRef False
239213 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
@@ -296,79 +270,29 @@ tests withDebugging wdConfig caps _selenium = do
296270 (e, ()) <- element "div" conf $ text "hello world"
297271 let click = domEvent Click e
298272 return ()
273+ -- TODO check this is the correct solution
274+ it "has ssr attribute, removes ssr attribute" $ runWD $ do
275+ let checkSSRAttr = do
276+ e <- findElemWithRetry $ WD.ByTag "div"
277+ assertAttr e "data-ssr" (Just "")
278+ pure e
279+ testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world"
299280
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
281+ describe "inputElement" $ do
282+ describe "hydration" $ session' $ do
359283 it "doesn't wipe user input when switching over" $ runWD $ do
360− inputRef <- newRef ("hello " :: Text)
284+ inputRef <- newRef ("" :: Text)
361285 testWidget'
362286 (do
363287 e <- findElemWithRetry $ WD.ByTag "input"
364− WD.sendKeys "world" e
288+ WD.sendKeys "hello world" e
365289 pure e)
366290 (\e -> do
367291 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
368292 WD.click =<< findElemWithRetry (WD.ByTag "button")
369293 readRef inputRef `shouldBeWithRetryM` "hello world"
370294 ) $ do
371− e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
295+ e <- inputElement def
372296 click <- button "save"
373297 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
374298 it "captures user input after switchover" $ runWD $ do
@@ -425,49 +349,24 @@ tests withDebugging wdConfig caps _selenium = do
425349 checkedByUIRef <- newRef False
426350 checkedRef <- newRef False
427351 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
352+ let checkValue = do
433353 readRef checkedByUIRef `shouldBeWithRetryM` False
434354 readRef checkedRef `shouldBeWithRetryM` False
435− WD.attr e "checked" `shouldBeWithRetryM` Nothing
355+ e <- findElemWithRetry $ WD.ByTag "input"
436356 WD.moveToCenter e
437357 WD.click e
438358 readRef checkedByUIRef `shouldBeWithRetryM` True
439359 readRef checkedRef `shouldBeWithRetryM` True
440− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
441360 liftIO $ writeChan setCheckedChan False
442361 readRef checkedByUIRef `shouldBeWithRetryM` True
443362 readRef checkedRef `shouldBeWithRetryM` False
444− WD.attr e "checked" `shouldBeWithRetryM` Nothing
445− testWidget' checkStatic checkValue $ do
363+ testWidget (pure ()) checkValue $ do
446364 setChecked <- triggerEventWithChan setCheckedChan
447365 e <- inputElement $ def
448366 & initialAttributes .~ "type" =: "checkbox"
449367 & inputElementConfig_setChecked .~ setChecked
450368 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
451369 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
452− it "respects user updates to checked which happen before hydration" $ runWD $ do
453− checkedByUIRef <- newRef False
454− checkedRef <- newRef False
455− let checkStatic = do
456− e <- findElemWithRetry $ WD.ByTag "input"
457− WD.attr e "checked" `shouldBeWithRetryM` Nothing
458− WD.moveToCenter e
459− WD.click e
460− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
461− pure e
462− checkValue e = do
463− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
464− readRef checkedByUIRef `shouldBeWithRetryM` True
465− readRef checkedRef `shouldBeWithRetryM` True
466− testWidget' checkStatic checkValue $ do
467− e <- inputElement $ def
468− & initialAttributes .~ "type" =: "checkbox"
469− performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
470− performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
471370 it "captures file uploads" $ runWD $ do
472371 filesRef :: IORef [Text] <- newRef []
473372 let uploadFile = do
@@ -483,117 +382,8 @@ tests withDebugging wdConfig caps _selenium = do
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
@@ -673,31 +463,8 @@ tests withDebugging wdConfig caps _selenium = do
673463 names <- liftJSM $ traverse File.getName fs
674464 liftIO $ writeRef filesRef names
675465
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
466+ describe "textAreaElement" $ do
467+ describe "hydration" $ session' $ do
701468 it "doesn't wipe user input when switching over" $ runWD $ do
702469 inputRef <- newRef ("" :: Text)
703470 testWidget'
@@ -763,90 +530,8 @@ tests withDebugging wdConfig caps _selenium = do
763530 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
764531 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
765532 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
848533
849− describe "hydration/immediate" $ do
534+ describe "hydration/immediate" $ session' $ do
850535 it "captures user input after switchover" $ runWD $ do
851536 inputRef :: IORef Text <- newRef ""
852537 let checkValue = do
@@ -888,13 +573,13 @@ tests withDebugging wdConfig caps _selenium = do
888573 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
889574 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
890575
891− session' "selectElement" $ do
576+ describe "selectElement" $ do
892577 let options :: DomBuilder t m => m ()
893578 options = do
894579 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
895580 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
896581 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
897− describe "hydration" $ do
582+ describe "hydration" $ session' $ do
898583 it "sets initial value correctly" $ runWD $ do
899584 inputRef <- newRef ("" :: Text)
900585 let setup = do
@@ -968,7 +653,7 @@ tests withDebugging wdConfig caps _selenium = do
968653 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
969654 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
970655
971− describe "hydration/immediate" $ do
656+ describe "hydration/immediate" $ session' $ do
972657 it "captures user input after switchover" $ runWD $ do
973658 inputRef :: IORef Text <- newRef ""
974659 let checkValue = do
@@ -1014,7 +699,7 @@ tests withDebugging wdConfig caps _selenium = do
1014699 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
1015700 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
1016701
1017− session' "prerender" $ do
702+ describe "prerender" $ session' $ do
1018703 it "works in simple case" $ runWD $ do
1019704 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
1020705 prerender_ (text "One") (text "Two")
@@ -1059,9 +744,9 @@ tests withDebugging wdConfig caps _selenium = do
1059744 pb <- getPostBuild
1060745 performEvent_ $ liftIO (putMVar lock ()) <$ pb
1061746 it "result Dynamic is updated *after* switchover" $ runWD $ do
1062− let preSwitchover = checkBodyText "PostBuild"
747+ let static = checkBodyText "PostBuild"
1063748 check = checkBodyText "Client"
1064− testWidget preSwitchover check $ void $ do
749+ testWidget static check $ void $ do
1065750 d <- prerender (pure "Initial") (pure "Client")
1066751 pb <- getPostBuild
1067752 initial <- sample $ current d
@@ -1069,30 +754,21 @@ tests withDebugging wdConfig caps _selenium = do
1069754 -- This essentially checks that the client IO runs *after* switchover/postBuild,
1070755 -- thus can't create conflicting DOM
1071756 it "can't exploit IO to break hydration" $ runWD $ do
1072− let preSwitchover = checkBodyText "Initial"
1073− testWidgetStatic preSwitchover $ void $ do
757+ let static = checkBodyText "Initial"
758+ testWidgetStatic static $ void $ do
1074759 ref <- liftIO $ newRef "Initial"
1075760 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
1076761 text <=< liftIO $ readRef ref
1077762 -- As above, so below
1078763 it "can't exploit triggerEvent to break hydration" $ runWD $ do
1079− let preSwitchover = checkBodyText "Initial"
764+ let static = checkBodyText "Initial"
1080765 check = checkBodyText "Client"
1081− testWidget preSwitchover check $ void $ do
766+ testWidget static check $ void $ do
1082767 (e, trigger) <- newTriggerEvent
1083768 prerender_ (pure ()) (liftIO $ trigger "Client")
1084769 textNode $ TextNodeConfig "Initial" $ Just e
1085770
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
771+ describe "runWithReplace" $ session' $ do
1096772 it "works" $ runWD $ do
1097773 replaceChan :: Chan Text <- liftIO newChan
1098774 let setup = findElemWithRetry $ WD.ByTag "div"
@@ -1236,61 +912,7 @@ tests withDebugging wdConfig caps _selenium = do
1236912 , el "span" . text <$> replace
1237913 ]
1238914
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
915+ describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1294916 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
1295917 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1296918 elClass "span" "key" $ text $ textKey k
@@ -1330,26 +952,26 @@ tests withDebugging wdConfig caps _selenium = do
1330952 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
1331953 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1332954 chan <- liftIO newChan
1333− let preSwitchover :: WD [WD.Element]
1334− preSwitchover = getAndCheckInitialItems keyMap
955+ let static :: WD [WD.Element]
956+ static = getAndCheckInitialItems keyMap
1335957 check :: [WD.Element] -> WD ()
1336958 check xs = do
1337959 checkInitialItems keyMap xs
1338960 checkRemoval chan Key_Int
1339961 checkReplace chan Key_Char 'B'
1340962 checkInsert chan Key_Bool True
1341− testWidget' preSwitchover check $ do
963+ testWidget' static check $ do
1342964 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1343965 liftIO $ dmap `H.shouldBe` keyMap
1344966 it "handles postBuild correctly" $ runWD $ do
1345967 chan <- liftIO newChan
1346− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
968+ let static = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1347969 check xs = do
1348970 withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1349971 checkRemoval chan Key_Int
1350972 checkInsert chan Key_Char 'B'
1351973 checkReplace chan Key_Bool True
1352− testWidget' preSwitchover check $ void $ do
974+ testWidget' static check $ void $ do
1353975 pb <- getPostBuild
1354976 replace <- triggerEventWithChan chan
1355977 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1393,7 +1015,7 @@ tests withDebugging wdConfig caps _selenium = do
13931015 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
13941016 liftIO $ dmap `H.shouldBe` keyMap
13951017
1396− session' "traverseIntMapWithKeyWithAdjust" $ do
1018+ describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
13971019 let textKeyInt k = "key" <> T.pack (show k)
13981020 intMap = IntMap.fromList
13991021 [ (1, "one")
@@ -1439,24 +1061,24 @@ tests withDebugging wdConfig caps _selenium = do
14391061 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
14401062 xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
14411063 chan <- liftIO newChan
1442− let preSwitchover = getAndCheckInitialItems intMap
1064+ let static = getAndCheckInitialItems intMap
14431065 check xs = do
14441066 checkInitialItems intMap xs
14451067 checkRemoval chan 1
14461068 checkReplace chan 2 "deux"
14471069 checkInsert chan 4 "four"
1448− testWidget' preSwitchover check $ void $ do
1070+ testWidget' static check $ void $ do
14491071 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
14501072 liftIO $ im `H.shouldBe` intMap
14511073 xit "handles postBuild correctly" $ runWD $ do
14521074 chan <- liftIO newChan
1453− let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1075+ let static = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
14541076 check xs = do
14551077 withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
14561078 checkRemoval chan 1
14571079 checkInsert chan 2 "deux"
14581080 checkReplace chan 3 "trois"
1459− testWidget' preSwitchover check $ void $ do
1081+ testWidget' static check $ void $ do
14601082 pb <- getPostBuild
14611083 replace <- triggerEventWithChan chan
14621084 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1500,7 +1122,7 @@ tests withDebugging wdConfig caps _selenium = do
15001122 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
15011123 liftIO $ dmap `H.shouldBe` intMap
15021124
1503− session' "traverseDMapWithKeyWithAdjustWithMove" $ do
1125+ describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
15041126 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
15051127 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
15061128 elClass "span" "key" $ text $ textKey2 k
@@ -1551,12 +1173,12 @@ tests withDebugging wdConfig caps _selenium = do
15511173
15521174 describe "hydration" $ moveSpec $ \initMap test -> do
15531175 chan <- liftIO newChan
1554− let preSwitchover = getAndCheckInitialItems initMap
1176+ let static = getAndCheckInitialItems initMap
15551177 check xs = do
15561178 checkInitialItems initMap xs
15571179 body <- getBody
15581180 test body chan
1559− testWidget' preSwitchover check $ void $ do
1181+ testWidget' static check $ void $ do
15601182 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
15611183 liftIO $ assertEqual "DMap" initMap dmap
15621184
@@ -1580,14 +1202,12 @@ tests withDebugging wdConfig caps _selenium = do
15801202 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
15811203 liftIO $ assertEqual "DMap" initMap dmap
15821204
1583− session' "hydrating invalid HTML" $ do
1584− xit "can hydrate list in paragraph" $ runWD $ do
1585− let preSwitchover = do
1205+ describe "hydrating invalid HTML" $ session' $ do
1206+ it "can hydrate list in paragraph" $ runWD $ do
1207+ let static = do
15861208 checkBodyText "before\ninner\nafter"
15871209 -- 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)"
1210+ [p1, p2] <- WD.findElems (WD.ByTag "p")
15911211 ol <- findElemWithRetry (WD.ByTag "ol")
15921212 shouldContainText "before" p1
15931213 shouldContainText "inner" ol
@@ -1598,8 +1218,7 @@ tests withDebugging wdConfig caps _selenium = do
15981218 shouldContainText "before\ninner\nafter" p1
15991219 elementShouldBeRemoved ol
16001220 elementShouldBeRemoved p2
1601− -- Don't fail fatally when hydration encounters the invalid DOM
1602− testWidgetDebug' False withDebugging preSwitchover check $ do
1221+ testWidget' static check $ do
16031222 -- This is deliberately invalid HTML, the browser will interpret it as
16041223 -- <p>before</p><ol>inner</ol>after<p></p>
16051224 el "p" $ do
@@ -1607,29 +1226,6 @@ tests withDebugging wdConfig caps _selenium = do
16071226 el "ol" $ text "inner"
16081227 text "after"
16091228
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−
16331229data Selenium = Selenium
16341230 { _selenium_portNumber :: PortNumber
16351231 , _selenium_stopServer :: IO ()
@@ -1697,9 +1293,6 @@ checkTextInId i expected = do
16971293findElemWithRetry :: Selector -> WD WD.Element
16981294findElemWithRetry = withRetry . WD.findElem
16991295
1700−findElemsWithRetry :: Selector -> WD [WD.Element]
1701−findElemsWithRetry = withRetry . WD.findElems
1702−
17031296getBody :: WD WD.Element
17041297getBody = WD.findElem $ WD.ByTag "body"
17051298
@@ -1708,8 +1301,8 @@ withRetry a = wait 300
17081301 where wait :: Int -> WD a
17091302 wait 0 = a
17101303 wait n = try a >>= \case
1711− Left (e :: SomeException) -> do
1712− liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
1304+ Left (_ :: SomeException) -> do
1305+ liftIO $ threadDelay 100000
17131306 wait $ n - 1
17141307 Right v -> return v
17151308
@@ -1725,12 +1318,11 @@ testWidgetStaticDebug
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+testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
17291322
17301323-- | TODO: do something about JSExceptions not causing tests to fail
17311324testWidgetDebug
17321325 :: Bool
1733− -> Bool
17341326 -> WD ()
17351327 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
17361328 -> WD b
@@ -1738,16 +1330,12 @@ testWidgetDebug
17381330 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17391331 -- ^ Widget we are testing
17401332 -> 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
1333+testWidgetDebug withDebugging beforeJS afterSwitchover =
1334+ testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
17461335
17471336-- | TODO: do something about JSExceptions not causing tests to fail
17481337testWidgetDebug'
17491338 :: Bool
1750− -> Bool
17511339 -> WD a
17521340 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
17531341 -> (a -> WD b)
@@ -1755,7 +1343,7 @@ testWidgetDebug'
17551343 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
17561344 -- ^ Widget we are testing (contents of body)
17571345 -> WD b
1758−testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
1346+testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
17591347 let putStrLnDebug :: MonadIO m => Text -> m ()
17601348 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
17611349 staticApp = do
@@ -1764,10 +1352,9 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
17641352 bodyWidget
17651353 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
17661354 putStrLnDebug "rendering static"
1767− ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1355+ ((), html) <- liftIO $ renderStatic staticApp
17681356 putStrLnDebug "rendered static"
17691357 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1770− onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
17711358 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
17721359 let entryPoint = do
17731360 putStrLnDebug "taking waitBeforeJS"
@@ -1779,7 +1366,7 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
17791366 liftIO $ putMVar waitUntilSwitchover ()
17801367 putStrLnDebug "put waitUntilSwitchover"
17811368 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1782− mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
1369+ mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
17831370 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
17841371 syncPoint
17851372 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
@@ -1797,26 +1384,23 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
17971384 ]
17981385 -- hSilence to get rid of ConnectionClosed logs
17991386 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
1814−
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)
1387+ jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
1388+ jsaddleTid <- liftIO jsaddleWarp
1389+ putStrLnDebug "taking waitJSaddle"
1390+ liftIO $ takeMVar waitJSaddle
1391+ putStrLnDebug "opening page"
1392+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1393+ putStrLnDebug "running beforeJS"
1394+ a <- beforeJS
1395+ putStrLnDebug "putting waitBeforeJS"
1396+ liftIO $ putMVar waitBeforeJS ()
1397+ putStrLnDebug "taking waitUntilSwitchover"
1398+ liftIO $ takeMVar waitUntilSwitchover
1399+ putStrLnDebug "running afterSwitchover"
1400+ b <- afterSwitchover a
1401+ putStrLnDebug "killing jsaddle thread"
1402+ liftIO $ killThread jsaddleTid
1403+ return b
18201404
18211405data Key2 a where
18221406 Key2_Int :: Int -> Key2 Int