mirror of
https://github.com/ilyakooo0/reflex-dom.git
synced 2024-09-11 06:35:30 +03:00
1829 lines
87 KiB
Haskell
1829 lines
87 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PolyKinds #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE RecursiveDo #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
-- Notice to those working on this test suite:
|
|
-- It doesn't appear to be possible to use --match to run a particular test, in
|
|
-- this situation the test may hang before reaching our code. This seems to
|
|
-- happen when the test is not the first test in the block. As a workaround, you
|
|
-- can just comment out the other tests. Also, using `xit` will cause the same
|
|
-- issue. `xit` tests must be the last tests in the session, or the session will
|
|
-- hang in the following test.
|
|
|
|
import Prelude hiding (fail)
|
|
import Control.Concurrent
|
|
import qualified Control.Concurrent.Async as Async
|
|
import Control.Lens.Operators
|
|
import Control.Monad hiding (fail)
|
|
import Control.Monad.Catch
|
|
import Control.Monad.Fail
|
|
import Control.Monad.Fix
|
|
import Control.Monad.IO.Class
|
|
import Control.Monad.Ref
|
|
import Data.Constraint.Extras
|
|
import Data.Constraint.Extras.TH
|
|
import Data.Dependent.Map (DMap)
|
|
import Data.Dependent.Sum (DSum(..), (==>))
|
|
import Data.Functor.Identity
|
|
import Data.Functor.Misc
|
|
import Data.GADT.Compare.TH
|
|
import Data.GADT.Show.TH
|
|
import Data.IORef (IORef)
|
|
import Data.List (sort)
|
|
import Data.Maybe
|
|
import Data.Proxy
|
|
import Data.Text (Text)
|
|
import Language.Javascript.JSaddle (syncPoint, liftJSM)
|
|
import Language.Javascript.JSaddle.Warp
|
|
import Network.HTTP.Types (status200)
|
|
import Network.Socket
|
|
import Network.Wai
|
|
import Network.WebSockets
|
|
import Reflex.Dom.Core
|
|
import Reflex.Dom.Widget.Input (dropdown)
|
|
import Reflex.Patch.DMapWithMove
|
|
import System.Directory
|
|
import System.Environment
|
|
import System.IO (stderr)
|
|
import System.IO.Silently
|
|
import System.IO.Temp
|
|
import System.Process
|
|
import System.Which (staticWhich)
|
|
import qualified Test.HUnit as HUnit
|
|
import qualified Test.Hspec as H
|
|
import qualified Test.Hspec.Core.Spec as H
|
|
import Test.Hspec (xit)
|
|
import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
|
|
import qualified Test.Hspec.WebDriver as WD
|
|
import Test.WebDriver (WD(..))
|
|
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import qualified Data.Dependent.Map as DMap
|
|
import qualified Data.IntMap as IntMap
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import qualified GHCJS.DOM.File as File
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
import qualified System.FilePath as FilePath
|
|
import qualified Test.WebDriver as WD
|
|
import qualified Test.WebDriver.Capabilities as WD
|
|
|
|
import Test.Util.ChromeFlags
|
|
import Test.Util.UnshareNetwork
|
|
|
|
-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
|
|
deriving instance MonadMask WD
|
|
|
|
chromium :: FilePath
|
|
chromium = $(staticWhich "chromium")
|
|
|
|
seleniumPort, jsaddlePort :: PortNumber
|
|
seleniumPort = 8000
|
|
jsaddlePort = 8001
|
|
|
|
-- TODO Remove orphan
|
|
instance MonadRef WD where
|
|
type Ref WD = Ref IO
|
|
newRef = WD . newRef
|
|
readRef = WD . readRef
|
|
writeRef r = WD . writeRef r
|
|
|
|
assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
|
|
assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
|
|
|
|
assertFailure :: MonadIO m => String -> m ()
|
|
assertFailure = liftIO . HUnit.assertFailure
|
|
|
|
assertBool :: (MonadIO m) => String -> Bool -> m ()
|
|
assertBool msg bool = liftIO $ HUnit.assertBool msg bool
|
|
|
|
chromeConfig :: Text -> [Text] -> WD.WDConfig
|
|
chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
|
|
|
|
keyMap :: DMap DKey Identity
|
|
keyMap = DMap.fromList
|
|
[ Key_Int ==> 0
|
|
, Key_Char ==> 'A'
|
|
]
|
|
|
|
data DKey a where
|
|
Key_Int :: DKey Int
|
|
Key_Char :: DKey Char
|
|
Key_Bool :: DKey Bool
|
|
|
|
|
|
textKey :: DKey a -> Text
|
|
textKey = \case
|
|
Key_Int -> "Key_Int"
|
|
Key_Char -> "Key_Char"
|
|
Key_Bool -> "Key_Bool"
|
|
|
|
deriveArgDict ''DKey
|
|
deriveGEq ''DKey
|
|
deriveGCompare ''DKey
|
|
deriveGShow ''DKey
|
|
|
|
deriving instance MonadFail WD
|
|
|
|
main :: IO ()
|
|
main = do
|
|
unshareNetwork
|
|
isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
|
|
withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
|
|
withSeleniumServer $ \selenium -> do
|
|
let browserPath = T.strip $ T.pack chromium
|
|
when (T.null browserPath) $ fail "No browser found"
|
|
withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
|
|
let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
|
|
chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
|
|
hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
|
|
|
|
tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
|
|
tests withDebugging wdConfig caps _selenium = do
|
|
let putStrLnDebug :: MonadIO m => Text -> m ()
|
|
putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
|
|
session' t = sessionWith wdConfig t . using caps
|
|
runWD m = runWDOptions (WdOptions False) $ do
|
|
putStrLnDebug "before"
|
|
r <- m
|
|
putStrLnDebug "after"
|
|
return r
|
|
testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
|
|
testWidgetStatic = testWidgetStaticDebug withDebugging
|
|
testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
|
|
testWidget = testWidgetDebug True withDebugging
|
|
testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
|
|
testWidget' = testWidgetDebug' True withDebugging
|
|
session' "text" $ do
|
|
it "works" $ runWD $ do
|
|
testWidgetStatic (checkBodyText "hello world") $ do
|
|
text "hello world"
|
|
it "works with postBuild" $ runWD $ do
|
|
testWidgetStatic (checkBodyText "pb") $ do
|
|
pb <- getPostBuild
|
|
void $ textNode $ TextNodeConfig "" $ Just $ "pb" <$ pb
|
|
it "works for adjacent text nodes" $ runWD $ do
|
|
testWidgetStatic (checkBodyText "hello world") $ do
|
|
text "hello "
|
|
text "world"
|
|
it "works for empty adjacent text nodes" $ runWD $ do
|
|
testWidgetStatic (checkBodyText "hello world") $ do
|
|
pb <- getPostBuild
|
|
text ""
|
|
text ""
|
|
_ <- textNode $ TextNodeConfig "" $ Just $ "hello " <$ pb
|
|
_ <- textNode $ TextNodeConfig "abc" $ Just $ "" <$ pb
|
|
_ <- textNode $ TextNodeConfig "" $ Just $ "world" <$ pb
|
|
text ""
|
|
it "works when empty text nodes are the only children of an element" $ runWD $ do
|
|
testWidgetStatic (checkBodyText "hello world") $ do
|
|
el "div" $ do
|
|
text ""
|
|
text ""
|
|
text "hello world"
|
|
it "works when an empty text node is the first child before text" $ runWD $ do
|
|
testWidgetStatic (checkTextInTag "div" "hello world") $ do
|
|
el "div" $ do
|
|
text ""
|
|
text "hello world"
|
|
it "works when an empty text node is the first child before element" $ runWD $ do
|
|
testWidgetStatic (checkTextInTag "div" "hello world") $ do
|
|
el "div" $ do
|
|
text ""
|
|
el "span" $ text "hello world"
|
|
it "works when an empty text node is the last child" $ runWD $ do
|
|
testWidgetStatic (checkTextInTag "div" "hello world") $ do
|
|
el "div" $ do
|
|
el "span" $ text "hello world"
|
|
text ""
|
|
-- TODO I think these two tests are broken
|
|
-- it "updates after postBuild" $ runWD $ do
|
|
-- testWidget (checkBodyText "initial") (checkBodyText "after") $ do
|
|
-- after <- delay 0 =<< getPostBuild
|
|
-- void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ after
|
|
-- it "updates immediately after postBuild" $ runWD $ do
|
|
-- testWidget (checkBodyText "pb") (checkBodyText "after") $ do
|
|
-- pb <- getPostBuild
|
|
-- after <- delay 0 pb
|
|
-- void $ textNode $ TextNodeConfig "initial" $ Just $ leftmost ["pb" <$ pb, "after" <$ after]
|
|
it "updates in immediate mode" $ runWD $ do
|
|
let checkUpdated = do
|
|
checkBodyText "initial"
|
|
WD.click =<< findElemWithRetry (WD.ByTag "button")
|
|
checkBodyText "after"
|
|
testWidget (pure ()) checkUpdated $ prerender_ (pure ()) $ do
|
|
click <- button ""
|
|
void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
|
|
|
|
session' "element" $ do
|
|
it "works with domEvent Click" $ runWD $ do
|
|
clickedRef <- liftIO $ newRef False
|
|
testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
|
|
(e, _) <- el' "div" $ text "hello world"
|
|
performEvent_ $ liftIO (writeRef clickedRef True) <$ domEvent Click e
|
|
readRef clickedRef `shouldBeWithRetryM` True
|
|
it "works with eventFlags stopPropagation" $ runWD $ do
|
|
firstClickedRef <- newRef False
|
|
secondClickedRef <- newRef False
|
|
let clickBoth = do
|
|
findElemWithRetry (WD.ById "first") >>= WD.click
|
|
findElemWithRetry (WD.ById "second") >>= WD.click
|
|
testWidget (pure ()) clickBoth $ do
|
|
(firstDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do
|
|
void $ elAttr "span" ("id" =: "first") $ text "hello world"
|
|
performEvent_ $ liftIO (writeRef firstClickedRef True) <$ domEvent Click firstDivEl
|
|
(secondDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do
|
|
let conf :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace
|
|
conf = (def :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace)
|
|
& initialAttributes .~ "id" =: "second"
|
|
& elementConfig_eventSpec .~ addEventSpecFlags (Proxy :: Proxy GhcjsDomSpace) Click (\_ -> stopPropagation) def
|
|
void $ element "span" conf $ text "hello world"
|
|
performEvent_ $ liftIO (writeRef secondClickedRef True) <$ domEvent Click secondDivEl
|
|
firstClicked <- readRef firstClickedRef
|
|
secondClicked <- readRef secondClickedRef
|
|
assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)
|
|
it "works with eventFlags preventDefault" $ runWD $ do
|
|
let click = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
s0 <- WD.isSelected e
|
|
WD.click e
|
|
s1 <- WD.isSelected e
|
|
pure (s0, s1)
|
|
clicked <- testWidget (pure ()) click $ prerender_ (pure ()) $ do
|
|
let conf :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace
|
|
conf = (def :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace)
|
|
& elementConfig_eventSpec .~ addEventSpecFlags (Proxy :: Proxy GhcjsDomSpace) Click (\_ -> preventDefault) def
|
|
& initialAttributes .~ "type" =: "checkbox"
|
|
void $ element "input" conf $ text "hello world"
|
|
assertEqual "Click not prevented" (False, False) clicked
|
|
it "can add/update/remove attributes" $ runWD $ do
|
|
let checkInitialAttrs = do
|
|
e <- findElemWithRetry $ WD.ByTag "div"
|
|
assertAttr e "const" (Just "const")
|
|
assertAttr e "delete" (Just "delete")
|
|
assertAttr e "init" (Just "init")
|
|
assertAttr e "click" Nothing
|
|
pure e
|
|
checkModifyAttrs e = do
|
|
WD.click e
|
|
withRetry $ do
|
|
assertAttr e "const" (Just "const")
|
|
assertAttr e "delete" Nothing
|
|
assertAttr e "init" (Just "click")
|
|
assertAttr e "click" (Just "click")
|
|
testWidget' checkInitialAttrs checkModifyAttrs $ mdo
|
|
let conf = def
|
|
& initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"
|
|
& modifyAttributes .~ (("delete" =: Nothing <> "init" =: Just "click" <> "click" =: Just "click") <$ click)
|
|
(e, ()) <- element "div" conf $ text "hello world"
|
|
let click = domEvent Click e
|
|
return ()
|
|
|
|
session' "inputElement" $ do
|
|
describe "static renderer" $ do
|
|
it "sets value attribute" $ runWD $ do
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test"
|
|
pure e
|
|
checkHydrated e = do
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test"
|
|
testWidget' checkStatic checkHydrated $ void $ inputElement $ def
|
|
& inputElementConfig_initialValue .~ "test"
|
|
it "updates value attribute at postBuild" $ runWD $ do
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
|
|
pure e
|
|
checkHydrated e = do
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
|
|
testWidget' checkStatic checkHydrated $ do
|
|
pb <- getPostBuild
|
|
_ <- inputElement $ def
|
|
& inputElementConfig_initialValue .~ "test"
|
|
& inputElementConfig_setValue .~ ("test-updated" <$ pb)
|
|
pure ()
|
|
it "sets checked attr appropriately" $ runWD $ do
|
|
setCheckedChan <- liftIO newChan
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.attr e "checked" `shouldBeWithRetryM` Just "true"
|
|
pure e
|
|
checkValue e = do
|
|
WD.attr e "checked" `shouldBeWithRetryM` Just "true"
|
|
WD.moveToCenter e
|
|
WD.click e -- Click to uncheck
|
|
WD.attr e "checked" `shouldBeWithRetryM` Nothing
|
|
liftIO $ writeChan setCheckedChan True -- Programatically check the checkbox
|
|
WD.attr e "checked" `shouldBeWithRetryM` Just "true"
|
|
testWidget' checkStatic checkValue $ do
|
|
setChecked <- triggerEventWithChan setCheckedChan
|
|
_ <- inputElement $ def
|
|
& initialAttributes .~ "type" =: "checkbox"
|
|
& inputElementConfig_initialChecked .~ True
|
|
& inputElementConfig_setChecked .~ setChecked
|
|
pure ()
|
|
it "sets checked attr appropriately at postbuild" $ runWD $ do
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.attr e "checked" `shouldBeWithRetryM` Just "true"
|
|
pure e
|
|
checkValue e = do
|
|
WD.attr e "checked" `shouldBeWithRetryM` Just "true"
|
|
testWidget' checkStatic checkValue $ do
|
|
pb <- getPostBuild
|
|
_ <- inputElement $ def
|
|
& initialAttributes .~ "type" =: "checkbox"
|
|
& inputElementConfig_initialChecked .~ False
|
|
& inputElementConfig_setChecked .~ (True <$ pb)
|
|
pure ()
|
|
describe "hydration" $ do
|
|
it "doesn't wipe user input when switching over" $ runWD $ do
|
|
inputRef <- newRef ("hello " :: Text)
|
|
testWidget'
|
|
(do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.sendKeys "world" e
|
|
pure e)
|
|
(\e -> do
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
|
|
WD.click =<< findElemWithRetry (WD.ByTag "button")
|
|
readRef inputRef `shouldBeWithRetryM` "hello world"
|
|
) $ do
|
|
e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
|
|
click <- button "save"
|
|
performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
|
|
it "captures user input after switchover" $ runWD $ do
|
|
inputRef <- newRef ("" :: Text)
|
|
let checkValue = do
|
|
WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
|
|
WD.click =<< findElemWithRetry (WD.ByTag "button")
|
|
readRef inputRef `shouldBeWithRetryM` "hello world"
|
|
testWidget (pure ()) checkValue $ do
|
|
e <- inputElement def
|
|
click <- button "save"
|
|
performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
|
|
it "sets focus appropriately" $ runWD $ do
|
|
focusRef <- newRef False
|
|
let checkValue = do
|
|
readRef focusRef `shouldBeWithRetryM` False
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.click e
|
|
readRef focusRef `shouldBeWithRetryM` True
|
|
testWidget (pure ()) checkValue $ do
|
|
e <- inputElement def
|
|
performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
|
|
it "sets focus when focus occurs before hydration" $ runWD $ do
|
|
focusRef <- newRef False
|
|
let setup = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.click e
|
|
((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
|
|
readRef focusRef `shouldBeWithRetryM` False
|
|
check = readRef focusRef `shouldBeWithRetryM` True
|
|
testWidget setup check $ do
|
|
e <- inputElement def
|
|
performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
|
|
it "sets value appropriately" $ runWD $ do
|
|
valueByUIRef <- newRef ("" :: Text)
|
|
valueRef <- newRef ("" :: Text)
|
|
setValueChan :: Chan Text <- liftIO newChan
|
|
let checkValue = do
|
|
readRef valueByUIRef `shouldBeWithRetryM` ""
|
|
readRef valueRef `shouldBeWithRetryM` ""
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.sendKeys "hello" e
|
|
readRef valueByUIRef `shouldBeWithRetryM` "hello"
|
|
readRef valueRef `shouldBeWithRetryM` "hello"
|
|
liftIO $ writeChan setValueChan "world"
|
|
readRef valueByUIRef `shouldBeWithRetryM` "hello"
|
|
readRef valueRef `shouldBeWithRetryM` "world"
|
|
testWidget (pure ()) checkValue $ do
|
|
update <- triggerEventWithChan setValueChan
|
|
e <- inputElement $ def & inputElementConfig_setValue .~ update
|
|
performEvent_ $ liftIO . writeRef valueByUIRef <$> _inputElement_input e
|
|
performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
|
|
it "sets checked appropriately" $ runWD $ do
|
|
checkedByUIRef <- newRef False
|
|
checkedRef <- newRef False
|
|
setCheckedChan <- liftIO newChan
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.attr e "checked" `shouldBeWithRetryM` Nothing
|
|
pure e
|
|
checkValue e = do
|
|
readRef checkedByUIRef `shouldBeWithRetryM` False
|
|
readRef checkedRef `shouldBeWithRetryM` False
|
|
WD.attr e "checked" `shouldBeWithRetryM` Nothing
|
|
WD.moveToCenter e
|
|
WD.click e
|
|
readRef checkedByUIRef `shouldBeWithRetryM` True
|
|
readRef checkedRef `shouldBeWithRetryM` True
|
|
WD.attr e "checked" `shouldBeWithRetryM` Just "true"
|
|
liftIO $ writeChan setCheckedChan False
|
|
readRef checkedByUIRef `shouldBeWithRetryM` True
|
|
readRef checkedRef `shouldBeWithRetryM` False
|
|
WD.attr e "checked" `shouldBeWithRetryM` Nothing
|
|
testWidget' checkStatic checkValue $ do
|
|
setChecked <- triggerEventWithChan setCheckedChan
|
|
e <- inputElement $ def
|
|
& initialAttributes .~ "type" =: "checkbox"
|
|
& inputElementConfig_setChecked .~ setChecked
|
|
performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
|
|
performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
|
|
it "respects user updates to checked which happen before hydration" $ runWD $ do
|
|
checkedByUIRef <- newRef False
|
|
checkedRef <- newRef False
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.attr e "checked" `shouldBeWithRetryM` Nothing
|
|
WD.moveToCenter e
|
|
WD.click e
|
|
WD.attr e "checked" `shouldBeWithRetryM` Just "true"
|
|
pure e
|
|
checkValue e = do
|
|
WD.attr e "checked" `shouldBeWithRetryM` Just "true"
|
|
readRef checkedByUIRef `shouldBeWithRetryM` True
|
|
readRef checkedRef `shouldBeWithRetryM` True
|
|
testWidget' checkStatic checkValue $ do
|
|
e <- inputElement $ def
|
|
& initialAttributes .~ "type" =: "checkbox"
|
|
performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
|
|
performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
|
|
it "captures file uploads" $ runWD $ do
|
|
filesRef :: IORef [Text] <- newRef []
|
|
let uploadFile = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
path <- liftIO $ writeSystemTempFile "testFile" "file contents"
|
|
WD.sendKeys (T.pack path) e
|
|
WD.click =<< findElemWithRetry (WD.ByTag "button")
|
|
liftIO $ removeFile path
|
|
readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
|
|
testWidget (pure ()) uploadFile $ do
|
|
e <- inputElement $ def & initialAttributes .~ "type" =: "file"
|
|
click <- button "save"
|
|
prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
|
|
names <- liftJSM $ traverse File.getName fs
|
|
liftIO $ writeRef filesRef names
|
|
it "fires _input event if the user altered the value before hydration" $ runWD $ do
|
|
input <- newRef ("" :: Text)
|
|
update <- newRef ("" :: Text)
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.attr e "value" `shouldBeWithRetryM` Just ""
|
|
WD.sendKeys "test" e
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test"
|
|
pure e
|
|
checkHydrated e = do
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test"
|
|
readRef input `shouldBeWithRetryM` "test"
|
|
readRef update `shouldBeWithRetryM` "test"
|
|
testWidget' checkStatic checkHydrated $ do
|
|
e <- inputElement def
|
|
performEvent_ $ liftIO . writeRef input <$> _inputElement_input e
|
|
performEvent_ $ liftIO . writeRef update <$> updated (_inputElement_value e)
|
|
it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
|
|
input <- newRef (Nothing :: Maybe Text)
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "pb"
|
|
pure e
|
|
checkHydrated e = do
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "pb"
|
|
readRef input `shouldBeWithRetryM` Nothing
|
|
testWidget' checkStatic checkHydrated $ do
|
|
pb <- getPostBuild
|
|
e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
|
|
performEvent_ $ liftIO . writeRef input . Just <$> _inputElement_input e
|
|
it "SSR produces correct DOM based on inputElement values when setValue happens at postBuild" $ runWD $ do
|
|
let checkBoth = do
|
|
input <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.attr input "value" `shouldBeWithRetryM` Just "pb"
|
|
p <- findElemWithRetry (WD.ByTag "p")
|
|
shouldContainText "pb" p
|
|
testWidget checkBoth checkBoth $ do
|
|
pb <- getPostBuild
|
|
e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
|
|
el "p" $ dynText $ _inputElement_value e
|
|
it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
|
|
let checkStatic = do
|
|
input <- findElemWithRetry $ WD.ByTag "input"
|
|
h2_value <- findElemWithRetry (WD.ByTag "h2")
|
|
h3_input <- findElemWithRetry (WD.ByTag "h3")
|
|
WD.attr input "value" `shouldBeWithRetryM` Just "pb"
|
|
shouldContainText "pb" h2_value
|
|
shouldContainText "" h3_input
|
|
WD.sendKeys "abc" input
|
|
WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
|
|
shouldContainText "pb" h2_value
|
|
shouldContainText "" h3_input
|
|
pure (input, h2_value, h3_input)
|
|
checkHydrated (input, h2_value, h3_input) = do
|
|
WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
|
|
shouldContainText "pbabc" h3_input
|
|
shouldContainText "pbabc pb" h2_value
|
|
pure ()
|
|
testWidget' checkStatic checkHydrated $ do
|
|
pb <- getPostBuild
|
|
e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
|
|
el "h1" $ dynText $ _inputElement_value e
|
|
el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _inputElement_value e
|
|
el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _inputElement_input e
|
|
it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
|
|
let checkStatic = do
|
|
input <- findElemWithRetry $ WD.ByTag "input"
|
|
p <- findElemWithRetry (WD.ByTag "p")
|
|
WD.attr input "value" `shouldBeWithRetryM` Just "pb"
|
|
shouldContainText "pb" p
|
|
WD.sendKeys "abc" input
|
|
WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
|
|
shouldContainText "pb" p -- It won't be updated yet
|
|
pure (input, p)
|
|
checkHydrated (input, p) = do
|
|
WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
|
|
shouldContainText "pbabc" p
|
|
pure ()
|
|
testWidget' checkStatic checkHydrated $ do
|
|
pb <- getPostBuild
|
|
e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
|
|
el "p" $ dynText $ _inputElement_value e
|
|
it "input event and (updated value) fire correctly when both setValue AND user updated value happen before switchover" $ runWD $ do
|
|
valRef <- newRef ([] :: [Text])
|
|
inputRef <- newRef ([] :: [Text])
|
|
let consRef ref a = liftIO $ atomicModifyRef ref $ \as -> (a:as, ())
|
|
checkStatic = do
|
|
input <- findElemWithRetry $ WD.ByTag "input"
|
|
p <- findElemWithRetry (WD.ByTag "p")
|
|
WD.attr input "value" `shouldBeWithRetryM` Just "pb"
|
|
shouldContainText "pb" p
|
|
WD.sendKeys "abc" input
|
|
WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
|
|
shouldContainText "pb" p -- It won't be updated yet
|
|
readRef inputRef `shouldBeWithRetryM` [] -- Should never fire input ref during SSR
|
|
readRef valRef `shouldBeWithRetryM` ["pb"]
|
|
pure (input, p)
|
|
checkHydrated (input, p) = do
|
|
readRef inputRef `shouldBeWithRetryM` ["pbabc"]
|
|
readRef valRef `shouldBeWithRetryM` ["pbabc", "pb"]
|
|
WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
|
|
shouldContainText "pbabc" p
|
|
pure ()
|
|
testWidget' checkStatic checkHydrated $ do
|
|
liftIO $ writeRef valRef []
|
|
pb <- getPostBuild
|
|
e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
|
|
el "p" $ dynText $ _inputElement_value e
|
|
performEvent_ $ consRef valRef <$> updated (_inputElement_value e)
|
|
performEvent_ $ consRef inputRef <$> _inputElement_input e
|
|
describe "hydration/immediate" $ do
|
|
it "captures user input after switchover" $ runWD $ do
|
|
inputRef :: IORef Text <- newRef ""
|
|
let checkValue = do
|
|
WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
|
|
WD.click =<< findElemWithRetry (WD.ByTag "button")
|
|
readRef inputRef `shouldBeWithRetryM` "hello world"
|
|
testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
|
|
e <- inputElement def
|
|
click <- button "save"
|
|
performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
|
|
it "sets focus appropriately" $ runWD $ do
|
|
focusRef <- newRef False
|
|
let checkValue = do
|
|
readRef focusRef `shouldBeWithRetryM` False
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.click e
|
|
readRef focusRef `shouldBeWithRetryM` True
|
|
testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
|
|
e <- inputElement def
|
|
performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
|
|
it "sets value appropriately" $ runWD $ do
|
|
valueByUIRef :: IORef Text <- newRef ""
|
|
valueRef :: IORef Text <- newRef ""
|
|
setValueChan :: Chan Text <- liftIO newChan
|
|
let checkValue = do
|
|
readRef valueByUIRef `shouldBeWithRetryM` ""
|
|
readRef valueRef `shouldBeWithRetryM` ""
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.sendKeys "hello" e
|
|
readRef valueByUIRef `shouldBeWithRetryM` "hello"
|
|
readRef valueRef `shouldBeWithRetryM` "hello"
|
|
liftIO $ writeChan setValueChan "world"
|
|
readRef valueByUIRef `shouldBeWithRetryM` "hello"
|
|
readRef valueRef `shouldBeWithRetryM` "world"
|
|
testWidget (pure ()) checkValue $ do
|
|
update <- triggerEventWithChan setValueChan
|
|
prerender_ (pure ()) $ do
|
|
e <- inputElement $ def & inputElementConfig_setValue .~ update
|
|
performEvent_ $ liftIO . writeRef valueByUIRef <$> _inputElement_input e
|
|
performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
|
|
it "sets checked appropriately" $ runWD $ do
|
|
checkedByUIRef <- newRef False
|
|
checkedRef <- newRef False
|
|
setCheckedChan <- liftIO newChan
|
|
let checkValue = do
|
|
readRef checkedByUIRef `shouldBeWithRetryM` False
|
|
readRef checkedRef `shouldBeWithRetryM` False
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
WD.moveToCenter e
|
|
WD.click e
|
|
readRef checkedByUIRef `shouldBeWithRetryM` True
|
|
readRef checkedRef `shouldBeWithRetryM` True
|
|
liftIO $ writeChan setCheckedChan False
|
|
readRef checkedByUIRef `shouldBeWithRetryM` True
|
|
readRef checkedRef `shouldBeWithRetryM` False
|
|
testWidget (pure ()) checkValue $ do
|
|
setChecked <- triggerEventWithChan setCheckedChan
|
|
prerender_ (pure ()) $ do
|
|
e <- inputElement $ def
|
|
& initialAttributes .~ "type" =: "checkbox"
|
|
& inputElementConfig_setChecked .~ setChecked
|
|
performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
|
|
performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
|
|
it "captures file uploads" $ runWD $ do
|
|
filesRef :: IORef [Text] <- newRef []
|
|
let uploadFile = do
|
|
e <- findElemWithRetry $ WD.ByTag "input"
|
|
path <- liftIO $ writeSystemTempFile "testFile" "file contents"
|
|
WD.sendKeys (T.pack path) e
|
|
WD.click =<< findElemWithRetry (WD.ByTag "button")
|
|
liftIO $ removeFile path
|
|
readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
|
|
testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
|
|
e <- inputElement $ def & initialAttributes .~ "type" =: "file"
|
|
click <- button "save"
|
|
performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
|
|
names <- liftJSM $ traverse File.getName fs
|
|
liftIO $ writeRef filesRef names
|
|
|
|
session' "textAreaElement" $ do
|
|
describe "static renderer" $ do
|
|
it "sets value attribute" $ runWD $ do
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test"
|
|
pure e
|
|
checkHydrated e = do
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test"
|
|
testWidget' checkStatic checkHydrated $ void $ textAreaElement $ def
|
|
& textAreaElementConfig_initialValue .~ "test"
|
|
it "updates value attribute at postBuild" $ runWD $ do
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
|
|
pure e
|
|
checkHydrated e = do
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
|
|
testWidget' checkStatic checkHydrated $ do
|
|
pb <- getPostBuild
|
|
_ <- textAreaElement $ def
|
|
& textAreaElementConfig_initialValue .~ "test"
|
|
& textAreaElementConfig_setValue .~ ("test-updated" <$ pb)
|
|
pure ()
|
|
describe "hydration" $ do
|
|
it "doesn't wipe user input when switching over" $ runWD $ do
|
|
inputRef <- newRef ("" :: Text)
|
|
testWidget'
|
|
(do
|
|
e <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.sendKeys "hello world" e
|
|
pure e)
|
|
(\e -> do
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
|
|
WD.click <=< findElemWithRetry $ WD.ByTag "button"
|
|
readRef inputRef `shouldBeWithRetryM` "hello world"
|
|
) $ do
|
|
e <- textAreaElement def
|
|
click <- button "save"
|
|
performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
|
|
it "captures user input after switchover" $ runWD $ do
|
|
inputRef <- newRef ("" :: Text)
|
|
let checkValue = do
|
|
WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "textarea")
|
|
WD.click =<< findElemWithRetry (WD.ByTag "button")
|
|
readRef inputRef `shouldBeWithRetryM` "hello world"
|
|
testWidget (pure ()) checkValue $ do
|
|
e <- textAreaElement def
|
|
click <- button "save"
|
|
performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
|
|
it "sets focus appropriately" $ runWD $ do
|
|
focusRef <- newRef False
|
|
let checkValue = do
|
|
readRef focusRef `shouldBeWithRetryM` False
|
|
e <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.click e
|
|
readRef focusRef `shouldBeWithRetryM` True
|
|
testWidget (pure ()) checkValue $ do
|
|
e <- textAreaElement def
|
|
performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
|
|
it "sets focus when focus occurs before hydration" $ runWD $ do
|
|
focusRef <- newRef False
|
|
let setup = do
|
|
e <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.click e
|
|
((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
|
|
readRef focusRef `shouldBeWithRetryM` False
|
|
check = readRef focusRef `shouldBeWithRetryM` True
|
|
testWidget setup check $ do
|
|
e <- textAreaElement def
|
|
performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
|
|
it "sets value appropriately" $ runWD $ do
|
|
valueByUIRef <- newRef ("" :: Text)
|
|
valueRef <- newRef ("" :: Text)
|
|
setValueChan :: Chan Text <- liftIO newChan
|
|
let checkValue = do
|
|
readRef valueByUIRef `shouldBeWithRetryM` ""
|
|
readRef valueRef `shouldBeWithRetryM` ""
|
|
e <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.sendKeys "hello" e
|
|
readRef valueByUIRef `shouldBeWithRetryM` "hello"
|
|
readRef valueRef `shouldBeWithRetryM` "hello"
|
|
liftIO $ writeChan setValueChan "world"
|
|
readRef valueByUIRef `shouldBeWithRetryM` "hello"
|
|
readRef valueRef `shouldBeWithRetryM` "world"
|
|
testWidget (pure ()) checkValue $ do
|
|
setValue' <- triggerEventWithChan setValueChan
|
|
e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
|
|
performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
|
|
performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
|
|
it "fires _input event if the user altered the value before hydration" $ runWD $ do
|
|
textarea <- newRef ("" :: Text)
|
|
update <- newRef ("" :: Text)
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.attr e "value" `shouldBeWithRetryM` Just ""
|
|
WD.sendKeys "test" e
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test"
|
|
pure e
|
|
checkHydrated e = do
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "test"
|
|
readRef textarea `shouldBeWithRetryM` "test"
|
|
readRef update `shouldBeWithRetryM` "test"
|
|
testWidget' checkStatic checkHydrated $ do
|
|
e <- textAreaElement def
|
|
performEvent_ $ liftIO . writeRef textarea <$> _textAreaElement_input e
|
|
performEvent_ $ liftIO . writeRef update <$> updated (_textAreaElement_value e)
|
|
it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
|
|
textarea <- newRef (Nothing :: Maybe Text)
|
|
let checkStatic = do
|
|
e <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "pb"
|
|
pure e
|
|
checkHydrated e = do
|
|
WD.attr e "value" `shouldBeWithRetryM` Just "pb"
|
|
readRef textarea `shouldBeWithRetryM` Nothing
|
|
testWidget' checkStatic checkHydrated $ do
|
|
pb <- getPostBuild
|
|
e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
|
|
performEvent_ $ liftIO . writeRef textarea . Just <$> _textAreaElement_input e
|
|
it "SSR produces correct DOM based on textAreaElement values when setValue happens at postBuild" $ runWD $ do
|
|
let checkBoth = do
|
|
textarea <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
|
|
p <- findElemWithRetry (WD.ByTag "p")
|
|
shouldContainText "pb" p
|
|
testWidget checkBoth checkBoth $ do
|
|
pb <- getPostBuild
|
|
e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
|
|
el "p" $ dynText $ _textAreaElement_value e
|
|
it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
|
|
let checkStatic = do
|
|
textarea <- findElemWithRetry $ WD.ByTag "textarea"
|
|
h2_value <- findElemWithRetry (WD.ByTag "h2")
|
|
h3_input <- findElemWithRetry (WD.ByTag "h3")
|
|
WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
|
|
shouldContainText "pb" h2_value
|
|
shouldContainText "" h3_input
|
|
WD.sendKeys "abc" textarea
|
|
WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
|
|
shouldContainText "pb" h2_value
|
|
shouldContainText "" h3_input
|
|
pure (textarea, h2_value, h3_input)
|
|
checkHydrated (textarea, h2_value, h3_input) = do
|
|
WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
|
|
shouldContainText "pbabc" h3_input
|
|
shouldContainText "pbabc pb" h2_value
|
|
pure ()
|
|
testWidget' checkStatic checkHydrated $ do
|
|
pb <- getPostBuild
|
|
e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
|
|
el "h1" $ dynText $ _textAreaElement_value e
|
|
el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _textAreaElement_value e
|
|
el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _textAreaElement_input e
|
|
it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
|
|
let checkStatic = do
|
|
textarea <- findElemWithRetry $ WD.ByTag "textarea"
|
|
p <- findElemWithRetry (WD.ByTag "p")
|
|
WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
|
|
shouldContainText "pb" p
|
|
WD.sendKeys "abc" textarea
|
|
WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
|
|
shouldContainText "pb" p -- It won't be updated yet
|
|
pure (textarea, p)
|
|
checkHydrated (textarea, p) = do
|
|
WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
|
|
shouldContainText "pbabc" p
|
|
pure ()
|
|
testWidget' checkStatic checkHydrated $ do
|
|
pb <- getPostBuild
|
|
e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
|
|
el "p" $ dynText $ _textAreaElement_value e
|
|
|
|
describe "hydration/immediate" $ do
|
|
it "captures user input after switchover" $ runWD $ do
|
|
inputRef :: IORef Text <- newRef ""
|
|
let checkValue = do
|
|
WD.sendKeys "hello world" <=< findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.click <=< findElemWithRetry $ WD.ByTag "button"
|
|
readRef inputRef `shouldBeWithRetryM` "hello world"
|
|
testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
|
|
e <- textAreaElement def
|
|
click <- button "save"
|
|
performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
|
|
it "sets focus appropriately" $ runWD $ do
|
|
focusRef <- newRef False
|
|
let checkValue = do
|
|
readRef focusRef `shouldBeWithRetryM` False
|
|
e <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.click e
|
|
readRef focusRef `shouldBeWithRetryM` True
|
|
testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
|
|
e <- textAreaElement def
|
|
performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
|
|
it "sets value appropriately" $ runWD $ do
|
|
valueByUIRef :: IORef Text <- newRef ""
|
|
valueRef :: IORef Text <- newRef ""
|
|
setValueChan :: Chan Text <- liftIO newChan
|
|
let checkValue = do
|
|
readRef valueByUIRef `shouldBeWithRetryM` ""
|
|
readRef valueRef `shouldBeWithRetryM` ""
|
|
e <- findElemWithRetry $ WD.ByTag "textarea"
|
|
WD.sendKeys "hello" e
|
|
readRef valueByUIRef `shouldBeWithRetryM` "hello"
|
|
readRef valueRef `shouldBeWithRetryM` "hello"
|
|
liftIO $ writeChan setValueChan "world"
|
|
readRef valueByUIRef `shouldBeWithRetryM` "hello"
|
|
readRef valueRef `shouldBeWithRetryM` "world"
|
|
testWidget (pure ()) checkValue $ do
|
|
setValue' <- triggerEventWithChan setValueChan
|
|
prerender_ (pure ()) $ do
|
|
e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
|
|
performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
|
|
performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
|
|
|
|
session' "selectElement" $ do
|
|
let options :: DomBuilder t m => m ()
|
|
options = do
|
|
elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
|
|
elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
|
|
elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
|
|
describe "hydration" $ do
|
|
it "sets initial value correctly" $ runWD $ do
|
|
inputRef <- newRef ("" :: Text)
|
|
let setup = do
|
|
e <- findElemWithRetry $ WD.ByTag "select"
|
|
assertAttr e "value" (Just "three")
|
|
WD.click =<< findElemWithRetry (WD.ById "two")
|
|
pure e
|
|
check e = do
|
|
assertAttr e "value" (Just "two")
|
|
readRef inputRef `shouldBeWithRetryM` "three"
|
|
WD.click =<< findElemWithRetry (WD.ByTag "button")
|
|
assertAttr e "value" (Just "two")
|
|
readRef inputRef `shouldBeWithRetryM` "two"
|
|
testWidget' setup check $ do
|
|
(e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options
|
|
click <- button "save"
|
|
liftIO . writeRef inputRef <=< sample $ current $ _selectElement_value e
|
|
performEvent_ $ liftIO . writeRef inputRef <$> tag (current (_selectElement_value e)) click
|
|
it "captures user input after switchover" $ runWD $ do
|
|
inputRef <- newRef ("" :: Text)
|
|
let checkValue = do
|
|
e <- findElemWithRetry $ WD.ByTag "select"
|
|
assertAttr e "value" (Just "one")
|
|
WD.click =<< findElemWithRetry (WD.ById "two")
|
|
assertAttr e "value" (Just "two")
|
|
WD.click =<< findElemWithRetry (WD.ByTag "button")
|
|
readRef inputRef `shouldBeWithRetryM` "two"
|
|
testWidget (pure ()) checkValue $ do
|
|
(e, ()) <- selectElement def options
|
|
click <- button "save"
|
|
performEvent_ $ liftIO . writeRef inputRef <$> tag (current (_selectElement_value e)) click
|
|
it "sets focus appropriately" $ runWD $ do
|
|
focusRef <- newRef False
|
|
let checkValue = do
|
|
readRef focusRef `shouldBeWithRetryM` False
|
|
e <- findElemWithRetry $ WD.ByTag "select"
|
|
WD.click e
|
|
readRef focusRef `shouldBeWithRetryM` True
|
|
testWidget (pure ()) checkValue $ do
|
|
(e, ()) <- selectElement def options
|
|
performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
|
|
it "sets focus when focus occurs before hydration" $ runWD $ do
|
|
focusRef <- newRef False
|
|
let setup = do
|
|
e <- findElemWithRetry $ WD.ByTag "select"
|
|
WD.click e
|
|
((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
|
|
readRef focusRef `shouldBeWithRetryM` False
|
|
check = readRef focusRef `shouldBeWithRetryM` True
|
|
testWidget setup check $ do
|
|
(e, ()) <- selectElement def options
|
|
performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
|
|
it "sets value appropriately" $ runWD $ do
|
|
valueByUIRef <- newRef ("" :: Text)
|
|
valueRef <- newRef ("" :: Text)
|
|
setValueChan :: Chan Text <- liftIO newChan
|
|
let checkValue = do
|
|
e <- findElemWithRetry $ WD.ByTag "select"
|
|
assertAttr e "value" (Just "one")
|
|
readRef valueByUIRef `shouldBeWithRetryM` "one"
|
|
readRef valueRef `shouldBeWithRetryM` "one"
|
|
WD.click <=< findElemWithRetry $ WD.ById "two"
|
|
readRef valueByUIRef `shouldBeWithRetryM` "two"
|
|
readRef valueRef `shouldBeWithRetryM` "two"
|
|
liftIO $ writeChan setValueChan "three"
|
|
readRef valueByUIRef `shouldBeWithRetryM` "two"
|
|
readRef valueRef `shouldBeWithRetryM` "three"
|
|
testWidget (pure ()) checkValue $ do
|
|
setValue' <- triggerEventWithChan setValueChan
|
|
(e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
|
|
performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
|
|
performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
|
|
|
|
describe "hydration/immediate" $ do
|
|
it "captures user input after switchover" $ runWD $ do
|
|
inputRef :: IORef Text <- newRef ""
|
|
let checkValue = do
|
|
WD.click <=< findElemWithRetry $ WD.ById "two"
|
|
WD.click <=< findElemWithRetry $ WD.ByTag "button"
|
|
readRef inputRef `shouldBeWithRetryM` "two"
|
|
testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
|
|
(e, ()) <- selectElement def options
|
|
click <- button "save"
|
|
performEvent_ $ liftIO . writeRef inputRef <$> tag (current (_selectElement_value e)) click
|
|
it "sets focus appropriately" $ runWD $ do
|
|
focusRef <- newRef False
|
|
let checkValue = do
|
|
readRef focusRef `shouldBeWithRetryM` False
|
|
e <- findElemWithRetry $ WD.ByTag "select"
|
|
WD.click e
|
|
readRef focusRef `shouldBeWithRetryM` True
|
|
testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
|
|
(e, ()) <- selectElement def options
|
|
performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
|
|
it "has correct initial value" $ runWD $ do
|
|
valueRef :: IORef Text <- newRef ""
|
|
let checkValue = readRef valueRef `shouldBeWithRetryM` "one"
|
|
testWidget (pure ()) checkValue $ do
|
|
prerender_ (pure ()) $ do
|
|
(e, ()) <- selectElement def { _selectElementConfig_initialValue = "one" } options
|
|
liftIO . writeRef valueRef <=< sample $ current $ _selectElement_value e
|
|
it "sets value appropriately" $ runWD $ do
|
|
valueByUIRef :: IORef Text <- newRef ""
|
|
valueRef :: IORef Text <- newRef ""
|
|
setValueChan :: Chan Text <- liftIO newChan
|
|
let checkValue = do
|
|
WD.click =<< findElemWithRetry (WD.ById "two")
|
|
readRef valueByUIRef `shouldBeWithRetryM` "two"
|
|
readRef valueRef `shouldBeWithRetryM` "two"
|
|
liftIO $ writeChan setValueChan "three"
|
|
readRef valueByUIRef `shouldBeWithRetryM` "two"
|
|
readRef valueRef `shouldBeWithRetryM` "three"
|
|
testWidget (pure ()) checkValue $ do
|
|
setValue' <- triggerEventWithChan setValueChan
|
|
prerender_ (pure ()) $ do
|
|
(e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
|
|
performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
|
|
performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
|
|
|
|
session' "prerender" $ do
|
|
it "works in simple case" $ runWD $ do
|
|
testWidget (checkBodyText "One") (checkBodyText "Two") $ do
|
|
prerender_ (text "One") (text "Two")
|
|
it "removes element correctly" $ runWD $ do
|
|
testWidget' (findElemWithRetry $ WD.ByTag "span") elementShouldBeRemoved $ do
|
|
prerender_ (el "span" $ text "One") (text "Two")
|
|
it "can be nested in server widget" $ runWD $ do
|
|
testWidget (checkBodyText "One") (checkBodyText "Three") $ do
|
|
prerender_ (prerender_ (text "One") (text "Two")) (text "Three")
|
|
it "can be nested in client widget" $ runWD $ do
|
|
testWidget (checkBodyText "One") (checkBodyText "Three") $ do
|
|
prerender_ (text "One") (prerender_ (text "Two") (text "Three"))
|
|
it "works with prerender_ siblings" $ runWD $ do
|
|
testWidget
|
|
(checkTextInId "a1" "One" >> checkTextInId "b1" "Three" >> checkTextInId "c1" "Five")
|
|
(checkTextInId "a2" "Two" >> checkTextInId "b2" "Four" >> checkTextInId "c2" "Six") $ do
|
|
prerender_ (divId "a1" $ text "One") (divId "a2" $ text "Two")
|
|
prerender_ (divId "b1" $ text "Three") (divId "b2" $ text "Four")
|
|
prerender_ (divId "c1" $ text "Five") (divId "c2" $ text "Six")
|
|
it "works inside other element" $ runWD $ do
|
|
testWidget (checkTextInTag "div" "One") (checkTextInTag "div" "Two") $ do
|
|
el "div" $ prerender_ (text "One") (text "Two")
|
|
-- TODO re-enable this
|
|
-- it "places fences and removes them" $ runWD $ do
|
|
-- testWidget'
|
|
-- (do
|
|
-- scripts <- WD.findElems $ WD.ByTag "script"
|
|
-- filterM (\s -> maybe False (\t -> "prerender" `T.isPrefixOf` t) <$> WD.attr s "type") scripts
|
|
-- )
|
|
-- (traverse_ elementShouldBeRemoved)
|
|
-- (el "span" $ prerender_ (text "One") (text "Two"))
|
|
it "postBuild works on server side" $ runWD $ do
|
|
lock :: MVar () <- liftIO newEmptyMVar
|
|
testWidget (liftIO $ takeMVar lock) (pure ()) $ do
|
|
prerender_ (do
|
|
pb <- getPostBuild
|
|
performEvent_ $ liftIO (putMVar lock ()) <$ pb) blank
|
|
it "postBuild works on client side" $ runWD $ do
|
|
lock :: MVar () <- liftIO newEmptyMVar
|
|
testWidget (pure ()) (liftIO $ takeMVar lock) $ do
|
|
prerender_ blank $ do
|
|
pb <- getPostBuild
|
|
performEvent_ $ liftIO (putMVar lock ()) <$ pb
|
|
it "result Dynamic is updated *after* switchover" $ runWD $ do
|
|
let preSwitchover = checkBodyText "PostBuild"
|
|
check = checkBodyText "Client"
|
|
testWidget preSwitchover check $ void $ do
|
|
d <- prerender (pure "Initial") (pure "Client")
|
|
pb <- getPostBuild
|
|
initial <- sample $ current d
|
|
textNode $ TextNodeConfig initial $ Just $ leftmost [updated d, "PostBuild" <$ pb]
|
|
-- This essentially checks that the client IO runs *after* switchover/postBuild,
|
|
-- thus can't create conflicting DOM
|
|
it "can't exploit IO to break hydration" $ runWD $ do
|
|
let preSwitchover = checkBodyText "Initial"
|
|
testWidgetStatic preSwitchover $ void $ do
|
|
ref <- liftIO $ newRef "Initial"
|
|
prerender_ (pure ()) (liftIO $ writeRef ref "Client")
|
|
text <=< liftIO $ readRef ref
|
|
-- As above, so below
|
|
it "can't exploit triggerEvent to break hydration" $ runWD $ do
|
|
let preSwitchover = checkBodyText "Initial"
|
|
check = checkBodyText "Client"
|
|
testWidget preSwitchover check $ void $ do
|
|
(e, trigger) <- newTriggerEvent
|
|
prerender_ (pure ()) (liftIO $ trigger "Client")
|
|
textNode $ TextNodeConfig "Initial" $ Just e
|
|
|
|
session' "namespaces" $ do
|
|
it "dyn can be nested in namespaced widget" $ runWD $ do
|
|
testWidget (pure ()) (checkTextInTag "svg" "one") $ do
|
|
let svgRootCfg = def
|
|
& (elementConfig_namespace ?~ "http://www.w3.org/2000/svg")
|
|
& (elementConfig_initialAttributes .~ ("width" =: "100%" <> "height" =: "100%" <> "viewBox" =: "0 0 1536 2048"))
|
|
void $ element "svg" svgRootCfg $ do
|
|
dyn_ $ text "one" <$ pure ()
|
|
|
|
session' "runWithReplace" $ do
|
|
it "works" $ runWD $ do
|
|
replaceChan :: Chan Text <- liftIO newChan
|
|
let setup = findElemWithRetry $ WD.ByTag "div"
|
|
check ssr = do
|
|
-- Check that the original element still exists and has the correct text
|
|
shouldContainText "two" ssr
|
|
liftIO $ writeChan replaceChan "three"
|
|
elementShouldBeRemoved ssr
|
|
shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
|
|
testWidget' setup check $ do
|
|
replace <- triggerEventWithChan replaceChan
|
|
pb <- getPostBuild
|
|
void $ runWithReplace (el "div" $ text "one") $ leftmost
|
|
[ el "div" (text "two") <$ pb
|
|
, el "span" . text <$> replace
|
|
]
|
|
it "can be nested in initial widget" $ runWD $ do
|
|
replaceChan :: Chan Text <- liftIO newChan
|
|
let setup = findElemWithRetry $ WD.ByTag "div"
|
|
check ssr = do
|
|
-- Check that the original element still exists and has the correct text
|
|
shouldContainText "two" ssr
|
|
liftIO $ writeChan replaceChan "three"
|
|
elementShouldBeRemoved ssr
|
|
shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
|
|
testWidget' setup check $ void $ flip runWithReplace never $ do
|
|
replace <- triggerEventWithChan replaceChan
|
|
pb <- getPostBuild
|
|
void $ runWithReplace (el "div" $ text "one") $ leftmost
|
|
[ el "div" (text "two") <$ pb
|
|
, el "span" . text <$> replace
|
|
]
|
|
it "can be nested in postBuild widget" $ runWD $ do
|
|
replaceChan :: Chan Text <- liftIO newChan
|
|
let setup = findElemWithRetry $ WD.ByTag "div"
|
|
check ssr = do
|
|
-- Check that the original element still exists and has the correct text
|
|
shouldContainText "two" ssr
|
|
liftIO $ writeChan replaceChan "three"
|
|
elementShouldBeRemoved ssr
|
|
shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
|
|
testWidget' setup check $ void $ do
|
|
pb <- getPostBuild
|
|
runWithReplace (pure ()) $ ffor pb $ \() -> do
|
|
replace <- triggerEventWithChan replaceChan
|
|
pb' <- getPostBuild
|
|
void $ runWithReplace (el "div" $ text "one") $ leftmost
|
|
[ el "div" (text "two") <$ pb'
|
|
, el "span" . text <$> replace
|
|
]
|
|
it "postBuild works in replaced widget" $ runWD $ do
|
|
replaceChan <- liftIO newChan
|
|
pbLock <- liftIO newEmptyMVar
|
|
let check = liftIO $ do
|
|
writeChan replaceChan ()
|
|
takeMVar pbLock
|
|
testWidget (pure ()) check $ void $ do
|
|
replace <- triggerEventWithChan replaceChan
|
|
runWithReplace (pure ()) $ ffor replace $ \() -> do
|
|
pb <- getPostBuild
|
|
performEvent_ $ liftIO (putMVar pbLock ()) <$ pb
|
|
it "can be nested in event widget" $ runWD $ do
|
|
replaceChan1 :: Chan Text <- liftIO newChan
|
|
replaceChan2 :: Chan Text <- liftIO newChan
|
|
lock :: MVar () <- liftIO newEmptyMVar
|
|
let check = do
|
|
shouldContainText "" =<< findElemWithRetry (WD.ByTag "body")
|
|
liftIO $ do
|
|
writeChan replaceChan1 "one"
|
|
takeMVar lock
|
|
one <- findElemWithRetry $ WD.ByTag "div"
|
|
shouldContainText "pb" one
|
|
liftIO $ writeChan replaceChan2 "two"
|
|
elementShouldBeRemoved one
|
|
shouldContainText "two" =<< findElemWithRetry (WD.ByTag "span")
|
|
testWidget (pure ()) check $ void $ do
|
|
replace1 <- triggerEventWithChan replaceChan1
|
|
runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
|
|
replace2 <- triggerEventWithChan replaceChan2
|
|
pb <- getPostBuild
|
|
performEvent_ $ liftIO (putMVar lock ()) <$ pb
|
|
void $ runWithReplace (el "div" $ text r1) $ leftmost
|
|
[ el "span" . text <$> replace2
|
|
, el "div" (text "pb") <$ pb
|
|
]
|
|
it "prerender works in replaced widget" $ runWD $ do
|
|
replaceChan <- liftIO newChan
|
|
lock :: MVar () <- liftIO newEmptyMVar
|
|
pbLock :: MVar () <- liftIO newEmptyMVar
|
|
let check = do
|
|
liftIO $ do
|
|
writeChan replaceChan ()
|
|
takeMVar lock
|
|
takeMVar pbLock
|
|
testWidget (pure ()) check $ void $ do
|
|
replace <- triggerEventWithChan replaceChan
|
|
runWithReplace (pure ()) $ ffor replace $ \() -> do
|
|
prerender_ (pure ()) $ do
|
|
liftIO $ putMVar lock ()
|
|
pb <- getPostBuild
|
|
performEvent_ $ liftIO (putMVar pbLock ()) <$ pb
|
|
it "prerender returns in immediate mode" $ runWD $ do
|
|
replaceChan <- liftIO newChan
|
|
pbLock <- liftIO newEmptyMVar
|
|
let check = liftIO $ do
|
|
writeChan replaceChan ()
|
|
takeMVar pbLock
|
|
testWidget (pure ()) check $ void $ do
|
|
replace <- triggerEventWithChan replaceChan
|
|
runWithReplace (pure ()) $ ffor replace $ \() -> do
|
|
prerender_ (pure ()) (pure ())
|
|
liftIO $ putMVar pbLock ()
|
|
it "works in immediate mode (RHS of prerender)" $ runWD $ do
|
|
replaceChan :: Chan Text <- liftIO newChan
|
|
let check = do
|
|
checkBodyText "one"
|
|
one <- findElemWithRetry $ WD.ByTag "div"
|
|
shouldContainText "one" one
|
|
liftIO $ writeChan replaceChan "pb"
|
|
elementShouldBeRemoved one
|
|
shouldContainText "pb" =<< findElemWithRetry (WD.ByTag "span")
|
|
testWidget (pure ()) check $ void $ do
|
|
replace <- triggerEventWithChan replaceChan
|
|
prerender_ blank $ do
|
|
void $ runWithReplace (el "div" $ text "one") $ el "span" . text <$> replace
|
|
it "works with postBuild in immediate mode (RHS of prerender)" $ runWD $ do
|
|
replaceChan :: Chan Text <- liftIO newChan
|
|
let check = do
|
|
checkBodyText "two"
|
|
two <- findElemWithRetry $ WD.ByTag "div"
|
|
shouldContainText "two" two
|
|
liftIO $ writeChan replaceChan "three"
|
|
elementShouldBeRemoved two
|
|
shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
|
|
testWidget (pure ()) check $ void $ do
|
|
replace <- triggerEventWithChan replaceChan
|
|
prerender_ blank $ do
|
|
pb <- getPostBuild
|
|
void $ runWithReplace (el "div" $ text "one") $ leftmost
|
|
[ el "div" (text "two") <$ pb
|
|
, el "span" . text <$> replace
|
|
]
|
|
|
|
let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)
|
|
it "removes bracketing comments" $ runWD $ do
|
|
replaceChan :: Chan () <- liftIO newChan
|
|
let
|
|
preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
|
|
check () = do
|
|
liftIO $ writeChan replaceChan () -- trigger creation of p tag
|
|
_ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
|
|
checkInnerHtml "div" "before|<p>inner2</p>|after"
|
|
testWidget' preSwitchover check $ do
|
|
replace <- triggerEventWithChan replaceChan
|
|
el "div" $ do
|
|
text "before|"
|
|
_ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
|
|
text "|after"
|
|
it "ignores extra ending bracketing comment" $ runWD $ do
|
|
replaceChan :: Chan () <- liftIO newChan
|
|
let
|
|
preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"
|
|
check () = do
|
|
liftIO $ writeChan replaceChan () -- trigger creation of p tag
|
|
_ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
|
|
checkInnerHtml "div" "before|inner2|after"
|
|
testWidget' preSwitchover check $ do
|
|
replace <- triggerEventWithChan replaceChan
|
|
el "div" $ do
|
|
text "before|"
|
|
_ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
|
|
text "|after"
|
|
void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
|
|
-- TODO This test actually causes a hydration failure, but it wasn't
|
|
-- previously detected, so I've marked it pending
|
|
xit "ignores missing ending bracketing comments" $ runWD $ do
|
|
replaceChan :: Chan () <- liftIO newChan
|
|
let
|
|
preSwitchover = do
|
|
checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
|
|
divEl <- findElemWithRetry (WD.ByTag "div")
|
|
let wrongHtml = "<!--replace-start-0-->inner1"
|
|
actualHtml :: String <- WD.executeJS
|
|
[WD.JSArg divEl, WD.JSArg wrongHtml]
|
|
"arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"
|
|
actualHtml `shouldBe` wrongHtml
|
|
check () = do
|
|
liftIO $ writeChan replaceChan () -- trigger creation of p tag
|
|
_ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
|
|
checkInnerHtml "div" "before|<p>inner2</p>|after"
|
|
testWidget' preSwitchover check $ do
|
|
replace <- triggerEventWithChan replaceChan
|
|
el "div" $ do
|
|
text "before|"
|
|
_ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
|
|
text "|after"
|
|
|
|
session' "traverseDMapWithKeyWithAdjust" $ do
|
|
let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
|
|
widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
|
|
elClass "span" "key" $ text $ textKey k
|
|
elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
|
|
pure (Identity v)
|
|
checkItem :: WD.Element -> Text -> Text -> WD ()
|
|
checkItem li k v = do
|
|
putStrLnDebug "checkItem"
|
|
shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
|
|
shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
|
|
checkInitialItems dm xs = do
|
|
putStrLnDebug "checkInitialItems"
|
|
liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
|
|
forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
|
|
getAndCheckInitialItems dm = withRetry $ do
|
|
putStrLnDebug "getAndCheckInitialItems"
|
|
xs <- WD.findElems (WD.ByTag "li")
|
|
checkInitialItems dm xs
|
|
pure xs
|
|
checkRemoval chan k = do
|
|
putStrLnDebug "checkRemoval"
|
|
e <- findElemWithRetry (WD.ById $ textKey k)
|
|
liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
|
|
elementShouldBeRemoved e
|
|
checkReplace chan k v = do
|
|
putStrLnDebug "checkReplace"
|
|
e <- findElemWithRetry (WD.ById $ textKey k)
|
|
liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
|
|
elementShouldBeRemoved e
|
|
e' <- findElemWithRetry $ WD.ById $ textKey k
|
|
checkItem e' (textKey k) (T.pack $ show v)
|
|
checkInsert chan k v = do
|
|
putStrLnDebug "checkInsert"
|
|
liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
|
|
e <- findElemWithRetry (WD.ById $ textKey k)
|
|
checkItem e (textKey k) (T.pack $ show v)
|
|
postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
|
|
it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
|
|
chan <- liftIO newChan
|
|
let preSwitchover :: WD [WD.Element]
|
|
preSwitchover = getAndCheckInitialItems keyMap
|
|
check :: [WD.Element] -> WD ()
|
|
check xs = do
|
|
checkInitialItems keyMap xs
|
|
checkRemoval chan Key_Int
|
|
checkReplace chan Key_Char 'B'
|
|
checkInsert chan Key_Bool True
|
|
testWidget' preSwitchover check $ do
|
|
(dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
|
|
liftIO $ dmap `H.shouldBe` keyMap
|
|
it "handles postBuild correctly" $ runWD $ do
|
|
chan <- liftIO newChan
|
|
let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
|
|
check xs = do
|
|
withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
|
|
checkRemoval chan Key_Int
|
|
checkInsert chan Key_Char 'B'
|
|
checkReplace chan Key_Bool True
|
|
testWidget' preSwitchover check $ void $ do
|
|
pb <- getPostBuild
|
|
replace <- triggerEventWithChan chan
|
|
(dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
|
|
liftIO $ dmap `H.shouldBe` keyMap
|
|
it "can delete/update/insert when built in prerender" $ runWD $ do
|
|
chan <- liftIO newChan
|
|
let check = do
|
|
_ <- getAndCheckInitialItems keyMap
|
|
checkRemoval chan Key_Int
|
|
checkReplace chan Key_Char 'B'
|
|
checkInsert chan Key_Bool True
|
|
testWidget (pure ()) check $ do
|
|
replace <- triggerEventWithChan chan
|
|
prerender_ (pure ()) $ do
|
|
(dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap replace
|
|
liftIO $ dmap `H.shouldBe` keyMap
|
|
it "can delete/update/insert when built in immediate mode" $ runWD $ do
|
|
chan <- liftIO newChan
|
|
let check = do
|
|
_ <- getAndCheckInitialItems keyMap
|
|
checkRemoval chan Key_Int
|
|
checkReplace chan Key_Char 'B'
|
|
checkInsert chan Key_Bool True
|
|
testWidget (pure ()) check $ void $ do
|
|
pb <- getPostBuild
|
|
runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
|
|
(dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
|
|
liftIO $ dmap `H.shouldBe` keyMap
|
|
-- Should be fixed by prerender changes!
|
|
it "handles postBuild correctly in prerender" $ runWD $ do
|
|
chan <- liftIO newChan
|
|
let check = do
|
|
_ <- getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
|
|
checkRemoval chan Key_Int
|
|
checkInsert chan Key_Char 'B'
|
|
checkReplace chan Key_Bool True
|
|
testWidget (pure ()) check $ do
|
|
replace <- triggerEventWithChan chan
|
|
prerender_ (pure ()) $ void $ do
|
|
pb <- getPostBuild
|
|
(dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
|
|
liftIO $ dmap `H.shouldBe` keyMap
|
|
|
|
session' "traverseIntMapWithKeyWithAdjust" $ do
|
|
let textKeyInt k = "key" <> T.pack (show k)
|
|
intMap = IntMap.fromList
|
|
[ (1, "one")
|
|
, (2, "two")
|
|
, (3, "three")
|
|
]
|
|
let widget :: DomBuilder t m => IntMap.Key -> Text -> m Text
|
|
widget k v = elAttr "li" ("id" =: textKeyInt k) $ do
|
|
elClass "span" "key" $ text $ textKeyInt k
|
|
elClass "span" "value" $ text v
|
|
pure v
|
|
checkItem :: WD.Element -> Text -> Text -> WD ()
|
|
checkItem li k v = do
|
|
putStrLnDebug "checkItem"
|
|
shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
|
|
shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
|
|
checkInitialItems dm xs = do
|
|
putStrLnDebug "checkInitialItems"
|
|
liftIO $ assertEqual "Wrong amount of items in DOM" (IntMap.size dm) (length xs)
|
|
forM_ (zip xs (IntMap.toList dm)) $ \(e, (k, v)) -> checkItem e (textKeyInt k) v
|
|
getAndCheckInitialItems dm = withRetry $ do
|
|
putStrLnDebug "getAndCheckInitialItems"
|
|
xs <- WD.findElems (WD.ByTag "li")
|
|
checkInitialItems dm xs
|
|
pure xs
|
|
checkRemoval chan k = do
|
|
putStrLnDebug "checkRemoval"
|
|
e <- findElemWithRetry (WD.ById $ textKeyInt k)
|
|
liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
|
|
elementShouldBeRemoved e
|
|
checkReplace chan k v = do
|
|
putStrLnDebug "checkReplace"
|
|
e <- findElemWithRetry (WD.ById $ textKeyInt k)
|
|
liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
|
|
elementShouldBeRemoved e
|
|
e' <- findElemWithRetry (WD.ById $ textKeyInt k)
|
|
withRetry $ checkItem e' (textKeyInt k) v
|
|
checkInsert chan k v = do
|
|
putStrLnDebug "checkInsert"
|
|
liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
|
|
e <- findElemWithRetry (WD.ById $ textKeyInt k)
|
|
checkItem e (textKeyInt k) v
|
|
postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
|
|
xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
|
|
chan <- liftIO newChan
|
|
let preSwitchover = getAndCheckInitialItems intMap
|
|
check xs = do
|
|
checkInitialItems intMap xs
|
|
checkRemoval chan 1
|
|
checkReplace chan 2 "deux"
|
|
checkInsert chan 4 "four"
|
|
testWidget' preSwitchover check $ void $ do
|
|
(im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
|
|
liftIO $ im `H.shouldBe` intMap
|
|
xit "handles postBuild correctly" $ runWD $ do
|
|
chan <- liftIO newChan
|
|
let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
|
|
check xs = do
|
|
withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
|
|
checkRemoval chan 1
|
|
checkInsert chan 2 "deux"
|
|
checkReplace chan 3 "trois"
|
|
testWidget' preSwitchover check $ void $ do
|
|
pb <- getPostBuild
|
|
replace <- triggerEventWithChan chan
|
|
(dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
|
|
liftIO $ dmap `H.shouldBe` intMap
|
|
xit "can delete/update/insert when built in prerender" $ runWD $ do
|
|
chan <- liftIO newChan
|
|
let check = do
|
|
_ <- getAndCheckInitialItems intMap
|
|
checkRemoval chan 1
|
|
checkReplace chan 2 "deux"
|
|
checkInsert chan 4 "quatre"
|
|
testWidget (pure ()) check $ do
|
|
replace <- triggerEventWithChan chan
|
|
prerender_ (pure ()) $ do
|
|
(dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap replace
|
|
liftIO $ dmap `H.shouldBe` intMap
|
|
xit "can delete/update/insert when built in immediate mode" $ runWD $ do
|
|
chan <- liftIO newChan
|
|
let check = do
|
|
_ <- getAndCheckInitialItems intMap
|
|
checkRemoval chan 1
|
|
checkReplace chan 2 "deux"
|
|
checkInsert chan 4 "quatre"
|
|
testWidget (pure ()) check $ void $ do
|
|
pb <- getPostBuild
|
|
runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
|
|
(dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
|
|
liftIO $ dmap `H.shouldBe` intMap
|
|
-- Should be fixed by prerender changes!
|
|
xit "handles postBuild correctly in prerender" $ runWD $ do
|
|
chan <- liftIO newChan
|
|
let check = do
|
|
_ <- getAndCheckInitialItems $ applyAlways postBuildPatch intMap
|
|
checkRemoval chan 1
|
|
checkInsert chan 2 "deux"
|
|
checkReplace chan 3 "trois"
|
|
testWidget (pure ()) check $ do
|
|
replace <- triggerEventWithChan chan
|
|
prerender_ (pure ()) $ void $ do
|
|
pb <- getPostBuild
|
|
(dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
|
|
liftIO $ dmap `H.shouldBe` intMap
|
|
|
|
session' "traverseDMapWithKeyWithAdjustWithMove" $ do
|
|
let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
|
|
widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
|
|
elClass "span" "key" $ text $ textKey2 k
|
|
elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
|
|
pure (Identity v)
|
|
textKey2 :: Key2 a -> Text
|
|
textKey2 = \case
|
|
Key2_Int i -> "i" <> T.pack (show i)
|
|
Key2_Char c -> "c" <> T.pack [c]
|
|
checkItem :: WD.Element -> Text -> Text -> WD ()
|
|
checkItem li k v = do
|
|
shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
|
|
shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
|
|
checkInitialItems dm xs = do
|
|
liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
|
|
forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey2 k) (T.pack $ has @Show k $ show v)
|
|
getAndCheckInitialItems dm = withRetry $ do
|
|
xs <- WD.findElems (WD.ByTag "li")
|
|
checkInitialItems dm xs
|
|
pure xs
|
|
moveSpec
|
|
:: (DMap Key2 Identity -> (WD.Element -> Chan (PatchDMapWithMove Key2 Identity) -> WD ()) -> WD ())
|
|
-> H.SpecM (WdTestSession ()) ()
|
|
moveSpec testMove = do
|
|
it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
|
|
shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
|
|
liftIO $ writeChan chan (insertDMapKey (Key2_Int 2) 2)
|
|
shouldContainText (T.strip $ T.unlines ["i11","i22","i33"]) body
|
|
it "can delete an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3]) $ \body chan -> do
|
|
shouldContainText (T.strip $ T.unlines ["i11","i22","i33"]) body
|
|
liftIO $ writeChan chan (deleteDMapKey (Key2_Int 2))
|
|
shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
|
|
it "can swap items" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 2 ==> 2, Key2_Int 3 ==> 3, Key2_Int 4 ==> 4]) $ \body chan -> do
|
|
shouldContainText (T.strip $ T.unlines ["i11","i22","i33","i44"]) body
|
|
liftIO $ writeChan chan (swapDMapKey (Key2_Int 2) (Key2_Int 3))
|
|
shouldContainText (T.strip $ T.unlines ["i11","i33","i22","i44"]) body
|
|
-- TODO re-enable this
|
|
-- 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
|
|
-- shouldContainText (T.strip $ T.unlines ["i11","i22","i33", "i44"]) body
|
|
-- liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3))
|
|
-- shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
|
|
-- liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- attempt a move to nonexistent key should delete
|
|
-- shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
|
|
-- liftIO $ writeChan chan (moveDMapKey (Key2_Int 2) (Key2_Int 3)) -- this causes a JSException in immediate builder too
|
|
-- shouldContainText (T.strip $ T.unlines ["i11","i44"]) body
|
|
-- 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
|
|
-- shouldContainText (T.strip $ T.unlines ["i11","i22","i44"]) body
|
|
|
|
describe "hydration" $ moveSpec $ \initMap test -> do
|
|
chan <- liftIO newChan
|
|
let preSwitchover = getAndCheckInitialItems initMap
|
|
check xs = do
|
|
checkInitialItems initMap xs
|
|
body <- getBody
|
|
test body chan
|
|
testWidget' preSwitchover check $ void $ do
|
|
(dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
|
|
liftIO $ assertEqual "DMap" initMap dmap
|
|
|
|
describe "hydration/immediate" $ moveSpec $ \initMap test -> do
|
|
chan <- liftIO newChan
|
|
replace <- liftIO newChan
|
|
lock :: MVar () <- liftIO newEmptyMVar
|
|
let check = do
|
|
liftIO $ do
|
|
writeChan replace ()
|
|
takeMVar lock
|
|
xs <- getAndCheckInitialItems initMap
|
|
checkInitialItems initMap xs
|
|
body <- getBody
|
|
test body chan
|
|
testWidget (pure ()) check $ void $ do
|
|
e <- triggerEventWithChan replace
|
|
runWithReplace (pure ()) $ ffor e $ \() -> void $ do
|
|
pb <- getPostBuild
|
|
performEvent_ $ liftIO (putMVar lock ()) <$ pb
|
|
(dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
|
|
liftIO $ assertEqual "DMap" initMap dmap
|
|
|
|
session' "hydrating invalid HTML" $ do
|
|
xit "can hydrate list in paragraph" $ runWD $ do
|
|
let preSwitchover = do
|
|
checkBodyText "before\ninner\nafter"
|
|
-- Two <p> tags should be present
|
|
(p1, p2) <- WD.findElems (WD.ByTag "p") >>= \case
|
|
[p1, p2] -> pure (p1, p2)
|
|
_ -> error "Unexpected number of `p` tags (expected 2)"
|
|
ol <- findElemWithRetry (WD.ByTag "ol")
|
|
shouldContainText "before" p1
|
|
shouldContainText "inner" ol
|
|
shouldContainText "" p2
|
|
pure (p1, ol, p2)
|
|
check (p1, ol, p2) = do
|
|
checkBodyText "before\ninner\nafter"
|
|
shouldContainText "before\ninner\nafter" p1
|
|
elementShouldBeRemoved ol
|
|
elementShouldBeRemoved p2
|
|
-- Don't fail fatally when hydration encounters the invalid DOM
|
|
testWidgetDebug' False withDebugging preSwitchover check $ do
|
|
-- This is deliberately invalid HTML, the browser will interpret it as
|
|
-- <p>before</p><ol>inner</ol>after<p></p>
|
|
el "p" $ do
|
|
text "before"
|
|
el "ol" $ text "inner"
|
|
text "after"
|
|
|
|
-- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
|
|
-- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
|
|
-- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
|
|
session' "dropdown" $ do
|
|
let doTest expectedOpts (initialValue :: Text) = do
|
|
let doCheck = do
|
|
es <- findElemsWithRetry $ WD.ByTag "option"
|
|
opts <- mapM fetchElement es
|
|
assertEqual "missing/extra/incorrect option element(s)" expectedOpts (sort opts)
|
|
testWidget doCheck doCheck $ do
|
|
void $ dropdown initialValue (constDyn (("aa" :: Text) =: "aaa" <> "bb" =: "bbb")) def
|
|
fetchElement e = do
|
|
val <- WD.attr e "value"
|
|
sel <- WD.attr e "selected"
|
|
return (fromMaybe "" val, isJust sel)
|
|
-- 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)
|
|
-- Thus, it would appear that we do actually need a HTML5 or maybe XML parser for this test suite.
|
|
xit "statically renders initial values (on aa)" $ runWD $ do
|
|
doTest [("0",True),("1",False)] "aa"
|
|
-- 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
|
|
xit "statically renders initial values (on bb)" $ runWD $ do
|
|
doTest [("0",False),("1",True)] "bb"
|
|
|
|
data Selenium = Selenium
|
|
{ _selenium_portNumber :: PortNumber
|
|
, _selenium_stopServer :: IO ()
|
|
}
|
|
|
|
startSeleniumServer :: PortNumber -> IO (IO ())
|
|
startSeleniumServer port = do
|
|
(_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])
|
|
{ std_in = NoStream
|
|
, std_out = NoStream
|
|
, std_err = NoStream
|
|
}
|
|
return $ terminateProcess ph
|
|
|
|
withSeleniumServer :: (Selenium -> IO ()) -> IO ()
|
|
withSeleniumServer f = do
|
|
stopServer <- startSeleniumServer seleniumPort
|
|
threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
|
|
f $ Selenium
|
|
{ _selenium_portNumber = seleniumPort
|
|
, _selenium_stopServer = stopServer
|
|
}
|
|
|
|
triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender js t m) => Chan a -> m (Event t a)
|
|
triggerEventWithChan chan = do
|
|
(e, trigger) <- newTriggerEvent
|
|
-- In prerender because we only want to do this on the client
|
|
prerender_ (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
|
|
pure e
|
|
|
|
shouldBeWithRetryM :: (Eq a, Show a) => WD a -> a -> WD ()
|
|
shouldBeWithRetryM m expected = withRetry $ do
|
|
got <- m
|
|
got `shouldBe` expected
|
|
|
|
assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
|
|
assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
|
|
|
|
elementShouldBeRemoved :: WD.Element -> WD ()
|
|
elementShouldBeRemoved e = withRetry $ do
|
|
try (WD.getText e) >>= \case
|
|
Left (WD.FailedCommand WD.StaleElementReference _) -> return ()
|
|
Left err -> throwM err
|
|
Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
|
|
|
|
shouldContainText :: Text -> WD.Element -> WD ()
|
|
shouldContainText t = withRetry . shouldContainTextNoRetry t
|
|
|
|
shouldContainTextNoRetry :: Text -> WD.Element -> WD ()
|
|
shouldContainTextNoRetry t = flip shouldBe t <=< WD.getText
|
|
|
|
checkBodyText :: Text -> WD ()
|
|
checkBodyText = checkTextInTag "body"
|
|
|
|
checkTextInTag :: Text -> Text -> WD ()
|
|
checkTextInTag t expected = do
|
|
e <- findElemWithRetry (WD.ByTag t)
|
|
shouldContainText expected e
|
|
|
|
checkTextInId :: Text -> Text -> WD ()
|
|
checkTextInId i expected = do
|
|
e <- findElemWithRetry (WD.ById i)
|
|
shouldContainText expected e
|
|
|
|
findElemWithRetry :: Selector -> WD WD.Element
|
|
findElemWithRetry = withRetry . WD.findElem
|
|
|
|
findElemsWithRetry :: Selector -> WD [WD.Element]
|
|
findElemsWithRetry = withRetry . WD.findElems
|
|
|
|
getBody :: WD WD.Element
|
|
getBody = WD.findElem $ WD.ByTag "body"
|
|
|
|
withRetry :: forall a. WD a -> WD a
|
|
withRetry a = wait 300
|
|
where wait :: Int -> WD a
|
|
wait 0 = a
|
|
wait n = try a >>= \case
|
|
Left (e :: SomeException) -> do
|
|
liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
|
|
wait $ n - 1
|
|
Right v -> return v
|
|
|
|
divId :: DomBuilder t m => Text -> m a -> m a
|
|
divId i = elAttr "div" ("id" =: i)
|
|
|
|
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)
|
|
|
|
testWidgetStaticDebug
|
|
:: Bool
|
|
-> WD b
|
|
-- ^ Webdriver commands to run before JS runs and after hydration switchover
|
|
-> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
|
|
-- ^ Widget we are testing
|
|
-> WD b
|
|
testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
|
|
|
|
-- | TODO: do something about JSExceptions not causing tests to fail
|
|
testWidgetDebug
|
|
:: Bool
|
|
-> Bool
|
|
-> WD ()
|
|
-- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
|
|
-> WD b
|
|
-- ^ Webdriver commands to run after hydration switchover
|
|
-> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
|
|
-- ^ Widget we are testing
|
|
-> WD b
|
|
testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =
|
|
testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)
|
|
|
|
data HydrationFailedException = HydrationFailedException deriving Show
|
|
instance Exception HydrationFailedException
|
|
|
|
-- | TODO: do something about JSExceptions not causing tests to fail
|
|
testWidgetDebug'
|
|
:: Bool
|
|
-> Bool
|
|
-> WD a
|
|
-- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
|
|
-> (a -> WD b)
|
|
-- ^ Webdriver commands to run after hydration switchover
|
|
-> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
|
|
-- ^ Widget we are testing (contents of body)
|
|
-> WD b
|
|
testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
|
|
let putStrLnDebug :: MonadIO m => Text -> m ()
|
|
putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
|
|
staticApp = do
|
|
el "head" $ pure ()
|
|
el "body" $ do
|
|
bodyWidget
|
|
el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
|
|
putStrLnDebug "rendering static"
|
|
((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
|
|
putStrLnDebug "rendered static"
|
|
waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
|
|
onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
|
|
waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
|
|
let entryPoint = do
|
|
putStrLnDebug "taking waitBeforeJS"
|
|
liftIO $ takeMVar waitBeforeJS
|
|
let switchOverAction = do
|
|
putStrLnDebug "switchover syncPoint"
|
|
syncPoint
|
|
putStrLnDebug "putting waitUntilSwitchover"
|
|
liftIO $ putMVar waitUntilSwitchover ()
|
|
putStrLnDebug "put waitUntilSwitchover"
|
|
putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
|
|
mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
|
|
putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
|
|
syncPoint
|
|
application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
|
|
putStrLnDebug "sending response"
|
|
r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
|
|
putStrLnDebug "sent response"
|
|
return r
|
|
waitJSaddle <- liftIO newEmptyMVar
|
|
let settings = foldr ($) Warp.defaultSettings
|
|
[ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
|
|
, Warp.setBeforeMainLoop $ do
|
|
putStrLnDebug "putting waitJSaddle"
|
|
putMVar waitJSaddle ()
|
|
putStrLnDebug "put waitJSaddle"
|
|
]
|
|
-- hSilence to get rid of ConnectionClosed logs
|
|
silenceIfDebug = if withDebugging then id else hSilence [stderr]
|
|
jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
|
|
withAsync' jsaddleWarp $ do
|
|
putStrLnDebug "taking waitJSaddle"
|
|
liftIO $ takeMVar waitJSaddle
|
|
putStrLnDebug "opening page"
|
|
WD.openPage $ "http://localhost:" <> show jsaddlePort
|
|
putStrLnDebug "running beforeJS"
|
|
a <- beforeJS
|
|
putStrLnDebug "putting waitBeforeJS"
|
|
liftIO $ putMVar waitBeforeJS ()
|
|
putStrLnDebug "taking waitUntilSwitchover"
|
|
liftIO $ takeMVar waitUntilSwitchover
|
|
putStrLnDebug "running afterSwitchover"
|
|
afterSwitchover a
|
|
|
|
withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
|
|
withAsync' f g = bracket
|
|
(liftIO $ Async.async f)
|
|
(liftIO . Async.uninterruptibleCancel)
|
|
(const g)
|
|
|
|
data Key2 a where
|
|
Key2_Int :: Int -> Key2 Int
|
|
Key2_Char :: Char -> Key2 Char
|
|
|
|
deriveGEq ''Key2
|
|
deriveGCompare ''Key2
|
|
deriveGShow ''Key2
|
|
deriveArgDict ''Key2
|