d6c88c9 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

More robust hydration

d6c88c9Tom Smalley8 years ago

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+124−71

compare with develop

unifiedsplit

@@ -37,7 +37,6 @@

37-- In "hydration mode", the preexisting DOM __must contain__ what the builder

38-- will expect at switchover time (the time at which parity with the static

39-- renderer is reached, and the time after which the page is "live").

40−-- There can be extra nodes, but no missing or incorrect nodes.

41--

40--

42-- For example, displaying the current time as text should be done inside

41-- For example, displaying the current time as text should be done inside

43-- 'Reflex.Dom.Prerender.prerender' to ensure that we don't attempt to hydrate the incorrect text.

42-- '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

52 , runHydrationRunnerT

51 , runHydrationRunnerT

53 , ImmediateDomBuilderT

52 , ImmediateDomBuilderT

54 , runHydrationDomBuilderT

53 , runHydrationDomBuilderT

55−

56 , getHydrationMode

54 , getHydrationMode

57 , addHydrationStep

55 , addHydrationStep

58 , addHydrationStepWithSetup

56 , addHydrationStepWithSetup

59 , setPreviousNode

57 , setPreviousNode

60−

58+ , insertAfterPreviousNode

59+ , hydrateComment

61 , askParent

60 , askParent

62 , askEvents

61 , askEvents

63 , append

62 , append

64 , textNodeInternal

63 , textNodeInternal

64+ , removeSubsequentNodes

65 , deleteBetweenExclusive

66 , extractBetweenExclusive

67 , deleteUpTo

@@ -73,7 +73,6 @@ module Reflex.Dom.Builder.Immediate

73 , EventFilterTriggerRef (..)

74 , wrap

75 , elementInternal

76− , hydrateNode

77 , HydrationDomSpace

76 , HydrationDomSpace

78 , GhcjsDomSpace

77 , GhcjsDomSpace

79 , GhcjsDomHandler (..)

78 , GhcjsDomHandler (..)

@@ -125,13 +124,13 @@ import Control.Monad.Exception

125import Control.Monad.Primitive

124import Control.Monad.Primitive

126import Control.Monad.Reader

125import Control.Monad.Reader

127import Control.Monad.Ref

126import 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)

129import Data.Bitraversable

128import Data.Bitraversable

130import Data.Default

129import Data.Default

131import Data.Dependent.Map (DMap)

130import Data.Dependent.Map (DMap)

132import Data.Dependent.Sum

131import Data.Dependent.Sum

133import Data.FastMutableIntMap (PatchIntMap (..))

132import Data.FastMutableIntMap (PatchIntMap (..))

134−import Data.Foldable (for_)

133+import Data.Foldable (for_, traverse_)

135import Data.Functor.Compose

134import Data.Functor.Compose

136import Data.Functor.Constant

135import Data.Functor.Constant

137import Data.Functor.Misc

136import Data.Functor.Misc

@@ -141,7 +140,6 @@ import Data.IntMap.Strict (IntMap)

141import Data.Maybe

140import Data.Maybe

142import Data.Some (Some(..))

141import Data.Some (Some(..))

143import Data.Text (Text)

142import Data.Text (Text)

144−import Data.Typeable (Typeable)

145import Foreign.JavaScript.Internal.Utils

143import Foreign.JavaScript.Internal.Utils

146import Foreign.JavaScript.TH

144import Foreign.JavaScript.TH

147import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

145import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

@@ -260,22 +258,35 @@ instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT s t m)

260

258

261-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.

259-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.

262-- State contains reference to the previous node sibling, if any, and the reader contains reference to the parent node.

260-- 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 }

264 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

262 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

265#if MIN_VERSION_base(4,9,1)

263#if MIN_VERSION_base(4,9,1)

266 , MonadAsyncException

264 , MonadAsyncException

267#endif

265#endif

268 )

266 )

269

267

268+data HydrationState = HydrationState

269+ { _hydrationState_previousNode :: Maybe Node

270+ , _hydrationState_failed :: Bool

271+ }

272+

270{-# INLINABLE localRunner #-}

273{-# INLINABLE localRunner #-}

271localRunner :: (MonadJSM m, Monad m) => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a

274localRunner :: (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

273

280

274{-# INLINABLE runHydrationRunnerT #-}

281{-# INLINABLE runHydrationRunnerT #-}

275runHydrationRunnerT

282runHydrationRunnerT

276 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))

283 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))

277 => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a

284 => 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

279

290

280instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where

291instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where

281 {-# INLINABLE newEventWithTrigger #-}

292 {-# INLINABLE newEventWithTrigger #-}

@@ -305,7 +316,7 @@ addHydrationStepWithSetup setup f = getHydrationMode >>= \case

305 HydrationMode_Immediate -> pure ()

316 HydrationMode_Immediate -> pure ()

306 HydrationMode_Hydrating -> do

317 HydrationMode_Hydrating -> do

307 switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

318 switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

308− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover -- 4% more memory than above

319+ (s, _) <- lift $ runWithReplace setup $ return () <$ switchover

309 addHydrationStep (f s)

320 addHydrationStep (f s)

310

321

311-- | Add a hydration step

322-- | Add a hydration step

@@ -409,11 +420,11 @@ data HydrationMode

409

420

410{-# INLINABLE getPreviousNode #-}

421{-# INLINABLE getPreviousNode #-}

411getPreviousNode :: Monad m => HydrationRunnerT t m (Maybe DOM.Node)

422getPreviousNode :: Monad m => HydrationRunnerT t m (Maybe DOM.Node)

412−getPreviousNode = HydrationRunnerT get

423+getPreviousNode = HydrationRunnerT $ gets _hydrationState_previousNode

413

424

414{-# INLINABLE setPreviousNode #-}

425{-# INLINABLE setPreviousNode #-}

415setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()

426setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()

416−setPreviousNode = HydrationRunnerT . put

427+setPreviousNode n = HydrationRunnerT $ modify' (\hs -> hs { _hydrationState_previousNode = n })

417

428

418{-# INLINABLE askUnreadyChildren #-}

429{-# INLINABLE askUnreadyChildren #-}

419askUnreadyChildren :: Monad m => HydrationDomBuilderT s t m (IORef Word)

430askUnreadyChildren :: Monad m => HydrationDomBuilderT s t m (IORef Word)

@@ -427,35 +438,11 @@ askCommitAction = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_commitActi

427getHydrationMode :: MonadIO m => HydrationDomBuilderT s t m HydrationMode

438getHydrationMode :: MonadIO m => HydrationDomBuilderT s t m HydrationMode

428getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)

439getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)

429

440

430−{-# INLINE makeNodeInternal #-}

441+-- | Remove all nodes after given node

431−makeNodeInternal

442+removeSubsequentNodes :: (MonadJSM m, IsNode n) => n -> m ()

432− :: forall node s t m. (MonadJSM m, IsNode node, Typeable node)

443+removeSubsequentNodes n = liftJSM $ do

433− => HydrationDomBuilderT s t m node -> HydrationDomBuilderT s t m node

444+ f <- eval ("(function(n) { while (n.nextSibling) { (n.parentNode).removeChild(n.nextSibling); }; })" :: Text)

434−makeNodeInternal mkNode = do

445+ void $ call f f [n]

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

459

446

460-- | s and e must both be children of the same node and s must precede e;

447-- | s and e must both be children of the same node and s must precede e;

461-- all nodes between s and e will be removed, but s and e will not be removed

448-- 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

671 runReaderT (defaultDomEventHandler e en) evt

658 runReaderT (defaultDomEventHandler e en) evt

672 }

659 }

673

660

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+

674{-# INLINE elementImmediate #-}

671{-# INLINE elementImmediate #-}

675elementImmediate

672elementImmediate

676 :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec

673 :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec

@@ -683,14 +680,9 @@ elementImmediate elementTag cfg child = do

683 doc <- askDocument

680 doc <- askDocument

684 ctx <- askJSM

681 ctx <- askJSM

685 events <- askEvents

682 events <- askEvents

686− e <- makeNodeInternal . liftJSM $ do

683+ parent <- getParent

687− e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of

684+ e <- makeElement doc elementTag cfg

688− Nothing -> createElement doc elementTag

685+ appendChild_ parent e

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

694 -- Run the child builder with updated parent and previous sibling references

686 -- Run the child builder with updated parent and previous sibling references

695 result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode e }) child

687 result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode e }) child

696 let rawCfg = extractRawElementConfig cfg

688 let rawCfg = extractRawElementConfig cfg

@@ -758,16 +750,16 @@ hydrateElement

758 -> ElementConfig er t HydrationDomSpace

750 -> ElementConfig er t HydrationDomSpace

759 -> HydrationDomBuilderT HydrationDomSpace t m a

751 -> HydrationDomBuilderT HydrationDomSpace t m a

760 -> HydrationDomBuilderT HydrationDomSpace t m ((Element er HydrationDomSpace t, a), IORef DOM.Element)

752 -> HydrationDomBuilderT HydrationDomSpace t m ((Element er HydrationDomSpace t, a), IORef DOM.Element)

761−hydrateElement _elementTag cfg child = do

753+hydrateElement elementTag cfg child = do

762 ctx <- askJSM

754 ctx <- askJSM

763 events <- askEvents

755 events <- askEvents

764 -- Schedule everything for after postBuild, except for getting the result itself

756 -- 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"

766 e' <- liftIO $ newIORef $ error "hydrateElement: Element not yet initialized"

758 e' <- liftIO $ newIORef $ error "hydrateElement: Element not yet initialized"

767 env <- HydrationDomBuilderT ask

759 env <- HydrationDomBuilderT ask

768 childDelayedRef <- liftIO $ newIORef $ pure ()

760 childDelayedRef <- liftIO $ newIORef $ pure ()

769 let env' = env

761 let env' = env

770− { _hydrationDomBuilderEnv_parent = Right parent

762+ { _hydrationDomBuilderEnv_parent = Right parentRef

771 , _hydrationDomBuilderEnv_delayed = childDelayedRef

763 , _hydrationDomBuilderEnv_delayed = childDelayedRef

772 }

764 }

773 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'

765 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'

@@ -779,10 +771,35 @@ hydrateElement _elementTag cfg child = do

779 Just ns -> hasAttributeNS e (Just ns) ssrAttr <* removeAttributeNS e (Just ns) ssrAttr

771 Just ns -> hasAttributeNS e (Just ns) ssrAttr <* removeAttributeNS e (Just ns) ssrAttr

780 childDom <- liftIO $ readIORef childDelayedRef

772 childDom <- liftIO $ readIORef childDelayedRef

781 let rawCfg = extractRawElementConfig cfg

773 let rawCfg = extractRawElementConfig cfg

774+ doc <- askDocument

782 addHydrationStep $ do

775 addHydrationStep $ do

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

783− e <- hydrateNode hasSSRAttribute DOM.Element

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

784 -- Update the parent node used by the children

801 -- Update the parent node used by the children

785− liftIO $ writeIORef parent $ toNode e

802+ liftIO $ writeIORef parentRef $ toNode e

786 liftIO $ writeIORef e' e

803 liftIO $ writeIORef e' e

787 -- Setup events, store the result so we can wait on it later

804 -- Setup events, store the result so we can wait on it later

788 refs <- wrap events e rawCfg

805 refs <- wrap events e rawCfg

@@ -1125,7 +1142,10 @@ textNodeImmediate

1125 :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)

1142 :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)

1126 => TextNodeConfig t -> HydrationDomBuilderT s t m DOM.Text

1143 => TextNodeConfig t -> HydrationDomBuilderT s t m DOM.Text

1127textNodeImmediate (TextNodeConfig !t mSetContents) = do

1144textNodeImmediate (TextNodeConfig !t mSetContents) = do

1145+ p <- getParent

1146+ doc <- askDocument

1128− n <- makeNodeInternal (askDocument >>= \doc -> createTextNode doc t)

1147+ n <- createTextNode doc t

1148+ appendChild_ p n

1129 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1149 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1130 pure n

1150 pure n

1131

1151

@@ -1144,10 +1164,11 @@ textNodeInternal

1144 :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t)

1164 :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t)

1145 => TextNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (TextNode HydrationDomSpace t)

1165 => TextNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (TextNode HydrationDomSpace t)

1146textNodeInternal tc@(TextNodeConfig !t mSetContents) = do

1166textNodeInternal tc@(TextNodeConfig !t mSetContents) = do

1167+ doc <- askDocument

1147 getHydrationMode >>= \case

1168 getHydrationMode >>= \case

1148 HydrationMode_Immediate -> void $ textNodeImmediate tc

1169 HydrationMode_Immediate -> void $ textNodeImmediate tc

1149 HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t) (hold t) mSetContents) $ \currentText -> do

1170 HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t) (hold t) mSetContents) $ \currentText -> do

1150− n <- hydrateTextNode =<< sample currentText

1171+ n <- hydrateTextNode doc =<< sample currentText

1151 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1172 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1152 pure $ TextNode ()

1173 pure $ TextNode ()

1153

1174

@@ -1161,20 +1182,22 @@ textNodeInternal tc@(TextNodeConfig !t mSetContents) = do

1161-- expect. We also have a special case for empty text nodes - we always create

1182-- expect. We also have a special case for empty text nodes - we always create

1162-- the and add them after the previous node reference.

1183-- the and add them after the previous node reference.

1163{-# INLINE hydrateTextNode #-}

1184{-# INLINE hydrateTextNode #-}

1164−hydrateTextNode :: MonadJSM m => Text -> HydrationRunnerT t m DOM.Text

1185+hydrateTextNode :: MonadJSM m => Document -> Text -> HydrationRunnerT t m DOM.Text

1165−hydrateTextNode t@"" = do

1186+hydrateTextNode doc t@"" = do

1166− doc <- Node.getOwnerDocumentUnchecked =<< askParent

1167 tn <- createTextNode doc t

1187 tn <- createTextNode doc t

1168 insertAfterPreviousNode tn

1188 insertAfterPreviousNode tn

1169 pure tn

1189 pure tn

1170−hydrateTextNode t = do

1190+hydrateTextNode doc t = do

1171 n <- join $ go <$> askParent <*> getPreviousNode

1191 n <- join $ go <$> askParent <*> getPreviousNode

1172 setPreviousNode $ Just $ toNode n

1192 setPreviousNode $ Just $ toNode n

1173 return n

1193 return n

1174 where

1194 where

1175− go parent mLastNode = do

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

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

1196+ Nothing -> do

1197+ n <- createTextNode doc t

1198+ insertAfterPreviousNode n

1199+ pure n

1177− DOM.castTo DOM.Text node >>= \case

1200+ Just node -> DOM.castTo DOM.Text node >>= \case

1178 Nothing -> go parent $ Just node

1201 Nothing -> go parent $ Just node

1179 Just originalNode -> do

1202 Just originalNode -> do

1180 originalText <- Node.getTextContentUnchecked originalNode

1203 originalText <- Node.getTextContentUnchecked originalNode

@@ -1185,29 +1208,59 @@ hydrateTextNode t = do

1185 -- required text and a subsequent sibling node containing the rest of the text.

1208 -- required text and a subsequent sibling node containing the rest of the text.

1186 DOM.splitText_ originalNode $ fromIntegral $ T.length t

1209 DOM.splitText_ originalNode $ fromIntegral $ T.length t

1187 return originalNode

1210 return originalNode

1188− Nothing -> go parent $ Just $ toNode originalNode

1211+ Nothing -> do

1212+ n <- createTextNode doc t

1213+ insertAfterPreviousNode n

1214+ pure n

1189

1215

1190{-# INLINE commentNodeImmediate #-}

1216{-# INLINE commentNodeImmediate #-}

1191commentNodeImmediate

1217commentNodeImmediate

1192 :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)

1218 :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)

1193 => CommentNodeConfig t -> HydrationDomBuilderT s t m DOM.Comment

1219 => CommentNodeConfig t -> HydrationDomBuilderT s t m DOM.Comment

1194commentNodeImmediate (CommentNodeConfig !t mSetContents) = do

1220commentNodeImmediate (CommentNodeConfig !t mSetContents) = do

1221+ p <- getParent

1222+ doc <- askDocument

1195− n <- makeNodeInternal (askDocument >>= \doc -> createComment doc t)

1223+ n <- createComment doc t

1224+ appendChild_ p n

1196 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1225 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1197 pure n

1226 pure n

1198

1227

1199{-# INLINE commentNodeInternal #-}

1228{-# INLINE commentNodeInternal #-}

1200commentNodeInternal

1229commentNodeInternal

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)

1202 => CommentNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (CommentNode HydrationDomSpace t)

1231 => 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

1204 getHydrationMode >>= \case

1234 getHydrationMode >>= \case

1205 HydrationMode_Immediate -> void $ commentNodeInternal tc

1235 HydrationMode_Immediate -> void $ commentNodeInternal tc

1206− HydrationMode_Hydrating -> addHydrationStep $ do

1236+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t0) (hold t0) mSetContents) $ \bt -> do

1207− n <- hydrateNode (const $ pure True) DOM.Comment

1237+ t <- sample bt

1208− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1238+ void $ hydrateComment doc t mSetContents

1209 pure $ CommentNode ()

1239 pure $ CommentNode ()

1210

1240

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

1211

1264

1212-- | We leave markers in the static builder as comments, and rip these comments

1265-- | We leave markers in the static builder as comments, and rip these comments

1213-- out at hydration time, replacing them with empty text nodes.

1266-- out at hydration time, replacing them with empty text nodes.

reflex-dom-core/src/Reflex/Dom/Main.hs+19−15

@@ -3,6 +3,7 @@

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE NoMonomorphismRestriction #-}

8{-# LANGUAGE NoMonomorphismRestriction #-}

8{-# LANGUAGE PatternSynonyms #-}

9{-# LANGUAGE PatternSynonyms #-}

@@ -27,7 +28,6 @@ import Reflex.PostBuild.Base

27import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)

28import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)

28import Reflex.TriggerEvent.Base

29import Reflex.TriggerEvent.Base

29import Reflex.TriggerEvent.Class

30import Reflex.TriggerEvent.Class

30−import qualified Reflex.TriggerEvent.Base as TriggerEvent

32import Control.Concurrent

33import Control.Lens

@@ -79,17 +79,22 @@ mainHydrationWidgetWithSwitchoverAction' switchoverAction head' body = do

79{-# INLINABLE attachHydrationWidget #-}

80attachHydrationWidget

81 :: IO ()

82− -> IORef HydrationMode

83− -> IORef [(Node, HydrationRunnerT DomTimeline (DomCoreWidget ()) ())]

84 -> JSContextSingleton ()

82 -> JSContextSingleton ()

83+ -> ( Event DomTimeline ()

84+ -> IORef HydrationMode

85+ -> Maybe (IORef [(Node, HydrationRunnerT DomTimeline (DomCoreWidget ()) ())])

86+ -> EventChannel

85− -> (EventChannel -> Event DomTimeline () -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ()))))

87+ -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))

88+ )

86 -> IO (a, FireCommand DomTimeline DomHost)

89 -> IO (a, FireCommand DomTimeline DomHost)

87−attachHydrationWidget switchoverAction hydrationMode rootNodesRef jsSing w = do

90+attachHydrationWidget switchoverAction jsSing w = do

91+ hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating

92+ rootNodesRef <- liftIO $ newIORef []

88 events <- newChan

93 events <- newChan

89 runDomHost $ flip runTriggerEventT events $ mdo

94 runDomHost $ flip runTriggerEventT events $ mdo

90 (syncEvent, fireSync) <- newTriggerEvent

95 (syncEvent, fireSync) <- newTriggerEvent

91 ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- lift $ hostPerformEventT $ do

96 ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- lift $ hostPerformEventT $ do

92− a <- w events syncEvent

97+ a <- w syncEvent hydrationMode (Just rootNodesRef) events

93 _ <- runWithReplace (return ()) $ delayedAction <$ syncEvent

98 _ <- runWithReplace (return ()) $ delayedAction <$ syncEvent

94 pure a

99 pure a

95 mPostBuildTrigger <- readRef postBuildTriggerRef

100 mPostBuildTrigger <- readRef postBuildTriggerRef

@@ -98,7 +103,8 @@ attachHydrationWidget switchoverAction hydrationMode rootNodesRef jsSing w = do

98 rootNodes <- liftIO $ readIORef rootNodesRef

103 rootNodes <- liftIO $ readIORef rootNodesRef

99 let delayedAction = do

104 let delayedAction = do

100 for_ (reverse rootNodes) $ \(rootNode, runner) -> do

105 for_ (reverse rootNodes) $ \(rootNode, runner) -> do

101− void $ runWithJSContextSingleton (runPostBuildT (runHydrationRunnerT runner Nothing rootNode events) never) jsSing

106+ let hydrate = runHydrationRunnerT runner Nothing rootNode events

107+ void $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing

102 liftIO $ writeIORef hydrationMode HydrationMode_Immediate

108 liftIO $ writeIORef hydrationMode HydrationMode_Immediate

103 liftIO $ switchoverAction

109 liftIO $ switchoverAction

104 pure (result, fc)

110 pure (result, fc)

@@ -122,15 +128,12 @@ runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonM

122 globalDoc <- currentDocumentUnchecked

128 globalDoc <- currentDocumentUnchecked

123 headElement <- getHeadUnchecked globalDoc

129 headElement <- getHeadUnchecked globalDoc

124 bodyElement <- getBodyUnchecked globalDoc

130 bodyElement <- getBodyUnchecked globalDoc

125− unreadyChildren <- liftIO $ newIORef 0

126− hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating

127− hydrationResult <- liftIO $ newIORef []

128− (events, fc) <- liftIO . attachHydrationWidget switchoverAction hydrationMode hydrationResult jsSing $ \events switchover -> do

131+ (events, fc) <- liftIO . attachHydrationWidget switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do

129 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

132 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

130 let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c

133 let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c

131 hydrateDom n w = do

134 hydrateDom n w = do

132− events' <- TriggerEvent.askEvents

133 delayed <- liftIO $ newIORef $ pure ()

135 delayed <- liftIO $ newIORef $ pure ()

136+ unreadyChildren <- liftIO $ newIORef 0

134 lift $ do

137 lift $ do

135 let builderEnv = HydrationDomBuilderEnv

138 let builderEnv = HydrationDomBuilderEnv

136 { _hydrationDomBuilderEnv_document = globalDoc

139 { _hydrationDomBuilderEnv_document = globalDoc

@@ -141,9 +144,10 @@ runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonM

141 , _hydrationDomBuilderEnv_switchover = switchover

144 , _hydrationDomBuilderEnv_switchover = switchover

142 , _hydrationDomBuilderEnv_delayed = delayed

145 , _hydrationDomBuilderEnv_delayed = delayed

143 }

146 }

144− a <- runHydrationDomBuilderT w builderEnv events'

147+ a <- runHydrationDomBuilderT w builderEnv events

148+ forM_ hydrationResult $ \hr -> do

145− res <- liftIO $ readIORef delayed

149+ res <- liftIO $ readIORef delayed

146− liftIO $ modifyIORef' hydrationResult ((n, res) :)

150+ liftIO $ modifyIORef' hr ((n, res) :)

147 pure a

151 pure a

148 runWithJSContextSingleton (runPostBuildT (runTriggerEventT (app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)) events) postBuild) jsSing

152 runWithJSContextSingleton (runPostBuildT (runTriggerEventT (app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)) events) postBuild) jsSing

149 return (events, postBuildTriggerRef)

153 return (events, postBuildTriggerRef)

reflex-dom-core/src/Reflex/Dom/Prerender.hs+29−37

@@ -20,28 +20,26 @@ module Reflex.Dom.Prerender

20 , PrerenderBaseConstraints

21 ) where

23−import Control.Lens ((&), (.~))

24import Control.Monad.Primitive (PrimMonad)

23import Control.Monad.Primitive (PrimMonad)

25import Control.Monad.Reader

24import Control.Monad.Reader

26import Control.Monad.Ref (MonadRef(..))

25import Control.Monad.Ref (MonadRef(..))

27import Control.Monad.State.Strict

26import Control.Monad.State.Strict

28−import Data.Default

29import Data.Foldable (traverse_)

27import Data.Foldable (traverse_)

30−import Data.IORef (IORef, modifyIORef', readIORef, newIORef)

28+import Data.IORef (IORef, newIORef)

31−import Data.String (IsString)

29+import Data.Text (Text)

32−import qualified GHCJS.DOM.Element as Element

33−import qualified GHCJS.DOM.Types as DOM

34−import qualified GHCJS.DOM.Document as Document

35−import qualified Data.Map as Map

36import Foreign.JavaScript.TH

30import Foreign.JavaScript.TH

37import GHCJS.DOM.Types (MonadJSM)

31import GHCJS.DOM.Types (MonadJSM)

38import Reflex hiding (askEvents)

32import Reflex hiding (askEvents)

39import Reflex.Dom.Builder.Class

33import Reflex.Dom.Builder.Class

40−import Reflex.Dom.Builder.InputDisabled

41import Reflex.Dom.Builder.Immediate

34import Reflex.Dom.Builder.Immediate

35+import Reflex.Dom.Builder.InputDisabled

42import Reflex.Dom.Builder.Static

36import Reflex.Dom.Builder.Static

43import Reflex.Host.Class

37import Reflex.Host.Class

39+import qualified GHCJS.DOM.Document as Document

40+import qualified GHCJS.DOM.Node as Node

41+import qualified GHCJS.DOM.Types as DOM

42+

45type PrerenderClientConstraint t m =

43type PrerenderClientConstraint t m =

46 ( DomBuilder t m

44 ( DomBuilder t m

47 , DomBuilderSpace m ~ GhcjsDomSpace

45 , DomBuilderSpace m ~ GhcjsDomSpace

@@ -127,15 +125,15 @@ instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerend

127 append $ DOM.toNode df

125 append $ DOM.toNode df

128 HydrationMode_Hydrating -> addHydrationStep $ do

126 HydrationMode_Hydrating -> addHydrationStep $ do

129 liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void b') env' events

127 liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void b') env' events

130− insertBefore df =<< deleteToPrerenderEnd

128+ insertBefore df =<< deleteToPrerenderEnd doc

131 (,) (Just a) <$> holdDyn b0 b'

129 (,) (Just a) <$> holdDyn b0 b'

132

130

133instance SupportsStaticDomBuilder t m => Prerender t (StaticDomBuilderT t m) where

131instance SupportsStaticDomBuilder t m => Prerender t (StaticDomBuilderT t m) where

134 type Client (StaticDomBuilderT t m) = HydrationDomBuilderT GhcjsDomSpace t m

132 type Client (StaticDomBuilderT t m) = HydrationDomBuilderT GhcjsDomSpace t m

135 prerenderImpl server _ = do

133 prerenderImpl server _ = do

136− _ <- element "script" (def & initialAttributes .~ Map.singleton "type" startMarker) $ pure ()

134+ _ <- commentNode $ CommentNodeConfig startMarker Nothing

137 (a, b) <- server

135 (a, b) <- server

138− _ <- element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()

136+ _ <- commentNode $ CommentNodeConfig endMarker Nothing

139 pure (Just a, pure b)

137 pure (Just a, pure b)

140

138

141instance (Prerender t m, Monad m) => Prerender t (ReaderT r m) where

139instance (Prerender t m, Monad m) => Prerender t (ReaderT r m) where

@@ -178,33 +176,27 @@ instance (Prerender t m, Monad m) => Prerender t (PostBuildT t m) where

178 type Client (PostBuildT t m) = Client m

176 type Client (PostBuildT t m) = Client m

179 prerenderImpl (PostBuildT server) client = PostBuildT $ prerenderImpl server client

177 prerenderImpl (PostBuildT server) client = PostBuildT $ prerenderImpl server client

180

178

181−startMarker, endMarker :: IsString s => s

179+startMarker, endMarker :: Text

182startMarker = "prerender/start"

180startMarker = "prerender/start"

183endMarker = "prerender/end"

181endMarker = "prerender/end"

184

182

185−deleteToPrerenderEnd :: (MonadIO m, MonadJSM m) => HydrationRunnerT t m DOM.Element

183+deleteToPrerenderEnd :: (MonadIO m, MonadJSM m, Reflex t, MonadFix m) => DOM.Document -> HydrationRunnerT t m DOM.Comment

186−deleteToPrerenderEnd = do

184+deleteToPrerenderEnd doc = do

187− depth <- liftIO $ newIORef (0 :: Int)

185+ startNode <- hydrateComment doc startMarker Nothing

188− startNode <- hydrateNode (\e -> do

186+ let go (n :: Int) lastNode = Node.getNextSibling lastNode >>= \case

189− n :: DOM.JSString <- Element.getTagName e

187+ Nothing -> do

190− mt :: Maybe DOM.JSString <- Element.getAttribute e ("type" :: DOM.JSString)

188+ c <- Document.createComment doc endMarker

191− pure $ n == "SCRIPT" && mt == Just startMarker) DOM.Element

189+ insertAfterPreviousNode c

192− endNode <- hydrateNode (\e -> do

190+ pure c

193− n :: DOM.JSString <- Element.getTagName e

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

194− attrCheck <- Element.getAttribute e ("type" :: DOM.JSString) >>= \case

192+ Nothing -> go n node

195− Just (t :: DOM.JSString)

193+ Just c -> Node.getTextContentUnchecked c >>= \case

196− | t == startMarker -> do

194+ t | t == startMarker -> go (succ n) node

197− liftIO $ modifyIORef' depth succ

198− pure False

199− | t == endMarker -> do

195+ | t == endMarker -> case n of

200− d <- liftIO $ readIORef depth

201− if d == 0

202− then pure True

196+ 0 -> pure c

203− else do

197+ _ -> go (pred n) node

204− liftIO $ modifyIORef' depth pred

198+ | otherwise -> go n node

205− pure False

199+ endNode <- go 0 $ DOM.toNode startNode

206− _ -> pure False

207− pure $ n == "SCRIPT" && attrCheck) DOM.Element

208 deleteBetweenExclusive startNode endNode

200 deleteBetweenExclusive startNode endNode

209− setPreviousNode $ Just $ DOM.toNode endNode -- TODO probably not necessary

201+ setPreviousNode $ Just $ DOM.toNode endNode

210 pure endNode

202 pure endNode

reflex-dom-core/test/hydration.hs+25

@@ -1257,6 +1257,31 @@ tests wdConfig caps _selenium = do

1257 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan

1258 liftIO $ assertEqual "DMap" initMap dmap

1259

1260+ describe "hydrating invalid HTML" $ session' $ do

1261+ it "can hydrate list in paragraph" $ runWD $ do

1262+ let static = do

1263+ body <- WD.findElem (WD.ByTag "body")

1264+ shouldContainText "before\ninner\nafter" body

1265+ -- Two tags should be present

1266+ [p1, p2] <- WD.findElems (WD.ByTag "p")

1267+ ol <- WD.findElem (WD.ByTag "ol")

1268+ shouldContainText "before" p1

1269+ shouldContainText "inner" ol

1270+ shouldContainText "" p2

1271+ pure (body, p1, ol, p2)

1272+ check (body, p1, ol, p2) = do

1273+ shouldContainText "before\ninner\nafter" body

1274+ shouldContainText "before\ninner\nafter" p1

1275+ elementShouldBeRemoved ol

1276+ elementShouldBeRemoved p2

1277+ testWidget' static check $ do

1278+ -- This is deliberately invalid HTML, the browser will interpret it as

1279+ -- before<ol>inner</ol>after

1280+ el "p" $ do

1281+ text "before"

1282+ el "ol" $ text "inner"

1283+ text "after"

1284+

1260data Selenium = Selenium

1285data Selenium = Selenium

1261 { _selenium_portNumber :: PortNumber

1286 { _selenium_portNumber :: PortNumber

1262 , _selenium_stopServer :: IO ()

1287 , _selenium_stopServer :: IO ()