984a534 · obelisk · git.iko.soy

git.iko.soy/obelisk

Update for new prerender

commit984a534e4df581c910b1d054c733002c2aa2e904 authorTom Smalley <tfsmalley@gmail.com> dateFri 21 Dec 2018, 14:47 (8 years ago) parent88111b0

2 files changed+45−93

compare with master

unifiedsplit

lib/frontend/src/Obelisk/Frontend.hs+21−85 lib/route/src/Obelisk/Route/Frontend.hs+24−8

lib/frontend/src/Obelisk/Frontend.hs+21−85

@@ -26,6 +26,7 @@ import Control.Monad hiding (sequence, sequence_)

2626import Control.Monad.Fix

2727import Control.Monad.IO.Class

2828import Control.Monad.Primitive

29+import Control.Monad.Reader

2930import Control.Monad.Ref

3031import Control.Monad.Trans.Class

3132import Data.ByteString (ByteString)

@@ -50,7 +51,7 @@ import qualified Reflex.TriggerEvent.Base as TriggerEvent

5051

5152makePrisms ''Sum

5253

53−type ObeliskWidget t x route m =

54+type ObeliskWidget t route m =

5455 ( DomBuilder t m

5556 , MonadFix m

5657 , MonadHold t m

@@ -58,8 +59,6 @@ type ObeliskWidget t x route m =

5859 , MonadReflexCreateTrigger t m

5960 , PostBuild t m

6061 , PerformEvent t m

61− , MonadIO m

62− , MonadIO (Performable m)

6362 , TriggerEvent t m

6463 , HasDocument m

6564 , MonadRef m

@@ -68,91 +67,19 @@ type ObeliskWidget t x route m =

6867 , Ref (Performable m) ~ Ref IO

6968 , MonadFix (Performable m)

7069 , PrimMonad m

71− , Prerender x m

70+ , Prerender t m

7271 , SetRoute t route m

72+ , SetRoute t route (Client m)

7373 , RouteToUrl route m

74+ , RouteToUrl route (Client m)

75+ , Monad (Client m)

7476 )

7577

7678data Frontend route = Frontend

77− { _frontend_head :: !(forall t m x. ObeliskWidget t x route m => RoutedT t route m ())

78− , _frontend_body :: !(forall t m x. ObeliskWidget t x route m => RoutedT t route m ())

79+ { _frontend_head :: !(forall t m. ObeliskWidget t route m => RoutedT t route m ())

80+ , _frontend_body :: !(forall t m. ObeliskWidget t route m => RoutedT t route m ())

7981 }

8082

81−type Widget' x a = HydrationDomBuilderT DomTimeline (DomCoreWidget x) a

82−

83−-- | A widget that isn't attached to any particular part of the DOM hierarchy

84−type FloatingWidget x = TriggerEventT DomTimeline (DomCoreWidget x)

85−

86−type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))

87−

88−--TODO: Rename

89−{-# INLINABLE attachWidget''' #-}

90−attachWidget'''

91− :: IORef HydrationMode

92− -> IORef [(Node, HydrationRunnerT DomTimeline (PostBuildT DomTimeline (WithJSContextSingleton () (PerformEventT DomTimeline DomHost))) ())]

93− -> JSContextSingleton ()

94− -> (EventChannel -> Event DomTimeline () -> PerformEventT DomTimeline DomHost (IORef (Maybe (EventTrigger DomTimeline ()))))

95− -> IO ()

96−attachWidget''' hydrationMode rootNodesRef jsSing w = do

97− events <- newChan

98− runDomHost $ flip runTriggerEventT events $ mdo

99− (syncEvent, fireSync) <- newTriggerEvent

100− liftIO $ putStrLn "-------------------------------------- Running host"

101− (postBuildTriggerRef, fc@(FireCommand fire)) <- lift $ hostPerformEventT $ do

102− a <- w events syncEvent

103− runWithReplace (return ()) $ delayedAction <$ syncEvent

104− pure a

105− mPostBuildTrigger <- readRef postBuildTriggerRef

106− lift $ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

107− liftIO $ fireSync ()

108− rootNodes <- liftIO $ readIORef rootNodesRef

109− -- TODO: DomHost is SpiderHost Global only if we're not in profiling mode

110− let delayedAction = do

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

112− liftIO $ putStrLn "-------------------------------------- Performing delayed actions"

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

114− liftIO $ putStrLn "-------------------------------------- Performed delayed actions"

115− liftIO $ writeIORef hydrationMode HydrationMode_Immediate

116− liftIO $ processAsyncEvents events fc

117−

118−--TODO: This is a collection of random stuff; we should make it make some more sense and then upstream to reflex-dom-core

119−runWithHeadAndBody

120− :: ( (forall c. Widget' () c -> FloatingWidget () c) -- "Append to head"

121− -> (forall c. Widget' () c -> FloatingWidget () c) -- "Append to body"

122− -> FloatingWidget () ()

123− )

124− -> JSM ()

125−runWithHeadAndBody app = withJSContextSingletonMono $ \jsSing -> do

126− globalDoc <- currentDocumentUnchecked

127− headElement <- getHeadUnchecked globalDoc

128− bodyElement <- getBodyUnchecked globalDoc

129− unreadyChildren <- liftIO $ newIORef 0

130− hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating

131− hydrationResult <- liftIO $ newIORef []

132− liftIO $ attachWidget''' hydrationMode hydrationResult jsSing $ \events switchover -> flip runWithJSContextSingleton jsSing $ do

133− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

134− let hydrateDom :: DOM.Node -> Widget' () c -> FloatingWidget () c

135− hydrateDom n w = do

136− events' <- TriggerEvent.askEvents

137− parent <- liftIO $ newIORef $ toNode n

138− lift $ do

139− let builderEnv = HydrationDomBuilderEnv

140− { _hydrationDomBuilderEnv_document = globalDoc

141− , _hydrationDomBuilderEnv_parent = parent

142− , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

143− , _hydrationDomBuilderEnv_commitAction = pure ()

144− , _hydrationDomBuilderEnv_hydrationMode = hydrationMode

145− , _hydrationDomBuilderEnv_switchover = switchover

146− }

147− (a, res) <- runHydrationDomBuilderT w builderEnv events'

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

149− pure a

150− flip runPostBuildT postBuild $ flip runTriggerEventT events $ app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)

151−-- liftIO (readIORef unreadyChildren) >>= \case

152−-- 0 -> DOM.liftJSM commit

153−-- _ -> return ()

154− return postBuildTriggerRef

155−

15683runFrontend :: forall backendRoute route. Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName -> Frontend (R route) -> JSM ()

15784runFrontend validFullEncoder frontend = do

15885 let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _InR . _ObeliskRoute_App))

@@ -168,12 +95,21 @@ runFrontend validFullEncoder frontend = do

16895 , MonadFix m

16996 , MonadFix (Performable m)

17097 )

171− => RoutedT t (R route) (SetRouteT t (R route) (RouteToUrlT (R route) m)) a

98+ => Event t ()

99+ -> RoutedT t (R route) (SetRouteT t (R route) (RouteToUrlT (R route) m)) a

172100 -> m a

173101 runMyRouteViewT = runRouteViewT ve

174− runWithHeadAndBody $ \appendHead appendBody -> runMyRouteViewT $ do

175− mapRoutedT (mapSetRouteT (mapRouteToUrlT appendHead)) $ _frontend_head frontend

176− mapRoutedT (mapSetRouteT (mapRouteToUrlT appendBody)) $ _frontend_body frontend

102+ runHydrationWidgetWithHeadAndBody (liftIO $ putStrLn "SWITCHOVER") $ \appendHead appendBody -> do

103+ rec switchover <- runMyRouteViewT switchover $ do

104+ (switchover, fire) <- newTriggerEvent

105+ mapRoutedT (mapSetRouteT (mapRouteToUrlT appendHead)) $ do

106+ _frontend_head frontend

107+ mapRoutedT (mapSetRouteT (mapRouteToUrlT appendBody)) $ do

108+ _frontend_body frontend

109+ switchover' <- lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

110+ performEvent_ $ liftIO (fire ()) <$ switchover'

111+ pure switchover

112+ pure ()

177113

178114renderFrontendHtml

179115 :: (t ~ DomTimeline)

lib/route/src/Obelisk/Route/Frontend.hs+24−8

@@ -14,6 +14,7 @@

1414{-# LANGUAGE RankNTypes #-}

1515{-# LANGUAGE ScopedTypeVariables #-}

1616{-# LANGUAGE TemplateHaskell #-}

17+{-# LANGUAGE TupleSections #-}

1718{-# LANGUAGE TypeFamilies #-}

1819{-# LANGUAGE TypeOperators #-}

1920{-# LANGUAGE ViewPatterns #-}

@@ -108,8 +109,11 @@ instance HasJSContext m => HasJSContext (RoutedT t r m) where

108109 type JSContextPhantom (RoutedT t r m) = JSContextPhantom m

109110 askJSContext = lift askJSContext

110111

111−instance (Prerender js m, Monad m) => Prerender js (RoutedT t r m) where

112− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

112+instance (Prerender t m, Monad m) => Prerender t (RoutedT t r m) where

113+ type Client (RoutedT t r m) = RoutedT t r (Client m)

114+ prerenderImpl (RoutedT server) client = RoutedT $ do

115+ r <- ask

116+ prerenderImpl server (runRoutedT client r)

113117

114118instance Requester t m => Requester t (RoutedT t r m) where

115119 type Request (RoutedT t r m) = Request m

@@ -254,8 +258,16 @@ instance (Reflex t, Monad m) => SetRoute t r (SetRouteT t r m) where

254258instance (Monad m, SetRoute t r m) => SetRoute t r (RoutedT t r' m) where

255259 modifyRoute = lift . modifyRoute

256260

257−instance (Prerender js m, Monad m) => Prerender js (SetRouteT t r m) where

258− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

261+instance (PerformEvent t m, MonadIO (Performable m), Prerender t m, Monad m, Reflex t, MonadIO m) => Prerender t (SetRouteT t r m) where

262+ type Client (SetRouteT t r m) = SetRouteT t r (Client m)

263+ prerenderImpl server client = do

264+ liftIO $ putStrLn "SetRouteT prerenderImpl"

265+ (ma, dt) :: (Maybe a, Dynamic t (b, Event t (Endo r))) <- lift $ prerenderImpl

266+ (do ((a, b), e) <- runSetRouteT server; pure (a, (b, e)))

267+ (runSetRouteT client)

268+ -- Must be prompt here

269+ SetRouteT $ tellEvent $ switchPromptlyDyn $ Prelude.snd <$> dt

270+ pure (ma, Prelude.fst <$> dt)

259271

260272instance Requester t m => Requester t (SetRouteT t r m) where

261273 type Request (SetRouteT t r m) = Request m

@@ -325,8 +337,11 @@ instance HasJSContext m => HasJSContext (RouteToUrlT r m) where

325337 type JSContextPhantom (RouteToUrlT r m) = JSContextPhantom m

326338 askJSContext = lift askJSContext

327339

328−instance (Prerender js m, Monad m) => Prerender js (RouteToUrlT r m) where

329− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

340+instance (Prerender t m, Monad m) => Prerender t (RouteToUrlT r m) where

341+ type Client (RouteToUrlT r m) = RouteToUrlT r (Client m)

342+ prerenderImpl (RouteToUrlT server) client = do

343+ r <- RouteToUrlT ask

344+ RouteToUrlT $ prerenderImpl server (runRouteToUrlT client r)

330345

331346instance Requester t m => Requester t (RouteToUrlT r m) where

332347 type Request (RouteToUrlT r m) = Request m

@@ -386,10 +401,11 @@ runRouteViewT

386401 , MonadFix m

387402 )

388403 => (Encoder Identity Identity r PageName)

404+ -> Event t () -- ^ Switchover event, nothing is done until this event fires. Used to prevent incorrect DOM expectations at hydration switchover time

389405 -> RoutedT t r (SetRouteT t r (RouteToUrlT r m)) a

390406 -> m a

391−runRouteViewT routeEncoder a = do

392− rec historyState <- manageHistory $ HistoryCommand_PushState <$> setState

407+runRouteViewT routeEncoder switchover a = do

408+ rec historyState <- manageHistory' switchover $ HistoryCommand_PushState <$> setState

393409 let theEncoder = pageNameEncoder . hoistParse (pure . runIdentity) routeEncoder

394410 -- NB: The can only fail if the uriPath doesn't begin with a '/' or if the uriQuery

395411 -- is nonempty, but begins with a character that isn't '?'. Since we don't expect