git.iko.soy/reflex-dom
on develop help sign in
First pass at hydration prerender
601f33eTom Smalley
reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+32−9
compare with develop
unifiedsplit
@@ -38,6 +38,8 @@ module Reflex.Dom.Builder.Hydration
38 , HydrationRunnerT (..)
38 , HydrationRunnerT (..)
39 , runHydrationRunnerT
39 , runHydrationRunnerT
40 , DOM(..), runDOMForest
40 , DOM(..), runDOMForest
41+ , hydrateDOM
42+ , hydrateNode
41 , runHydrationDomBuilderT
43 , runHydrationDomBuilderT
42 , askParent
44 , askParent
43 , askEvents
45 , askEvents
@@ -399,6 +401,10 @@ getPreviousNode = HydrationRunnerT get
399setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()
401setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()
400setPreviousNode = HydrationRunnerT . put
402setPreviousNode = HydrationRunnerT . put
401
403
404+{-# INLINABLE getPrerenderDepth #-}
405+getPrerenderDepth :: MonadIO m => HydrationDomBuilderT t m Word
406+getPrerenderDepth = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_prerenderDepth)
407+
402{-# INLINABLE getParent #-}
408{-# INLINABLE getParent #-}
403getParent :: MonadIO m => HydrationDomBuilderT t m DOM.Node
409getParent :: MonadIO m => HydrationDomBuilderT t m DOM.Node
404getParent = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)
410getParent = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)
@@ -437,8 +443,8 @@ makeNodeInternal mkNode = do
437-- @check@. The previous node reference is also updated.
443-- @check@. The previous node reference is also updated.
438hydrateNode
444hydrateNode
439 :: (MonadJSM m, IsNode node, Typeable node)
445 :: (MonadJSM m, IsNode node, Typeable node)
440− => (node -> HydrationRunnerT t m Bool) -> HydrationRunnerT t m node -> (DOM.JSVal -> node) -> HydrationRunnerT t m node
446+ => (node -> HydrationRunnerT t m Bool) -> (DOM.JSVal -> node) -> HydrationRunnerT t m node
441−hydrateNode check mkNode constructor = do
447+hydrateNode check constructor = do
442 parent <- askParent
448 parent <- askParent
443 liftIO $ putStr $ show (typeRep constructor) <> ": "
449 liftIO $ putStr $ show (typeRep constructor) <> ": "
444 lastHydrationNode <- getPreviousNode
450 lastHydrationNode <- getPreviousNode
@@ -587,7 +593,6 @@ makeElement elementTag cfg child = do
587 writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
593 writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
588 getHydrationMode >>= \case
594 getHydrationMode >>= \case
589 HydrationMode_Immediate -> do
595 HydrationMode_Immediate -> do
590− -- TODO: prerender needs completely replacing
591 e <- makeNodeInternal buildElement
596 e <- makeNodeInternal buildElement
592 p <- liftIO $ newIORef $ toNode e
597 p <- liftIO $ newIORef $ toNode e
593 -- Run the child builder with updated parent and previous sibling references
598 -- Run the child builder with updated parent and previous sibling references
@@ -603,8 +608,15 @@ makeElement elementTag cfg child = do
603 let env' = env { _hydrationDomBuilderEnv_parent = parent}
608 let env' = env { _hydrationDomBuilderEnv_parent = parent}
604 (result, childDom) <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') []
609 (result, childDom) <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') []
605 wrapResult <- liftIO newEmptyMVar
610 wrapResult <- liftIO newEmptyMVar
611+ prerenderDepth <- getPrerenderDepth
606 let activateElement = do
612 let activateElement = do
613+ e <- case prerenderDepth of
607− e <- hydrateNode hasSSRAttribute buildElement DOM.Element
614+ 0 -> hydrateNode hasSSRAttribute DOM.Element
615+ _ -> do
616+ e <- buildElement
617+ maybe (askParent >>= \p -> Node.appendChild_ p e) (insertAfter e) =<< getPreviousNode
618+ setPreviousNode $ Just $ toNode e
619+ pure e
608 -- Update the parent node used by the children
620 -- Update the parent node used by the children
609 liftIO $ writeIORef parent $ toNode e
621 liftIO $ writeIORef parent $ toNode e
610 -- Setup events, store the result so we can wait on it later
622 -- Setup events, store the result so we can wait on it later
@@ -644,12 +656,16 @@ textNodeInternal !t mSetContents = getHydrationMode >>= \case
644 pure n
656 pure n
645 HydrationMode_Hydrating -> do
657 HydrationMode_Hydrating -> do
646 doc <- askDocument
658 doc <- askDocument
659+ prerenderDepth <- getPrerenderDepth
647 let activateText = do
660 let activateText = do
648 liftIO $ putStrLn $ "Action: Text: " <> show (DOM.toJSString t)
661 liftIO $ putStrLn $ "Action: Text: " <> show (DOM.toJSString t)
662+ n <- case prerenderDepth of
649− n <- hydrateNode (const $ pure True) (createTextNode doc t) DOM.Text
663+ 0 -> hydrateNode (const $ pure True) DOM.Text
650− --case mSetContents of
664+ _ -> do
651− -- Nothing -> liftIO $ putStrLn "No update events for text"
665+ tn <- createTextNode doc t
652− -- Just e -> requestDomAction_ $ setNodeValue n . Just <$> e
666+ maybe (askParent >>= \p -> Node.appendChild_ p tn) (insertAfter tn) =<< getPreviousNode
667+ setPreviousNode $ Just $ toNode tn
668+ pure tn
653 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
669 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
654 hydrateDOM $ DOM_Node activateText
670 hydrateDOM $ DOM_Node activateText
655 pure $ error "textNodeInternal: DOM.Text"
671 pure $ error "textNodeInternal: DOM.Text"
@@ -663,9 +679,16 @@ commentNodeInternal !t mSetContents = getHydrationMode >>= \case
663 pure n
679 pure n
664 HydrationMode_Hydrating -> do
680 HydrationMode_Hydrating -> do
665 doc <- askDocument
681 doc <- askDocument
682+ prerenderDepth <- getPrerenderDepth
666 let activateComment = do
683 let activateComment = do
667 liftIO $ putStrLn $ "Action: Comment: " <> show (DOM.toJSString t)
684 liftIO $ putStrLn $ "Action: Comment: " <> show (DOM.toJSString t)
685+ n <- case prerenderDepth of
668− n <- hydrateNode (const $ pure True) (createComment doc t) DOM.Comment
686+ 0 -> hydrateNode (const $ pure True) DOM.Comment
687+ _ -> do
688+ tn <- createComment doc t
689+ maybe (askParent >>= \p -> Node.appendChild_ p tn) (insertAfter tn) =<< getPreviousNode
690+ setPreviousNode $ Just $ toNode tn
691+ pure tn
669 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
692 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
670 hydrateDOM $ DOM_Node activateComment
693 hydrateDOM $ DOM_Node activateComment
671 pure $ error "commentNodeInternal: DOM.Comment"
694 pure $ error "commentNodeInternal: DOM.Comment"
reflex-dom-core/src/Reflex/Dom/Prerender.hs+46−5
@@ -4,6 +4,7 @@
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE Rank2Types #-}
@@ -17,18 +18,23 @@ module Reflex.Dom.Prerender
17 , PrerenderClientConstraint
18 , PrerenderClientConstraint
18 ) where
19 ) where
19
20
21+import Control.Lens ((&), (.~))
20import Control.Monad.Reader
22import Control.Monad.Reader
21import Control.Monad.Ref (Ref, MonadRef)
23import Control.Monad.Ref (Ref, MonadRef)
22import Data.Constraint
24import Data.Constraint
23import Data.Default
25import Data.Default
24−import Data.IORef (modifyIORef')
26+import Data.IORef (modifyIORef', readIORef, newIORef)
27+import Data.String (IsString)
28+import qualified GHCJS.DOM.Element as Element
29+import qualified GHCJS.DOM.Types as DOM
30+import qualified Data.Map as Map
25import Foreign.JavaScript.TH
31import Foreign.JavaScript.TH
26import GHC.IORef (IORef)
32import GHC.IORef (IORef)
27import GHCJS.DOM.Types (MonadJSM)
33import GHCJS.DOM.Types (MonadJSM)
28import Reflex
34import Reflex
29import Reflex.Dom.Builder.Class
35import Reflex.Dom.Builder.Class
30import Reflex.Dom.Builder.InputDisabled
36import Reflex.Dom.Builder.InputDisabled
31−import Reflex.Dom.Builder.Immediate
37+import Reflex.Dom.Builder.Immediate (ImmediateDomBuilderT)
32import Reflex.Dom.Builder.Hydration
38import Reflex.Dom.Builder.Hydration
33import Reflex.Dom.Builder.Static
39import Reflex.Dom.Builder.Static
34import Reflex.Host.Class
40import Reflex.Host.Class
@@ -57,7 +63,9 @@ class Monad m => Prerender js m | m -> js where
57-- | Draw one widget when prerendering (e.g. server-side) and another when the
63-- | Draw one widget when prerendering (e.g. server-side) and another when the
58-- widget is fully instantiated. In a given execution of this function, there
64-- widget is fully instantiated. In a given execution of this function, there
59-- will be exactly one invocation of exactly one of the arguments.
65-- will be exactly one invocation of exactly one of the arguments.
66+prerender
60−prerender :: forall js t m a. (Prerender js m, DomBuilder t m) => m a -> (PrerenderClientConstraint js m => m a) -> m a
67+ :: forall js t m a. (Prerender js m, DomBuilder t m)
68+ => m a -> (PrerenderClientConstraint js m => m a) -> m a
61prerender server client = do
69prerender server client = do
62 startPrerenderBlock
70 startPrerenderBlock
63 a <- case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of
71 a <- case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of
@@ -93,17 +101,50 @@ instance ( HasJS js m
93 prerenderClientDict = Just Dict
101 prerenderClientDict = Just Dict
94 startPrerenderBlock = do
102 startPrerenderBlock = do
95 depth <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_prerenderDepth
103 depth <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_prerenderDepth
104+ d <- liftIO $ readIORef depth
105+ when (d == 0) $ do
106+ -- Delete up to the end marker
107+ hydrateDOM $ DOM_Node deleteToPrerenderEnd
96 liftIO $ modifyIORef' depth succ
108 liftIO $ modifyIORef' depth succ
97 endPrerenderBlock = do
109 endPrerenderBlock = do
98 depth <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_prerenderDepth
110 depth <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_prerenderDepth
99 liftIO $ modifyIORef' depth pred
111 liftIO $ modifyIORef' depth pred
100
112
113+startMarker, endMarker :: IsString s => s
114+startMarker = "prerender/start"
115+endMarker = "prerender/end"
116+
117+deleteToPrerenderEnd :: (MonadIO m, MonadJSM m) => HydrationRunnerT t m ()
118+deleteToPrerenderEnd = do
119+ depth <- liftIO $ newIORef 0
120+ startNode <- hydrateNode (\e -> do
121+ n :: DOM.JSString <- Element.getTagName e
122+ mt :: Maybe DOM.JSString <- Element.getAttribute e ("type" :: DOM.JSString)
123+ pure $ n == "SCRIPT" && mt == Just startMarker) DOM.Element
124+ endNode <- hydrateNode (\e -> do
125+ n :: DOM.JSString <- Element.getTagName e
126+ attrCheck <- Element.getAttribute e ("type" :: DOM.JSString) >>= \case
127+ Just (t :: DOM.JSString)
128+ | t == startMarker -> do
129+ liftIO $ modifyIORef' depth succ
130+ pure False
131+ | t == endMarker -> do
132+ d <- liftIO $ readIORef depth
133+ if d == 0
134+ then pure True
135+ else do
136+ liftIO $ modifyIORef' depth pred
137+ pure False
138+ _ -> pure False
139+ pure $ n == "SCRIPT" && attrCheck) DOM.Element
140+ deleteBetweenExclusive startNode endNode
141+
101data NoJavaScript -- This type should never have a HasJS instance
142data NoJavaScript -- This type should never have a HasJS instance
102
143
103instance (Monad m, js ~ NoJavaScript, Adjustable t m, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ IORef) => Prerender js (StaticDomBuilderT t m) where
144instance (Monad m, js ~ NoJavaScript, Adjustable t m, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ IORef) => Prerender js (StaticDomBuilderT t m) where
104 prerenderClientDict = Nothing
145 prerenderClientDict = Nothing
105− startPrerenderBlock = void $ commentNode $ def { _commentNodeConfig_initialContents = "prerender-start" }
146+ startPrerenderBlock = void $ element "script" (def & initialAttributes .~ Map.singleton "type" startMarker) $ pure ()
106− endPrerenderBlock = void $ commentNode $ def { _commentNodeConfig_initialContents = "prerender-end" }
147+ endPrerenderBlock = void $ element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()
107
148
108
149
109instance (Prerender js m, ReflexHost t) => Prerender js (PostBuildT t m) where
150instance (Prerender js m, ReflexHost t) => Prerender js (PostBuildT t m) where