601f33e · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

First pass at hydration prerender

Currently leaves the marker script tags

commit601f33ec7cf2bda5913e8060d06baa2eda035caf authorTom Smalley <tfsmalley@gmail.com> dateMon 19 Nov 2018, 18:53 (8 years ago) parent3a854c3

2 files changed+78−14

compare with develop

unifiedsplit

reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+32−9 reflex-dom-core/src/Reflex/Dom/Prerender.hs+46−5

reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+32−9

@@ -38,6 +38,8 @@ module Reflex.Dom.Builder.Hydration

3838 , HydrationRunnerT (..)

3939 , runHydrationRunnerT

4040 , DOM(..), runDOMForest

41+ , hydrateDOM

42+ , hydrateNode

4143 , runHydrationDomBuilderT

4244 , askParent

4345 , askEvents

@@ -399,6 +401,10 @@ getPreviousNode = HydrationRunnerT get

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

400402setPreviousNode = HydrationRunnerT . put

401403

404+{-# INLINABLE getPrerenderDepth #-}

405+getPrerenderDepth :: MonadIO m => HydrationDomBuilderT t m Word

406+getPrerenderDepth = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_prerenderDepth)

407+

402408{-# INLINABLE getParent #-}

403409getParent :: MonadIO m => HydrationDomBuilderT t m DOM.Node

404410getParent = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)

@@ -437,8 +443,8 @@ makeNodeInternal mkNode = do

437443-- @check@. The previous node reference is also updated.

438444hydrateNode

439445 :: (MonadJSM m, IsNode node, Typeable node)

440− => (node -> HydrationRunnerT t m Bool) -> HydrationRunnerT t m node -> (DOM.JSVal -> node) -> HydrationRunnerT t m node

441−hydrateNode check mkNode constructor = do

446+ => (node -> HydrationRunnerT t m Bool) -> (DOM.JSVal -> node) -> HydrationRunnerT t m node

447+hydrateNode check constructor = do

442448 parent <- askParent

443449 liftIO $ putStr $ show (typeRep constructor) <> ": "

444450 lastHydrationNode <- getPreviousNode

@@ -587,7 +593,6 @@ makeElement elementTag cfg child = do

587593 writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])

588594 getHydrationMode >>= \case

589595 HydrationMode_Immediate -> do

590− -- TODO: prerender needs completely replacing

591596 e <- makeNodeInternal buildElement

592597 p <- liftIO $ newIORef $ toNode e

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

@@ -603,8 +608,15 @@ makeElement elementTag cfg child = do

603608 let env' = env { _hydrationDomBuilderEnv_parent = parent}

604609 (result, childDom) <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') []

605610 wrapResult <- liftIO newEmptyMVar

611+ prerenderDepth <- getPrerenderDepth

606612 let activateElement = do

607− e <- hydrateNode hasSSRAttribute buildElement DOM.Element

613+ e <- case prerenderDepth of

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

608620 -- Update the parent node used by the children

609621 liftIO $ writeIORef parent $ toNode e

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

@@ -644,12 +656,16 @@ textNodeInternal !t mSetContents = getHydrationMode >>= \case

644656 pure n

645657 HydrationMode_Hydrating -> do

646658 doc <- askDocument

659+ prerenderDepth <- getPrerenderDepth

647660 let activateText = do

648661 liftIO $ putStrLn $ "Action: Text: " <> show (DOM.toJSString t)

649− n <- hydrateNode (const $ pure True) (createTextNode doc t) DOM.Text

650− --case mSetContents of

651− -- Nothing -> liftIO $ putStrLn "No update events for text"

652− -- Just e -> requestDomAction_ $ setNodeValue n . Just <$> e

662+ n <- case prerenderDepth of

663+ 0 -> hydrateNode (const $ pure True) DOM.Text

664+ _ -> do

665+ tn <- createTextNode doc t

666+ maybe (askParent >>= \p -> Node.appendChild_ p tn) (insertAfter tn) =<< getPreviousNode

667+ setPreviousNode $ Just $ toNode tn

668+ pure tn

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

654670 hydrateDOM $ DOM_Node activateText

655671 pure $ error "textNodeInternal: DOM.Text"

@@ -663,9 +679,16 @@ commentNodeInternal !t mSetContents = getHydrationMode >>= \case

663679 pure n

664680 HydrationMode_Hydrating -> do

665681 doc <- askDocument

682+ prerenderDepth <- getPrerenderDepth

666683 let activateComment = do

667684 liftIO $ putStrLn $ "Action: Comment: " <> show (DOM.toJSString t)

668− n <- hydrateNode (const $ pure True) (createComment doc t) DOM.Comment

685+ n <- case prerenderDepth of

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

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

670693 hydrateDOM $ DOM_Node activateComment

671694 pure $ error "commentNodeInternal: DOM.Comment"

reflex-dom-core/src/Reflex/Dom/Prerender.hs+46−5

@@ -4,6 +4,7 @@

44{-# LANGUAGE FlexibleContexts #-}

55{-# LANGUAGE FlexibleInstances #-}

66{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE LambdaCase #-}

78{-# LANGUAGE OverloadedStrings #-}

89{-# LANGUAGE MultiParamTypeClasses #-}

910{-# LANGUAGE Rank2Types #-}

@@ -17,18 +18,23 @@ module Reflex.Dom.Prerender

1718 , PrerenderClientConstraint

1819 ) where

1920

21+import Control.Lens ((&), (.~))

2022import Control.Monad.Reader

2123import Control.Monad.Ref (Ref, MonadRef)

2224import Data.Constraint

2325import 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

2531import Foreign.JavaScript.TH

2632import GHC.IORef (IORef)

2733import GHCJS.DOM.Types (MonadJSM)

2834import Reflex

2935import Reflex.Dom.Builder.Class

3036import Reflex.Dom.Builder.InputDisabled

31−import Reflex.Dom.Builder.Immediate

37+import Reflex.Dom.Builder.Immediate (ImmediateDomBuilderT)

3238import Reflex.Dom.Builder.Hydration

3339import Reflex.Dom.Builder.Static

3440import Reflex.Host.Class

@@ -57,7 +63,9 @@ class Monad m => Prerender js m | m -> js where

5763-- | Draw one widget when prerendering (e.g. server-side) and another when the

5864-- widget is fully instantiated. In a given execution of this function, there

5965-- will be exactly one invocation of exactly one of the arguments.

60−prerender :: forall js t m a. (Prerender js m, DomBuilder t m) => m a -> (PrerenderClientConstraint js m => m a) -> m a

66+prerender

67+ :: forall js t m a. (Prerender js m, DomBuilder t m)

68+ => m a -> (PrerenderClientConstraint js m => m a) -> m a

6169prerender server client = do

6270 startPrerenderBlock

6371 a <- case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of

@@ -93,17 +101,50 @@ instance ( HasJS js m

93101 prerenderClientDict = Just Dict

94102 startPrerenderBlock = do

95103 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

96108 liftIO $ modifyIORef' depth succ

97109 endPrerenderBlock = do

98110 depth <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_prerenderDepth

99111 liftIO $ modifyIORef' depth pred

100112

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+

101142data NoJavaScript -- This type should never have a HasJS instance

102143

103144instance (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

104145 prerenderClientDict = Nothing

105− startPrerenderBlock = void $ commentNode $ def { _commentNodeConfig_initialContents = "prerender-start" }

106− endPrerenderBlock = void $ commentNode $ def { _commentNodeConfig_initialContents = "prerender-end" }

146+ startPrerenderBlock = void $ element "script" (def & initialAttributes .~ Map.singleton "type" startMarker) $ pure ()

147+ endPrerenderBlock = void $ element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()

107148

108149

109150instance (Prerender js m, ReflexHost t) => Prerender js (PostBuildT t m) where