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

…lace-comment

Fix hydration runWithReplace when beginning marker can't be found

reflex-dom-core/ChangeLog.md

@@ -17,6 +17,8 @@
    * `tabDisplay`
    * `tableDynAttr`
 
+* Fix bug in hydration when dealing with unexpected HTML ([#361](https://github.com/reflex-frp/reflex-dom/pull/361)).
+
 ## 0.5.3
 
 * Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:

reflex-dom-core/reflex-dom-core.cabal

@@ -166,6 +166,7 @@ test-suite hlint
 test-suite hydration
   build-depends: base
                , aeson
+               , async
                , bytestring
                , chrome-test-utils
                , constraints

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs

@@ -1272,52 +1272,59 @@ hydrateComment doc t mSetContents = do
 skipToAndReplaceComment
   :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
   => Text
-  -> IORef Text
-  -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
+  -> IORef (Maybe Text)
+  -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))
 skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
   HydrationMode_Immediate -> do
     -- If we're in immediate mode, we don't try to replace an existing comment,
     -- and just return a dummy key
     t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
     append $ toNode t
     textNodeRef <- liftIO $ newIORef t
-    keyRef <- liftIO $ newIORef ""
+    keyRef <- liftIO $ newIORef Nothing
     pure (pure (), textNodeRef, keyRef)
   HydrationMode_Hydrating -> do
     doc <- askDocument
     textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
     keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
-    let go key0 mLastNode = do
-          parent <- askParent
-          node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
-          DOM.castTo DOM.Comment node >>= \case
+    let
+      go Nothing _ = do
+        tn <- createTextNode doc ("" :: Text)
+        insertAfterPreviousNode tn
+        HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
+        pure (tn, Nothing)
+      go (Just key0) mLastNode = do
+        parent <- askParent
+        maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
+          Nothing -> go Nothing Nothing
+          Just node -> DOM.castTo DOM.Comment node >>= \case
             Just comment -> do
-              commentText <- Node.getTextContentUnchecked comment
-              case T.stripPrefix (prefix <> key0) commentText of
+              commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment
+              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.
                 Just key -> do
                   -- Replace the comment with an (invisible) text node
                   tn <- createTextNode doc ("" :: Text)
                   Node.replaceChild_ parent tn comment
-                  pure (tn, key)
+                  pure (tn, Just key)
                 Nothing -> do
-                  go key0 (Just node)
+                  go (Just key0) (Just node)
             Nothing -> do
-              go key0 (Just node)
-        switchComment = do
-          key0 <- liftIO $ readIORef key0Ref
-          (tn, key) <- go key0 =<< getPreviousNode
-          setPreviousNode $ Just $ toNode tn
-          liftIO $ do
-            writeIORef textNodeRef tn
-            writeIORef keyRef key
+              go (Just key0) (Just node)
+      switchComment = do
+        key0 <- liftIO $ readIORef key0Ref
+        (tn, key) <- go key0 =<< getPreviousNode
+        setPreviousNode $ Just $ toNode tn
+        liftIO $ do
+          writeIORef textNodeRef tn
+          writeIORef keyRef key
     pure (switchComment, textNodeRef, keyRef)
 
 {-# INLINABLE skipToReplaceStart #-}
-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)
-skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
+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))
+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work.
 
 {-# INLINABLE skipToReplaceEnd #-}
-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)
+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)
 skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
 
 instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where

reflex-dom-core/src/Reflex/Dom/Builder/Static.hs

@@ -55,7 +55,6 @@ import Reflex.PerformEvent.Class
 import Reflex.PostBuild.Base
 import Reflex.PostBuild.Class
 import Reflex.TriggerEvent.Class
-import System.Random (randomRIO)
 
 data StaticDomBuilderEnv t = StaticDomBuilderEnv
   { _staticDomBuilderEnv_shouldEscape :: Bool
@@ -64,6 +63,7 @@ data StaticDomBuilderEnv t = StaticDomBuilderEnv
     -- We use this to add a "selected" attribute to the appropriate "option" child element.
     -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing.
     -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.
+  , _staticDomBuilderEnv_nextRunWithReplaceKey :: IORef Int
   }
 
 newtype StaticDomBuilderT t m a = StaticDomBuilderT
@@ -164,7 +164,7 @@ instance (SupportsStaticDomBuilder t m, Monad m) => HasDocument (StaticDomBuilde
 instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where
   runWithReplace a0 a' = do
     e <- StaticDomBuilderT ask
-    key <- replaceStart
+    key <- replaceStart e
     (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')
     o <- hold (snd result0) $ fmapCheap snd result'
     StaticDomBuilderT $ modify $ (:) $ join o
@@ -174,10 +174,9 @@ instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m)
   traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap
   traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
 
--- TODO remove this?
-replaceStart :: (DomBuilder t m, MonadIO m) => m Text
-replaceStart = do
-  str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')
+replaceStart :: (DomBuilder t m, MonadIO m) => StaticDomBuilderEnv t -> m Text
+replaceStart env = do
+  str <- show <$> liftIO (atomicModifyRef (_staticDomBuilderEnv_nextRunWithReplaceKey env) $ \k -> (succ k, k))
   let key = "-" <> T.pack str
   _ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key }
   pure key
@@ -287,7 +286,8 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
     es <- newFanEventWithTrigger $ \_ _ -> return (return ())
     StaticDomBuilderT $ do
       let shouldEscape = elementTag `Set.notMember` noEscapeElements
-      (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing
+      nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey
+      (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing nextRunWithReplaceKey
       attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
       selectValue <- asks _staticDomBuilderEnv_selectValue
       let addSelectedAttr attrs sel = case Map.lookup "value" attrs of
@@ -341,7 +341,9 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
   selectElement cfg child = do
     v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)
     (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do
-      (a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False $ Just (current v)
+      (a, innerHtml) <- StaticDomBuilderT $ do
+        nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey
+        lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False (Just $ current v) nextRunWithReplaceKey
       StaticDomBuilderT $ lift $ modify $ (:) innerHtml
       return a
     let wrapped = SelectElement
@@ -363,7 +365,8 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)
 renderStatic w = do
   runDomHost $ do
     (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
-    let env0 = StaticDomBuilderEnv True Nothing
+    nextRunWithReplaceKey <- newRef 0
+    let env0 = StaticDomBuilderEnv True Nothing nextRunWithReplaceKey
     ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
     mPostBuildTrigger <- readRef postBuildTriggerRef
     forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

reflex-dom-core/test/hydration.hs

@@ -1,27 +1,28 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 import Prelude hiding (fail)
 import Control.Concurrent
+import qualified Control.Concurrent.Async as Async
 import Control.Lens.Operators
 import Control.Monad hiding (fail)
 import Control.Monad.Catch
@@ -32,7 +33,7 @@ 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.Dependent.Sum (DSum(..), (==>))
 import Data.Functor.Identity
 import Data.Functor.Misc
 import Data.GADT.Compare.TH
@@ -63,7 +64,6 @@ 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 Test.WebDriver.Exceptions (ServerError(..))
 
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Dependent.Map as DMap
@@ -79,6 +79,9 @@ import qualified Test.WebDriver.Capabilities as WD
 import Test.Util.ChromeFlags
 import Test.Util.UnshareNetwork
 
+-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
+deriving instance MonadMask WD
+
 chromium :: FilePath
 chromium = $(staticWhich "chromium")
 
@@ -924,6 +927,58 @@ tests withDebugging wdConfig caps _selenium = do
             , el "span" . text <$> replace
             ]
 
+    let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)
+    it "removes bracketing comments" $ runWD $ do
+      replaceChan :: Chan () <- liftIO newChan
+      let
+        preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
+        check () = do
+          liftIO $ writeChan replaceChan () -- trigger creation of p tag
+          _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
+          checkInnerHtml "div" "before|<p>inner2</p>|after"
+      testWidget' preSwitchover check $ do
+        replace <- triggerEventWithChan replaceChan
+        el "div" $ do
+          text "before|"
+          _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
+          text "|after"
+    it "ignores extra ending bracketing comment" $ runWD $ do
+      replaceChan :: Chan () <- liftIO newChan
+      let
+        preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"
+        check () = do
+          liftIO $ writeChan replaceChan () -- trigger creation of p tag
+          _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
+          checkInnerHtml "div" "before|inner2|after"
+      testWidget' preSwitchover check $ do
+        replace <- triggerEventWithChan replaceChan
+        el "div" $ do
+          text "before|"
+          _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
+          text "|after"
+        void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
+    it "ignores missing ending bracketing comments" $ runWD $ do
+      replaceChan :: Chan () <- liftIO newChan
+      let
+        preSwitchover = do
+          checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
+          divEl <- findElemWithRetry (WD.ByTag "div")
+          let wrongHtml = "<!--replace-start-0-->inner1"
+          actualHtml :: String <- WD.executeJS
+            [WD.JSArg divEl, WD.JSArg wrongHtml]
+            "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"
+          actualHtml `shouldBe` wrongHtml
+        check () = do
+          liftIO $ writeChan replaceChan () -- trigger creation of p tag
+          _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
+          checkInnerHtml "div" "before|<p>inner2</p>|after"
+      testWidget' preSwitchover check $ do
+        replace <- triggerEventWithChan replaceChan
+        el "div" $ do
+          text "before|"
+          _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
+          text "|after"
+
   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
@@ -1315,8 +1370,8 @@ withRetry a = wait 300
   where wait :: Int -> WD a
         wait 0 = a
         wait n = try a >>= \case
-          Left (_ :: SomeException) -> do
-            liftIO $ threadDelay 100000
+          Left (e :: SomeException) -> do
+            liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
             wait $ n - 1
           Right v -> return v
 
@@ -1398,23 +1453,26 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
         ]
       -- 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
+      jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
+  withAsync' jsaddleWarp $ do
+    putStrLnDebug "taking waitJSaddle"
+    liftIO $ takeMVar waitJSaddle
+    putStrLnDebug "opening page"
+    WD.openPage $ "http://localhost:" <> show jsaddlePort
+    putStrLnDebug "running beforeJS"
+    a <- beforeJS
+    putStrLnDebug "putting waitBeforeJS"
+    liftIO $ putMVar waitBeforeJS ()
+    putStrLnDebug "taking waitUntilSwitchover"
+    liftIO $ takeMVar waitUntilSwitchover
+    putStrLnDebug "running afterSwitchover"
+    afterSwitchover a
+
+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
+withAsync' f g = bracket
+  (liftIO $ Async.async f)
+  (liftIO . Async.uninterruptibleCancel)
+  (const g)
 
 data Key2 a where
   Key2_Int :: Int -> Key2 Int