f11eba4 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Merge pull request #361 from reflex-frp/eac@fix-hydration-skip-to-replace-comment

Fix hydration runWithReplace when beginning marker can't be found

commitf11eba42f08333db67acb61804c178afb64a3bb3 authorElliot Cameron <3noch@users.noreply.github.com> dateMon 9 Mar 2020, 12:19 (7 years ago) parent7439e26 2d7241c

5 files changed+128−57

compare with develop

unifiedsplit

reflex-dom-core/ChangeLog.md+2 reflex-dom-core/reflex-dom-core.cabal+1 reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+29−22 reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+12−9 reflex-dom-core/test/hydration.hs+84−26

reflex-dom-core/ChangeLog.md+2

@@ -17,6 +17,8 @@

1717 * `tabDisplay`

1818 * `tableDynAttr`

1919

20+* Fix bug in hydration when dealing with unexpected HTML ([#361](https://github.com/reflex-frp/reflex-dom/pull/361)).

21+

2022## 0.5.3

2123

2224* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:

reflex-dom-core/reflex-dom-core.cabal+1

@@ -166,6 +166,7 @@ test-suite hlint

166166test-suite hydration

167167 build-depends: base

168168 , aeson

169+ , async

169170 , bytestring

170171 , chrome-test-utils

171172 , constraints

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+29−22

@@ -1272,8 +1272,8 @@ hydrateComment doc t mSetContents = do

12721272skipToAndReplaceComment

12731273 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)

12741274 => Text

1275− -> IORef Text

1276− -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)

1275+ -> IORef (Maybe Text)

1276+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))

12771277skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

12781278 HydrationMode_Immediate -> do

12791279 -- If we're in immediate mode, we don't try to replace an existing comment,

@@ -1281,43 +1281,50 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

12811281 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing

12821282 append $ toNode t

12831283 textNodeRef <- liftIO $ newIORef t

1284− keyRef <- liftIO $ newIORef ""

1284+ keyRef <- liftIO $ newIORef Nothing

12851285 pure (pure (), textNodeRef, keyRef)

12861286 HydrationMode_Hydrating -> do

12871287 doc <- askDocument

12881288 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"

12891289 keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"

1290− let go key0 mLastNode = do

1291− parent <- askParent

1292− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

1293− DOM.castTo DOM.Comment node >>= \case

1290+ let

1291+ go Nothing _ = do

1292+ tn <- createTextNode doc ("" :: Text)

1293+ insertAfterPreviousNode tn

1294+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }

1295+ pure (tn, Nothing)

1296+ go (Just key0) mLastNode = do

1297+ parent <- askParent

1298+ maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case

1299+ Nothing -> go Nothing Nothing

1300+ Just node -> DOM.castTo DOM.Comment node >>= \case

12941301 Just comment -> do

1295− commentText <- Node.getTextContentUnchecked comment

1296− case T.stripPrefix (prefix <> key0) commentText of

1302+ commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment

1303+ case T.stripPrefix (prefix <> key0) commentText of -- 'key0' may be @""@ in which case we're just finding the actual key; TODO: Don't be clever.

12971304 Just key -> do

12981305 -- Replace the comment with an (invisible) text node

12991306 tn <- createTextNode doc ("" :: Text)

13001307 Node.replaceChild_ parent tn comment

1301− pure (tn, key)

1308+ pure (tn, Just key)

13021309 Nothing -> do

1303− go key0 (Just node)

1310+ go (Just key0) (Just node)

13041311 Nothing -> do

1305− go key0 (Just node)

1306− switchComment = do

1307− key0 <- liftIO $ readIORef key0Ref

1308− (tn, key) <- go key0 =<< getPreviousNode

1309− setPreviousNode $ Just $ toNode tn

1310− liftIO $ do

1311− writeIORef textNodeRef tn

1312− writeIORef keyRef key

1312+ go (Just key0) (Just node)

1313+ switchComment = do

1314+ key0 <- liftIO $ readIORef key0Ref

1315+ (tn, key) <- go key0 =<< getPreviousNode

1316+ setPreviousNode $ Just $ toNode tn

1317+ liftIO $ do

1318+ writeIORef textNodeRef tn

1319+ writeIORef keyRef key

13131320 pure (switchComment, textNodeRef, keyRef)

13141321

13151322{-# INLINABLE skipToReplaceStart #-}

1316−skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)

1317−skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")

1323+skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))

1324+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work.

13181325

13191326{-# INLINABLE skipToReplaceEnd #-}

1320−skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef Text -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)

1327+skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef (Maybe Text) -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)

13211328skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key

13221329

13231330instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where

reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+12−9

@@ -55,7 +55,6 @@ import Reflex.PerformEvent.Class

5555import Reflex.PostBuild.Base

5656import Reflex.PostBuild.Class

5757import Reflex.TriggerEvent.Class

58−import System.Random (randomRIO)

5958

6059data StaticDomBuilderEnv t = StaticDomBuilderEnv

6160 { _staticDomBuilderEnv_shouldEscape :: Bool

@@ -64,6 +63,7 @@ data StaticDomBuilderEnv t = StaticDomBuilderEnv

6463 -- We use this to add a "selected" attribute to the appropriate "option" child element.

6564 -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing.

6665 -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.

66+ , _staticDomBuilderEnv_nextRunWithReplaceKey :: IORef Int

6767 }

6868

6969newtype StaticDomBuilderT t m a = StaticDomBuilderT

@@ -164,7 +164,7 @@ instance (SupportsStaticDomBuilder t m, Monad m) => HasDocument (StaticDomBuilde

164164instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where

165165 runWithReplace a0 a' = do

166166 e <- StaticDomBuilderT ask

167− key <- replaceStart

167+ key <- replaceStart e

168168 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')

169169 o <- hold (snd result0) $ fmapCheap snd result'

170170 StaticDomBuilderT $ modify $ (:) $ join o

@@ -174,10 +174,9 @@ instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m)

174174 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap

175175 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

176176

177−-- TODO remove this?

178−replaceStart :: (DomBuilder t m, MonadIO m) => m Text

179−replaceStart = do

180− str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')

177+replaceStart :: (DomBuilder t m, MonadIO m) => StaticDomBuilderEnv t -> m Text

178+replaceStart env = do

179+ str <- show <$> liftIO (atomicModifyRef (_staticDomBuilderEnv_nextRunWithReplaceKey env) $ \k -> (succ k, k))

181180 let key = "-" <> T.pack str

182181 _ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key }

183182 pure key

@@ -287,7 +286,8 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

287286 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

288287 StaticDomBuilderT $ do

289288 let shouldEscape = elementTag `Set.notMember` noEscapeElements

290− (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing

289+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey

290+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing nextRunWithReplaceKey

291291 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)

292292 selectValue <- asks _staticDomBuilderEnv_selectValue

293293 let addSelectedAttr attrs sel = case Map.lookup "value" attrs of

@@ -341,7 +341,9 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

341341 selectElement cfg child = do

342342 v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)

343343 (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do

344− (a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False $ Just (current v)

344+ (a, innerHtml) <- StaticDomBuilderT $ do

345+ nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey

346+ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False (Just $ current v) nextRunWithReplaceKey

345347 StaticDomBuilderT $ lift $ modify $ (:) innerHtml

346348 return a

347349 let wrapped = SelectElement

@@ -363,7 +365,8 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)

363365renderStatic w = do

364366 runDomHost $ do

365367 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

366− let env0 = StaticDomBuilderEnv True Nothing

368+ nextRunWithReplaceKey <- newRef 0

369+ let env0 = StaticDomBuilderEnv True Nothing nextRunWithReplaceKey

367370 ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0

368371 mPostBuildTrigger <- readRef postBuildTriggerRef

369372 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

reflex-dom-core/test/hydration.hs+84−26

@@ -1,13 +1,9 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

21{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE StandaloneDeriving #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE UndecidableInstances #-}

62{-# LANGUAGE ConstraintKinds #-}

7−{-# LANGUAGE CPP #-}

83{-# LANGUAGE FlexibleContexts #-}

94{-# LANGUAGE FlexibleInstances #-}

105{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

117{-# LANGUAGE LambdaCase #-}

128{-# LANGUAGE MultiParamTypeClasses #-}

139{-# LANGUAGE OverloadedStrings #-}

@@ -15,13 +11,18 @@

1511{-# LANGUAGE RankNTypes #-}

1612{-# LANGUAGE RecursiveDo #-}

1713{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE StandaloneDeriving #-}

1815{-# LANGUAGE TemplateHaskell #-}

1916{-# LANGUAGE TupleSections #-}

2017{-# LANGUAGE TypeApplications #-}

2118{-# LANGUAGE TypeFamilies #-}

19+{-# LANGUAGE UndecidableInstances #-}

20+

21+{-# OPTIONS_GHC -fno-warn-orphans #-}

2222

2323import Prelude hiding (fail)

2424import Control.Concurrent

25+import qualified Control.Concurrent.Async as Async

2526import Control.Lens.Operators

2627import Control.Monad hiding (fail)

2728import Control.Monad.Catch

@@ -32,7 +33,7 @@ import Control.Monad.Ref

3233import Data.Constraint.Extras

3334import Data.Constraint.Extras.TH

3435import Data.Dependent.Map (DMap)

35−import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))

36+import Data.Dependent.Sum (DSum(..), (==>))

3637import Data.Functor.Identity

3738import Data.Functor.Misc

3839import Data.GADT.Compare.TH

@@ -63,7 +64,6 @@ import Test.Hspec (xit)

6364import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)

6465import qualified Test.Hspec.WebDriver as WD

6566import Test.WebDriver (WD(..))

66−import Test.WebDriver.Exceptions (ServerError(..))

6767

6868import qualified Data.ByteString.Lazy as LBS

6969import qualified Data.Dependent.Map as DMap

@@ -79,6 +79,9 @@ import qualified Test.WebDriver.Capabilities as WD

7979import Test.Util.ChromeFlags

8080import Test.Util.UnshareNetwork

8181

82+-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167

83+deriving instance MonadMask WD

84+

8285chromium :: FilePath

8386chromium = $(staticWhich "chromium")

8487

@@ -924,6 +927,58 @@ tests withDebugging wdConfig caps _selenium = do

924927 , el "span" . text <$> replace

925928 ]

926929

930+ let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)

931+ it "removes bracketing comments" $ runWD $ do

932+ replaceChan :: Chan () <- liftIO newChan

933+ let

934+ preSwitchover = checkInnerHtml "div" "before|inner1|after"

935+ check () = do

936+ liftIO $ writeChan replaceChan () -- trigger creation of p tag

937+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created

938+ checkInnerHtml "div" "before|<p>inner2</p>|after"

939+ testWidget' preSwitchover check $ do

940+ replace <- triggerEventWithChan replaceChan

941+ el "div" $ do

942+ text "before|"

943+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace

944+ text "|after"

945+ it "ignores extra ending bracketing comment" $ runWD $ do

946+ replaceChan :: Chan () <- liftIO newChan

947+ let

948+ preSwitchover = checkInnerHtml "div" "before|inner1|after"

949+ check () = do

950+ liftIO $ writeChan replaceChan () -- trigger creation of p tag

951+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created

952+ checkInnerHtml "div" "before|inner2|after"

953+ testWidget' preSwitchover check $ do

954+ replace <- triggerEventWithChan replaceChan

955+ el "div" $ do

956+ text "before|"

957+ _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace

958+ text "|after"

959+ void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test

960+ it "ignores missing ending bracketing comments" $ runWD $ do

961+ replaceChan :: Chan () <- liftIO newChan

962+ let

963+ preSwitchover = do

964+ checkInnerHtml "div" "before|inner1|after"

965+ divEl <- findElemWithRetry (WD.ByTag "div")

966+ let wrongHtml = "inner1"

967+ actualHtml :: String <- WD.executeJS

968+ [WD.JSArg divEl, WD.JSArg wrongHtml]

969+ "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"

970+ actualHtml `shouldBe` wrongHtml

971+ check () = do

972+ liftIO $ writeChan replaceChan () -- trigger creation of p tag

973+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created

974+ checkInnerHtml "div" "before|<p>inner2</p>|after"

975+ testWidget' preSwitchover check $ do

976+ replace <- triggerEventWithChan replaceChan

977+ el "div" $ do

978+ text "before|"

979+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace

980+ text "|after"

981+

927982 describe "traverseDMapWithKeyWithAdjust" $ session' $ do

928983 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)

929984 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do

@@ -1315,8 +1370,8 @@ withRetry a = wait 300

13151370 where wait :: Int -> WD a

13161371 wait 0 = a

13171372 wait n = try a >>= \case

1318− Left (_ :: SomeException) -> do

1319− liftIO $ threadDelay 100000

1373+ Left (e :: SomeException) -> do

1374+ liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000

13201375 wait $ n - 1

13211376 Right v -> return v

13221377

@@ -1398,23 +1453,26 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do

13981453 ]

13991454 -- hSilence to get rid of ConnectionClosed logs

14001455 silenceIfDebug = if withDebugging then id else hSilence [stderr]

1401− jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application

1402− jsaddleTid <- liftIO jsaddleWarp

1403− putStrLnDebug "taking waitJSaddle"

1404− liftIO $ takeMVar waitJSaddle

1405− putStrLnDebug "opening page"

1406− WD.openPage $ "http://localhost:" <> show jsaddlePort

1407− putStrLnDebug "running beforeJS"

1408− a <- beforeJS

1409− putStrLnDebug "putting waitBeforeJS"

1410− liftIO $ putMVar waitBeforeJS ()

1411− putStrLnDebug "taking waitUntilSwitchover"

1412− liftIO $ takeMVar waitUntilSwitchover

1413− putStrLnDebug "running afterSwitchover"

1414− b <- afterSwitchover a

1415− putStrLnDebug "killing jsaddle thread"

1416− liftIO $ killThread jsaddleTid

1417− return b

1456+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application

1457+ withAsync' jsaddleWarp $ do

1458+ putStrLnDebug "taking waitJSaddle"

1459+ liftIO $ takeMVar waitJSaddle

1460+ putStrLnDebug "opening page"

1461+ WD.openPage $ "http://localhost:" <> show jsaddlePort

1462+ putStrLnDebug "running beforeJS"

1463+ a <- beforeJS

1464+ putStrLnDebug "putting waitBeforeJS"

1465+ liftIO $ putMVar waitBeforeJS ()

1466+ putStrLnDebug "taking waitUntilSwitchover"

1467+ liftIO $ takeMVar waitUntilSwitchover

1468+ putStrLnDebug "running afterSwitchover"

1469+ afterSwitchover a

1470+

1471+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b

1472+withAsync' f g = bracket

1473+ (liftIO $ Async.async f)

1474+ (liftIO . Async.uninterruptibleCancel)

1475+ (const g)

14181476

14191477data Key2 a where

14201478 Key2_Int :: Int -> Key2 Int