mirror of
https://github.com/ilyakooo0/reflex-dom.git
synced 2024-09-11 06:35:30 +03:00
More fixes for input/textArea elements, improve test suite
- Fix some bad behaviour around what happens at switchover with input type elements - Allow the test suite to report hydration failures. This also exposed an unrelated test failure which we previously missed. I marked it as pending for now - when the test suite was originally written, the hydration failures were always obvious in the logs during development, so it was difficult to add new failing tests. At some point we ended up being much more verbose by default, so the failure message got hidden.
This commit is contained in:
Tom Smalley
parent
0b9379019c
commit
8d034f2dfb
@ -292,11 +292,12 @@ localRunner (HydrationRunnerT m) s parent = do
|
||||
{-# INLINABLE runHydrationRunnerT #-}
|
||||
runHydrationRunnerT
|
||||
:: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
|
||||
=> HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
|
||||
runHydrationRunnerT (HydrationRunnerT m) s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do
|
||||
=> HydrationRunnerT t m a -> IO () -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
|
||||
runHydrationRunnerT (HydrationRunnerT m) onFailure s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do
|
||||
(a, s') <- runStateT m (HydrationState s False)
|
||||
traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
|
||||
when (_hydrationState_failed s') $ liftIO $ putStrLn "reflex-dom warning: hydration failed: the DOM was not as expected at switchover time. This may be due to invalid HTML which the browser has altered upon parsing, some external JS altering the DOM, or the page being served from an outdated cache."
|
||||
when (_hydrationState_failed s') $ liftIO onFailure
|
||||
pure a
|
||||
|
||||
instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
|
||||
@ -938,17 +939,15 @@ inputElementInternal cfg = getHydrationMode >>= \case
|
||||
domElement <- liftIO $ readIORef domElementRef
|
||||
let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
|
||||
getValue = Input.getValue domInputElement
|
||||
-- Fire the appropriate events if the value has changed somehow
|
||||
liftJSM getValue >>= \realValue -> liftIO $ if
|
||||
-- The user could have altered the value before switchover
|
||||
| realValue /= switchoverValue -> triggerChangeByUI realValue
|
||||
-- When the value has been updated by setValue before switchover, but
|
||||
-- the user hasn't entered text, we must send an update here to remain
|
||||
-- in sync. This is because the later requestDomAction based on the
|
||||
-- setValue event will not capture events happening before postBuild,
|
||||
-- because this code runs after switchover.
|
||||
| v0 /= switchoverValue -> triggerChangeBySetValue switchoverValue
|
||||
| otherwise -> pure ()
|
||||
-- When the value has been updated by setValue before switchover, we must
|
||||
-- send an update here to remain in sync. This is because the later
|
||||
-- requestDomAction based on the setValue event will not capture events
|
||||
-- happening before postBuild, because this code runs after switchover.
|
||||
when (v0 /= switchoverValue) $ liftIO $ triggerChangeBySetValue switchoverValue
|
||||
-- The user could have altered the value before switchover. This must be
|
||||
-- triggered after the setValue one in order for the events to be in the
|
||||
-- correct order.
|
||||
liftJSM getValue >>= \realValue -> when (realValue /= switchoverValue) $ liftIO $ triggerChangeByUI realValue
|
||||
-- Watch for user interaction and trigger event accordingly
|
||||
requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
|
||||
for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->
|
||||
@ -962,19 +961,17 @@ inputElementInternal cfg = getHydrationMode >>= \case
|
||||
]
|
||||
liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
|
||||
requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
|
||||
-- Fire the appropriate events if the checked state has changed somehow
|
||||
liftJSM (Input.getChecked domInputElement) >>= \realChecked -> liftIO $ if
|
||||
-- The user could have clicked the checkbox before switchover, we only
|
||||
-- detect cases where they flipped the state
|
||||
| realChecked /= switchoverChecked -> triggerCheckedChangedByUI realChecked
|
||||
-- When the checked state has been updated by setChecked before
|
||||
-- switchover, but the user hasn't changed the state, we must send an
|
||||
-- update here to remain in sync. This is because the later
|
||||
-- requestDomAction based on the setChecked event will not capture
|
||||
-- events happening before postBuild, because this code runs after
|
||||
-- switchover.
|
||||
| c0 /= switchoverChecked -> triggerCheckedChangedBySetChecked switchoverChecked
|
||||
| otherwise -> pure ()
|
||||
-- When the checked state has been updated by setChecked before
|
||||
-- switchover, we must send an update here to remain in sync. This is
|
||||
-- because the later requestDomAction based on the setChecked event will not
|
||||
-- capture events happening before postBuild, because this code runs after
|
||||
-- switchover.
|
||||
when (c0 /= switchoverChecked) $ liftIO $ triggerCheckedChangedBySetChecked switchoverChecked
|
||||
-- The user could have clicked the checkbox before switchover, we only
|
||||
-- detect cases where they flipped the state. This must be triggered after
|
||||
-- the setValue one in order for the events to be in the correct order.
|
||||
liftJSM (Input.getChecked domInputElement) >>= \realChecked -> when (realChecked /= switchoverChecked) $
|
||||
liftIO $ triggerCheckedChangedByUI realChecked
|
||||
_ <- liftJSM $ domInputElement `on` Events.click $ do
|
||||
liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement
|
||||
for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->
|
||||
@ -1059,14 +1056,21 @@ textAreaElementInternal cfg = getHydrationMode >>= \case
|
||||
doc <- askDocument
|
||||
-- Expected initial value from config
|
||||
let v0 = _textAreaElementConfig_initialValue cfg
|
||||
addHydrationStep $ do
|
||||
valueAtSwitchover = maybe (pure $ pure v0) (hold v0) (_textAreaElementConfig_setValue cfg)
|
||||
addHydrationStepWithSetup valueAtSwitchover $ \switchoverValue' -> do
|
||||
switchoverValue <- sample switchoverValue'
|
||||
domElement <- liftIO $ readIORef domElementRef
|
||||
let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
|
||||
getValue = TextArea.getValue domTextAreaElement
|
||||
-- The browser might have messed with the value, or the user could have
|
||||
-- altered it before activation, so we set it if it isn't what we expect
|
||||
liftJSM getValue >>= \v0' -> do
|
||||
when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
|
||||
-- When the value has been updated by setValue before switchover, we must
|
||||
-- send an update here to remain in sync. This is because the later
|
||||
-- requestDomAction based on the setValue event will not capture events
|
||||
-- happening before postBuild, because this code runs after switchover.
|
||||
when (v0 /= switchoverValue) $ liftIO $ triggerChangeBySetValue switchoverValue
|
||||
-- The user could have altered the value before switchover. This must be
|
||||
-- triggered after the setValue one in order for the events to be in the
|
||||
-- correct order.
|
||||
liftJSM getValue >>= \realValue -> when (realValue /= switchoverValue) $ liftIO $ triggerChangeByUI realValue
|
||||
-- Watch for user interaction and trigger event accordingly
|
||||
requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
|
||||
for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->
|
||||
|
||||
@ -328,16 +328,16 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
|
||||
& elementConfig_initialAttributes %~ setInitialValue . setInitialChecked
|
||||
& elementConfig_modifyAttributes %~ setUpdatedValue . setUpdatedChecked
|
||||
(e, _result) <- element "input" adjustedConfig $ return ()
|
||||
v0 <- case _inputElementConfig_setValue cfg of
|
||||
v <- case _inputElementConfig_setValue cfg of
|
||||
Nothing -> pure $ constDyn (cfg ^. inputElementConfig_initialValue)
|
||||
Just e -> holdDyn (cfg ^. inputElementConfig_initialValue) e
|
||||
c0 <- case _inputElementConfig_setChecked cfg of
|
||||
Just ev -> holdDyn (cfg ^. inputElementConfig_initialValue) ev
|
||||
c <- case _inputElementConfig_setChecked cfg of
|
||||
Nothing -> pure $ constDyn $ _inputElementConfig_initialChecked cfg
|
||||
Just e -> holdDyn (_inputElementConfig_initialChecked cfg) e
|
||||
Just ev -> holdDyn (_inputElementConfig_initialChecked cfg) ev
|
||||
let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
|
||||
return $ InputElement
|
||||
{ _inputElement_value = v0
|
||||
, _inputElement_checked = c0
|
||||
{ _inputElement_value = v
|
||||
, _inputElement_checked = c
|
||||
, _inputElement_checkedChange = never
|
||||
, _inputElement_input = never
|
||||
, _inputElement_hasFocus = hasFocus
|
||||
@ -352,10 +352,12 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
|
||||
void $ textNode $ def
|
||||
& textNodeConfig_initialContents .~ _textAreaElementConfig_initialValue cfg
|
||||
& textNodeConfig_setContents .~ fromMaybe never (_textAreaElementConfig_setValue cfg)
|
||||
let v0 = constDyn $ cfg ^. textAreaElementConfig_initialValue
|
||||
v <- case _textAreaElementConfig_setValue cfg of
|
||||
Nothing -> pure $ constDyn (cfg ^. textAreaElementConfig_initialValue)
|
||||
Just ev -> holdDyn (cfg ^. textAreaElementConfig_initialValue) ev
|
||||
let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
|
||||
return $ TextAreaElement
|
||||
{ _textAreaElement_value = v0
|
||||
{ _textAreaElement_value = v
|
||||
, _textAreaElement_input = never
|
||||
, _textAreaElement_hasFocus = hasFocus
|
||||
, _textAreaElement_element = e
|
||||
|
||||
@ -64,23 +64,24 @@ mainHydrationWidgetWithHead = mainHydrationWidgetWithHead'
|
||||
{-# INLINABLE mainHydrationWidgetWithHead' #-}
|
||||
-- | Warning: `mainHydrationWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.
|
||||
mainHydrationWidgetWithHead' :: HydrationWidget () () -> HydrationWidget () () -> JSM ()
|
||||
mainHydrationWidgetWithHead' = mainHydrationWidgetWithSwitchoverAction' (pure ())
|
||||
mainHydrationWidgetWithHead' = mainHydrationWidgetWithSwitchoverAction' (pure ()) (pure ())
|
||||
|
||||
{-# INLINE mainHydrationWidgetWithSwitchoverAction #-}
|
||||
mainHydrationWidgetWithSwitchoverAction :: JSM () -> (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()
|
||||
mainHydrationWidgetWithSwitchoverAction :: IO () -> JSM () -> (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()
|
||||
mainHydrationWidgetWithSwitchoverAction = mainHydrationWidgetWithSwitchoverAction'
|
||||
|
||||
{-# INLINABLE mainHydrationWidgetWithSwitchoverAction' #-}
|
||||
-- | Warning: `mainHydrationWidgetWithSwitchoverAction'` is provided only as performance tweak. It is expected to disappear in future releases.
|
||||
mainHydrationWidgetWithSwitchoverAction' :: JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()
|
||||
mainHydrationWidgetWithSwitchoverAction' switchoverAction head' body = do
|
||||
runHydrationWidgetWithHeadAndBody switchoverAction $ \appendHead appendBody -> do
|
||||
mainHydrationWidgetWithSwitchoverAction' :: IO () -> JSM () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()
|
||||
mainHydrationWidgetWithSwitchoverAction' onFailure switchoverAction head' body = do
|
||||
runHydrationWidgetWithHeadAndBody onFailure switchoverAction $ \appendHead appendBody -> do
|
||||
appendHead head'
|
||||
appendBody body
|
||||
|
||||
{-# INLINABLE attachHydrationWidget #-}
|
||||
attachHydrationWidget
|
||||
:: JSM ()
|
||||
:: IO ()
|
||||
-> JSM ()
|
||||
-> JSContextSingleton ()
|
||||
-> ( Event DomTimeline ()
|
||||
-> IORef HydrationMode
|
||||
@ -89,7 +90,7 @@ attachHydrationWidget
|
||||
-> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))
|
||||
)
|
||||
-> IO (a, FireCommand DomTimeline DomHost)
|
||||
attachHydrationWidget switchoverAction jsSing w = do
|
||||
attachHydrationWidget onFailure switchoverAction jsSing w = do
|
||||
hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating
|
||||
rootNodesRef <- liftIO $ newIORef []
|
||||
events <- newChan
|
||||
@ -105,7 +106,7 @@ attachHydrationWidget switchoverAction jsSing w = do
|
||||
rootNodes <- liftIO $ readIORef rootNodesRef
|
||||
let delayedAction = do
|
||||
for_ (reverse rootNodes) $ \(rootNode, runner) -> do
|
||||
let hydrate = runHydrationRunnerT runner Nothing rootNode events
|
||||
let hydrate = runHydrationRunnerT runner onFailure Nothing rootNode events
|
||||
void $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing
|
||||
liftIO $ writeIORef hydrationMode HydrationMode_Immediate
|
||||
runWithJSContextSingleton (DOM.liftJSM switchoverAction) jsSing
|
||||
@ -120,17 +121,18 @@ type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (Perform
|
||||
|
||||
{-# INLINABLE runHydrationWidgetWithHeadAndBody #-}
|
||||
runHydrationWidgetWithHeadAndBody
|
||||
:: JSM ()
|
||||
:: IO ()
|
||||
-> JSM ()
|
||||
-> ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head" --TODO: test invoking this more than once
|
||||
-> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body" --TODO: test invoking this more than once
|
||||
-> FloatingWidget () ()
|
||||
)
|
||||
-> JSM ()
|
||||
runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonMono $ \jsSing -> do
|
||||
runHydrationWidgetWithHeadAndBody onFailure switchoverAction app = withJSContextSingletonMono $ \jsSing -> do
|
||||
globalDoc <- currentDocumentUnchecked
|
||||
headElement <- getHeadUnchecked globalDoc
|
||||
bodyElement <- getBodyUnchecked globalDoc
|
||||
(events, fc) <- liftIO . attachHydrationWidget switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do
|
||||
(events, fc) <- liftIO . attachHydrationWidget onFailure switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do
|
||||
(postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
|
||||
let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c
|
||||
hydrateDom n w = do
|
||||
|
||||
@ -161,9 +161,9 @@ tests withDebugging wdConfig caps _selenium = do
|
||||
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 = testWidgetDebug True withDebugging
|
||||
testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
|
||||
testWidget' = testWidgetDebug' withDebugging
|
||||
testWidget' = testWidgetDebug' True withDebugging
|
||||
describe "text" $ session' $ do
|
||||
it "works" $ runWD $ do
|
||||
testWidgetStatic (checkBodyText "hello world") $ do
|
||||
@ -313,6 +313,40 @@ tests withDebugging wdConfig caps _selenium = do
|
||||
& 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" $ session' $ do
|
||||
it "doesn't wipe user input when switching over" $ runWD $ do
|
||||
inputRef <- newRef ("hello " :: Text)
|
||||
@ -383,24 +417,49 @@ tests withDebugging wdConfig caps _selenium = do
|
||||
checkedByUIRef <- newRef False
|
||||
checkedRef <- newRef False
|
||||
setCheckedChan <- liftIO newChan
|
||||
let checkValue = do
|
||||
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
|
||||
e <- findElemWithRetry $ WD.ByTag "input"
|
||||
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
|
||||
testWidget (pure ()) checkValue $ do
|
||||
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
|
||||
@ -416,6 +475,116 @@ tests withDebugging wdConfig caps _selenium = do
|
||||
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" $ session' $ do
|
||||
it "captures user input after switchover" $ runWD $ do
|
||||
@ -587,6 +756,88 @@ tests withDebugging wdConfig caps _selenium = do
|
||||
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" $ session' $ do
|
||||
it "captures user input after switchover" $ runWD $ do
|
||||
@ -1008,7 +1259,9 @@ tests withDebugging wdConfig caps _selenium = do
|
||||
_ <- 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
|
||||
it "ignores missing ending bracketing comments" $ runWD $ do
|
||||
-- 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
|
||||
@ -1338,7 +1591,8 @@ tests withDebugging wdConfig caps _selenium = do
|
||||
shouldContainText "before\ninner\nafter" p1
|
||||
elementShouldBeRemoved ol
|
||||
elementShouldBeRemoved p2
|
||||
testWidget' preSwitchover check $ do
|
||||
-- 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
|
||||
@ -1464,11 +1718,12 @@ testWidgetStaticDebug
|
||||
-> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
|
||||
-- ^ Widget we are testing
|
||||
-> WD b
|
||||
testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
|
||||
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
|
||||
@ -1476,12 +1731,16 @@ testWidgetDebug
|
||||
-> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
|
||||
-- ^ Widget we are testing
|
||||
-> WD b
|
||||
testWidgetDebug withDebugging beforeJS afterSwitchover =
|
||||
testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
|
||||
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)
|
||||
@ -1489,7 +1748,7 @@ testWidgetDebug'
|
||||
-> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
|
||||
-- ^ Widget we are testing (contents of body)
|
||||
-> WD b
|
||||
testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
|
||||
testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
|
||||
let putStrLnDebug :: MonadIO m => Text -> m ()
|
||||
putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
|
||||
staticApp = do
|
||||
@ -1501,6 +1760,7 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
|
||||
((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
|
||||
putStrLnDebug "rendered static"
|
||||
waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
|
||||
onFailure <- if hardFailure then (\tid -> throwTo tid HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
|
||||
waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
|
||||
let entryPoint = do
|
||||
putStrLnDebug "taking waitBeforeJS"
|
||||
@ -1512,7 +1772,7 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
|
||||
liftIO $ putMVar waitUntilSwitchover ()
|
||||
putStrLnDebug "put waitUntilSwitchover"
|
||||
putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
|
||||
mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
|
||||
mainHydrationWidgetWithSwitchoverAction onFailure switchOverAction blank bodyWidget
|
||||
putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
|
||||
syncPoint
|
||||
application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user