{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
import Control.Concurrent
import Control.Monad
import Control.Monad.Catch
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(..), (==>), EqTag(..), ShowTag(..))
import Data.Functor.Identity
import Data.Functor.Misc
import Data.GADT.Compare.TH
import Data.GADT.Show.TH
import Data.IORef (IORef)
import Data.Maybe
import Data.Monoid
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.Patch.DMapWithMove
import System.Directory
import System.Environment
import System.IO (stderr)
import System.IO.Silently
import System.IO.Temp
import System.Process
import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
import qualified Test.Hspec 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
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 a b = liftIO . HUnit.assertEqual a b
assertFailure :: MonadIO m => String -> m ()
assertFailure = liftIO . HUnit.assertFailure
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
instance ShowTag DKey Identity where
showTaggedPrec = \case
Key_Int -> showsPrec
Key_Char -> showsPrec
Key_Bool -> showsPrec
instance EqTag DKey Identity where
eqTagged Key_Int Key_Int = (==)
eqTagged Key_Char Key_Char = (==)
eqTagged Key_Bool Key_Bool = (==)
main :: IO ()
main = do
unshareNetork
isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
withSeleniumServer $ \selenium -> do
browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
when (T.null browserPath) $ fail "No browser found"
withDebugging <- isJust <$> lookupEnv "DEBUG"
let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
tests withDebugging wdConfig caps _selenium = do
let putStrLnDebug :: MonadIO m => Text -> m ()
putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
session' = sessionWith wdConfig "" . using (map (,"") 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 withDebugging
testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
testWidget' = testWidgetDebug' withDebugging
describe "text" $ session' $ 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
describe "element" $ session' $ 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 ()
-- TODO check this is the correct solution
it "has ssr attribute, removes ssr attribute" $ runWD $ do
let checkSSRAttr = do
e <- findElemWithRetry $ WD.ByTag "div"
assertAttr e "data-ssr" (Just "")
pure e
testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world"
describe "inputElement" $ do
describe "hydration" $ session' $ do
it "doesn't wipe user input when switching over" $ runWD $ do
inputRef <- newRef ("" :: Text)
testWidget'
(do
e <- findElemWithRetry $ WD.ByTag "input"
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 <- inputElement 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 "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 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
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 $ 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
describe "hydration/immediate" $ session' $ 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
describe "textAreaElement" $ do
describe "hydration" $ session' $ 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)
describe "hydration/immediate" $ session' $ 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)
describe "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" $ session' $ 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" $ session' $ 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)
describe "prerender" $ session' $ 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 static = checkBodyText "PostBuild"
check = checkBodyText "Client"
testWidget static 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 static = checkBodyText "Initial"
testWidgetStatic static $ 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 static = checkBodyText "Initial"
check = checkBodyText "Client"
testWidget static check $ void $ do
(e, trigger) <- newTriggerEvent
prerender_ (pure ()) (liftIO $ trigger "Client")
textNode $ TextNodeConfig "Initial" $ Just e
describe "runWithReplace" $ session' $ 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 <- 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
]
describe "traverseDMapWithKeyWithAdjust" $ session' $ 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 static :: WD [WD.Element]
static = 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' static check $ do
(dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
liftIO $ dmap `H.shouldBe` keyMap
it "handles postBuild correctly" $ runWD $ do
chan <- liftIO newChan
let static = 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' static 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
describe "traverseIntMapWithKeyWithAdjust" $ session' $ 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 static = getAndCheckInitialItems intMap
check xs = do
checkInitialItems intMap xs
checkRemoval chan 1
checkReplace chan 2 "deux"
checkInsert chan 4 "four"
testWidget' static 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 static = 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' static 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
describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ 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 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 static = getAndCheckInitialItems initMap
check xs = do
checkInitialItems initMap xs
body <- getBody
test body chan
testWidget' static 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 <- 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
describe "hydrating invalid HTML" $ session' $ do
it "can hydrate list in paragraph" $ runWD $ do
let static = do
checkBodyText "before\ninner\nafter"
-- Two <p> tags should be present
[p1, p2] <- WD.findElems (WD.ByTag "p")
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
testWidget' static 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"
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
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 (_ :: SomeException) -> do
liftIO $ 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 withDebugging (void w) w
-- | TODO: do something about JSExceptions not causing tests to fail
testWidgetDebug
:: 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 withDebugging beforeJS afterSwitchover =
testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
-- | TODO: do something about JSExceptions not causing tests to fail
testWidgetDebug'
:: 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' 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 staticApp
putStrLnDebug "rendered static"
waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
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"
mainHydrationWidgetWithSwitchoverAction 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 = forkIO $ silenceIfDebug $ Warp.runSettings settings application
jsaddleTid <- liftIO jsaddleWarp
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"
b <- afterSwitchover a
putStrLnDebug "killing jsaddle thread"
liftIO $ killThread jsaddleTid
return b
data Key2 a where
Key2_Int :: Int -> Key2 Int
Key2_Char :: Char -> Key2 Char
deriveGEq ''Key2
deriveGCompare ''Key2
deriveGShow ''Key2
deriveArgDict ''Key2
instance ShowTag Key2 Identity where
showTaggedPrec = \case
Key2_Int _ -> showsPrec
Key2_Char _ -> showsPrec
instance EqTag Key2 Identity where
eqTagged (Key2_Int _) (Key2_Int _) = (==)
eqTagged (Key2_Char _) (Key2_Char _) = (==)