@@ -37,7 +37,6 @@
3737-- In "hydration mode", the preexisting DOM __must contain__ what the builder
3838-- will expect at switchover time (the time at which parity with the static
3939-- renderer is reached, and the time after which the page is "live").
40−-- There can be extra nodes, but no missing or incorrect nodes.
4140--
4241-- For example, displaying the current time as text should be done inside
4342-- 'Reflex.Dom.Prerender.prerender' to ensure that we don't attempt to hydrate the incorrect text.
@@ -52,16 +51,17 @@ module Reflex.Dom.Builder.Immediate
5251 , runHydrationRunnerT
5352 , ImmediateDomBuilderT
5453 , runHydrationDomBuilderT
55−
5654 , getHydrationMode
5755 , addHydrationStep
5856 , addHydrationStepWithSetup
5957 , setPreviousNode
60−
58+ , insertAfterPreviousNode
59+ , hydrateComment
6160 , askParent
6261 , askEvents
6362 , append
6463 , textNodeInternal
64+ , removeSubsequentNodes
6565 , deleteBetweenExclusive
6666 , extractBetweenExclusive
6767 , deleteUpTo
@@ -73,7 +73,6 @@ module Reflex.Dom.Builder.Immediate
7373 , EventFilterTriggerRef (..)
7474 , wrap
7575 , elementInternal
76− , hydrateNode
7776 , HydrationDomSpace
7877 , GhcjsDomSpace
7978 , GhcjsDomHandler (..)
@@ -125,13 +124,13 @@ import Control.Monad.Exception
125124import Control.Monad.Primitive
126125import Control.Monad.Reader
127126import Control.Monad.Ref
128−import Control.Monad.State.Strict (StateT, evalStateT, mapStateT, get, put)
127+import Control.Monad.State.Strict (StateT, mapStateT, get, modify', gets, runStateT)
129128import Data.Bitraversable
130129import Data.Default
131130import Data.Dependent.Map (DMap)
132131import Data.Dependent.Sum
133132import Data.FastMutableIntMap (PatchIntMap (..))
134−import Data.Foldable (for_)
133+import Data.Foldable (for_, traverse_)
135134import Data.Functor.Compose
136135import Data.Functor.Constant
137136import Data.Functor.Misc
@@ -141,7 +140,6 @@ import Data.IntMap.Strict (IntMap)
141140import Data.Maybe
142141import Data.Some (Some(..))
143142import Data.Text (Text)
144−import Data.Typeable (Typeable)
145143import Foreign.JavaScript.Internal.Utils
146144import Foreign.JavaScript.TH
147145import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
@@ -260,22 +258,35 @@ instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT s t m)
260258
261259-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.
262260-- State contains reference to the previous node sibling, if any, and the reader contains reference to the parent node.
263−newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT (Maybe Node) (ReaderT Node (DomRenderHookT t m)) a }
261+newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT HydrationState (ReaderT Node (DomRenderHookT t m)) a }
264262 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
265263#if MIN_VERSION_base(4,9,1)
266264 , MonadAsyncException
267265#endif
268266 )
269267
268+data HydrationState = HydrationState
269+ { _hydrationState_previousNode :: Maybe Node
270+ , _hydrationState_failed :: Bool
271+ }
272+
270273{-# INLINABLE localRunner #-}
271274localRunner :: (MonadJSM m, Monad m) => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a
272−localRunner (HydrationRunnerT m) s parent = HydrationRunnerT . lift $ local (\_ -> parent) (evalStateT m s)
275+localRunner (HydrationRunnerT m) s parent = do
276+ s0 <- HydrationRunnerT get
277+ (a, s') <- HydrationRunnerT $ lift $ local (\_ -> parent) $ runStateT m (s0 { _hydrationState_previousNode = s })
278+ traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
279+ pure a
273280
274281{-# INLINABLE runHydrationRunnerT #-}
275282runHydrationRunnerT
276283 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
277284 => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
278−runHydrationRunnerT (HydrationRunnerT m) s parent = runDomRenderHookT (runReaderT (evalStateT m s) parent)
285+runHydrationRunnerT (HydrationRunnerT m) s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do
286+ (a, s') <- runStateT m (HydrationState s False)
287+ traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
288+ 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."
289+ pure a
279290
280291instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
281292 {-# INLINABLE newEventWithTrigger #-}
@@ -305,7 +316,7 @@ addHydrationStepWithSetup setup f = getHydrationMode >>= \case
305316 HydrationMode_Immediate -> pure ()
306317 HydrationMode_Hydrating -> do
307318 switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
308− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover -- 4% more memory than above
319+ (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
309320 addHydrationStep (f s)
310321
311322-- | Add a hydration step
@@ -409,11 +420,11 @@ data HydrationMode
409420
410421{-# INLINABLE getPreviousNode #-}
411422getPreviousNode :: Monad m => HydrationRunnerT t m (Maybe DOM.Node)
412−getPreviousNode = HydrationRunnerT get
423+getPreviousNode = HydrationRunnerT $ gets _hydrationState_previousNode
413424
414425{-# INLINABLE setPreviousNode #-}
415426setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()
416−setPreviousNode = HydrationRunnerT . put
427+setPreviousNode n = HydrationRunnerT $ modify' (\hs -> hs { _hydrationState_previousNode = n })
417428
418429{-# INLINABLE askUnreadyChildren #-}
419430askUnreadyChildren :: Monad m => HydrationDomBuilderT s t m (IORef Word)
@@ -427,35 +438,11 @@ askCommitAction = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_commitActi
427438getHydrationMode :: MonadIO m => HydrationDomBuilderT s t m HydrationMode
428439getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)
429440
430−{-# INLINE makeNodeInternal #-}
431−makeNodeInternal
432− :: forall node s t m. (MonadJSM m, IsNode node, Typeable node)
433− => HydrationDomBuilderT s t m node -> HydrationDomBuilderT s t m node
434−makeNodeInternal mkNode = do
435− n <- mkNode
436− append $ toNode n
437− return n
438−
439−{-# INLINE hydrateNode #-}
440−-- | This function expects the existing DOM at the current hydration node to be
441−-- correct. It skips any nodes that are the wrong type, or that fail the
442−-- @check@. The previous node reference is also updated.
443−hydrateNode
444− :: (MonadJSM m, IsNode node, Typeable node)
445− => (node -> HydrationRunnerT t m Bool) -> (DOM.JSVal -> node) -> HydrationRunnerT t m node
446−hydrateNode check constructor = do
447− parent <- askParent
448− lastHydrationNode <- getPreviousNode
449− let go mLastNode = do
450− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
451− DOM.castTo constructor node >>= \case
452− Nothing -> go (Just node)
453− Just tn -> check tn >>= \case
454− True -> return tn
455− False -> go (Just node)
456− n <- go lastHydrationNode
457− setPreviousNode $ Just $ toNode n
458− return n
441+-- | Remove all nodes after given node
442+removeSubsequentNodes :: (MonadJSM m, IsNode n) => n -> m ()
443+removeSubsequentNodes n = liftJSM $ do
444+ f <- eval ("(function(n) { while (n.nextSibling) { (n.parentNode).removeChild(n.nextSibling); }; })" :: Text)
445+ void $ call f f [n]
459446
460447-- | s and e must both be children of the same node and s must precede e;
461448-- all nodes between s and e will be removed, but s and e will not be removed
@@ -671,6 +658,16 @@ instance er ~ EventResult => Default (GhcjsEventSpec er) where
671658 runReaderT (defaultDomEventHandler e en) evt
672659 }
673660
661+makeElement :: MonadJSM m => Document -> Text -> ElementConfig er t s -> m DOM.Element
662+makeElement doc elementTag cfg = do
663+ e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
664+ Nothing -> createElement doc elementTag
665+ Just ens -> createElementNS doc (Just ens) elementTag
666+ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
667+ Nothing -> setAttribute e n v
668+ Just ans -> setAttributeNS e (Just ans) n v
669+ pure e
670+
674671{-# INLINE elementImmediate #-}
675672elementImmediate
676673 :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
@@ -683,14 +680,9 @@ elementImmediate elementTag cfg child = do
683680 doc <- askDocument
684681 ctx <- askJSM
685682 events <- askEvents
686− e <- makeNodeInternal . liftJSM $ do
687− e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
688− Nothing -> createElement doc elementTag
689− Just ens -> createElementNS doc (Just ens) elementTag
690− iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
691− Nothing -> setAttribute e n v
692− Just ans -> setAttributeNS e (Just ans) n v
693− pure e
683+ parent <- getParent
684+ e <- makeElement doc elementTag cfg
685+ appendChild_ parent e
694686 -- Run the child builder with updated parent and previous sibling references
695687 result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode e }) child
696688 let rawCfg = extractRawElementConfig cfg
@@ -758,16 +750,16 @@ hydrateElement
758750 -> ElementConfig er t HydrationDomSpace
759751 -> HydrationDomBuilderT HydrationDomSpace t m a
760752 -> HydrationDomBuilderT HydrationDomSpace t m ((Element er HydrationDomSpace t, a), IORef DOM.Element)
761−hydrateElement _elementTag cfg child = do
753+hydrateElement elementTag cfg child = do
762754 ctx <- askJSM
763755 events <- askEvents
764756 -- Schedule everything for after postBuild, except for getting the result itself
765− parent <- liftIO $ newIORef $ error "Parent not yet initialized"
757+ parentRef <- liftIO $ newIORef $ error "Parent not yet initialized"
766758 e' <- liftIO $ newIORef $ error "hydrateElement: Element not yet initialized"
767759 env <- HydrationDomBuilderT ask
768760 childDelayedRef <- liftIO $ newIORef $ pure ()
769761 let env' = env
770− { _hydrationDomBuilderEnv_parent = Right parent
762+ { _hydrationDomBuilderEnv_parent = Right parentRef
771763 , _hydrationDomBuilderEnv_delayed = childDelayedRef
772764 }
773765 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
@@ -779,10 +771,35 @@ hydrateElement _elementTag cfg child = do
779771 Just ns -> hasAttributeNS e (Just ns) ssrAttr <* removeAttributeNS e (Just ns) ssrAttr
780772 childDom <- liftIO $ readIORef childDelayedRef
781773 let rawCfg = extractRawElementConfig cfg
774+ doc <- askDocument
782775 addHydrationStep $ do
783− e <- hydrateNode hasSSRAttribute DOM.Element
776+ parent <- askParent
777+ lastHydrationNode <- getPreviousNode
778+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
779+ Nothing -> do -- ran out of nodes, create the element
780+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
781+ e <- makeElement doc elementTag cfg
782+ insertAfterPreviousNode e
783+ pure e
784+ Just node -> DOM.castTo DOM.Element node >>= \case
785+ Nothing -> go (Just node) -- this node is not an element, skip
786+ Just e -> hasSSRAttribute e >>= \case
787+ False -> go (Just node) -- this element was not added by the static renderer, skip
788+ True -> do
789+ t <- Element.getTagName e
790+ -- TODO: check attributes?
791+ if T.toCaseFold elementTag == T.toCaseFold t
792+ then pure e
793+ -- we came to some other statically rendered element, so something has gone wrong
794+ else do
795+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
796+ n <- makeElement doc elementTag cfg
797+ insertAfterPreviousNode n
798+ pure n
799+ e <- go lastHydrationNode
800+ setPreviousNode $ Just $ toNode e
784801 -- Update the parent node used by the children
785− liftIO $ writeIORef parent $ toNode e
802+ liftIO $ writeIORef parentRef $ toNode e
786803 liftIO $ writeIORef e' e
787804 -- Setup events, store the result so we can wait on it later
788805 refs <- wrap events e rawCfg
@@ -1125,7 +1142,10 @@ textNodeImmediate
11251142 :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)
11261143 => TextNodeConfig t -> HydrationDomBuilderT s t m DOM.Text
11271144textNodeImmediate (TextNodeConfig !t mSetContents) = do
1128− n <- makeNodeInternal (askDocument >>= \doc -> createTextNode doc t)
1145+ p <- getParent
1146+ doc <- askDocument
1147+ n <- createTextNode doc t
1148+ appendChild_ p n
11291149 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
11301150 pure n
11311151
@@ -1144,10 +1164,11 @@ textNodeInternal
11441164 :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t)
11451165 => TextNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (TextNode HydrationDomSpace t)
11461166textNodeInternal tc@(TextNodeConfig !t mSetContents) = do
1167+ doc <- askDocument
11471168 getHydrationMode >>= \case
11481169 HydrationMode_Immediate -> void $ textNodeImmediate tc
11491170 HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t) (hold t) mSetContents) $ \currentText -> do
1150− n <- hydrateTextNode =<< sample currentText
1171+ n <- hydrateTextNode doc =<< sample currentText
11511172 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
11521173 pure $ TextNode ()
11531174
@@ -1161,20 +1182,22 @@ textNodeInternal tc@(TextNodeConfig !t mSetContents) = do
11611182-- expect. We also have a special case for empty text nodes - we always create
11621183-- the and add them after the previous node reference.
11631184{-# INLINE hydrateTextNode #-}
1164−hydrateTextNode :: MonadJSM m => Text -> HydrationRunnerT t m DOM.Text
1165−hydrateTextNode t@"" = do
1166− doc <- Node.getOwnerDocumentUnchecked =<< askParent
1185+hydrateTextNode :: MonadJSM m => Document -> Text -> HydrationRunnerT t m DOM.Text
1186+hydrateTextNode doc t@"" = do
11671187 tn <- createTextNode doc t
11681188 insertAfterPreviousNode tn
11691189 pure tn
1170−hydrateTextNode t = do
1190+hydrateTextNode doc t = do
11711191 n <- join $ go <$> askParent <*> getPreviousNode
11721192 setPreviousNode $ Just $ toNode n
11731193 return n
11741194 where
1175− go parent mLastNode = do
1176− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
1177− DOM.castTo DOM.Text node >>= \case
1195+ go parent mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1196+ Nothing -> do
1197+ n <- createTextNode doc t
1198+ insertAfterPreviousNode n
1199+ pure n
1200+ Just node -> DOM.castTo DOM.Text node >>= \case
11781201 Nothing -> go parent $ Just node
11791202 Just originalNode -> do
11801203 originalText <- Node.getTextContentUnchecked originalNode
@@ -1185,29 +1208,59 @@ hydrateTextNode t = do
11851208 -- required text and a subsequent sibling node containing the rest of the text.
11861209 DOM.splitText_ originalNode $ fromIntegral $ T.length t
11871210 return originalNode
1188− Nothing -> go parent $ Just $ toNode originalNode
1211+ Nothing -> do
1212+ n <- createTextNode doc t
1213+ insertAfterPreviousNode n
1214+ pure n
11891215
11901216{-# INLINE commentNodeImmediate #-}
11911217commentNodeImmediate
11921218 :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)
11931219 => CommentNodeConfig t -> HydrationDomBuilderT s t m DOM.Comment
11941220commentNodeImmediate (CommentNodeConfig !t mSetContents) = do
1195− n <- makeNodeInternal (askDocument >>= \doc -> createComment doc t)
1221+ p <- getParent
1222+ doc <- askDocument
1223+ n <- createComment doc t
1224+ appendChild_ p n
11961225 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
11971226 pure n
11981227
11991228{-# INLINE commentNodeInternal #-}
12001229commentNodeInternal
1201− :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, Reflex t, Adjustable t m)
1230+ :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, Reflex t, Adjustable t m, MonadHold t m, MonadSample t m)
12021231 => CommentNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (CommentNode HydrationDomSpace t)
1203−commentNodeInternal tc@(CommentNodeConfig _t mSetContents) = do
1232+commentNodeInternal tc@(CommentNodeConfig t0 mSetContents) = do
1233+ doc <- askDocument
12041234 getHydrationMode >>= \case
12051235 HydrationMode_Immediate -> void $ commentNodeInternal tc
1206− HydrationMode_Hydrating -> addHydrationStep $ do
1207− n <- hydrateNode (const $ pure True) DOM.Comment
1208− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1236+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t0) (hold t0) mSetContents) $ \bt -> do
1237+ t <- sample bt
1238+ void $ hydrateComment doc t mSetContents
12091239 pure $ CommentNode ()
12101240
1241+{-# INLINE hydrateComment #-}
1242+hydrateComment :: (MonadJSM m, Reflex t, MonadFix m) => Document -> Text -> Maybe (Event t Text) -> HydrationRunnerT t m DOM.Comment
1243+hydrateComment doc t mSetContents = do
1244+ parent <- askParent
1245+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1246+ Nothing -> do
1247+ c <- createComment doc t
1248+ insertAfterPreviousNode c
1249+ pure c
1250+ Just node -> DOM.castTo DOM.Comment node >>= \case
1251+ Nothing -> go (Just node)
1252+ Just c -> do
1253+ t' <- Node.getTextContentUnchecked c
1254+ if t == t'
1255+ then pure c
1256+ else do
1257+ c' <- createComment doc t
1258+ insertAfterPreviousNode c'
1259+ pure c'
1260+ n <- go =<< getPreviousNode
1261+ setPreviousNode $ Just $ toNode n
1262+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1263+ pure n
12111264
12121265-- | We leave markers in the static builder as comments, and rip these comments
12131266-- out at hydration time, replacing them with empty text nodes.