git.iko.soy/obelisk
on master help sign in
runFrontend: make head more like prerendered head

This fixes a problem where ghcjs and ob run would fail to hydrate the head because of tag mismatches. Remaining tag mismatches are at the very end of the head and body where they are (currently) harmless.

commitfe9bad09e05a760f0708e8d9aa7007372fa256f7 authorJames Deikun <james.deikun@obsidian.systems> dateFri 29 Mar 2019, 13:32 (8 years ago) parent076587a
6 files changed+162−16
compare with master
unifiedsplit
lib/backend/src/Obelisk/Backend.hs+1−3 lib/executable-config/inject/src/Obelisk/ExecutableConfig/Inject.hs+1−1 lib/frontend/obelisk-frontend.cabal+3 lib/frontend/src/Obelisk/Frontend.hs+49−11 lib/frontend/src/Obelisk/Frontend/Config.hs+107 lib/run/src/Obelisk/Run.hs+1−1
lib/backend/src/Obelisk/Backend.hs+1−3
@@ -193,9 +193,7 @@ renderGhcjsFrontend urlEnc route f = do
193193 let ghcjsPreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: "ghcjs/all.js") blank
194194 ghcjsScript = elAttr "script" ("language" =: "javascript" <> "src" =: "ghcjs/all.js" <> "defer" =: "defer") blank
195195 cookies <- askCookies
196− renderFrontendHtml cookies urlEnc route
197− (_frontend_head f >> ghcjsPreload)
198− (_frontend_body f >> ghcjsScript)
196+ renderFrontendHtml cookies urlEnc route f ghcjsPreload ghcjsScript
199197
200198instance HasCookies Snap where
201199 askCookies = map (\c -> (cookieName c, cookieValue c)) <$> getsRequest rqCookies
lib/executable-config/inject/src/Obelisk/ExecutableConfig/Inject.hs+1−1
@@ -22,7 +22,7 @@ inject key = do
2222-- whose value is the provided configuration
2323injectPure :: DomBuilder t m => Text -> Text -> m ()
2424injectPure key value =
25− let attrs = ("type" =: "text/plain" <> "id" =: ("config-" <> key))
25+ let attrs = ("type" =: "text/plain" <> "id" =: ("config-" <> key) <> "data-executable-config-inject" =: "1")
2626 in elAttr "script" attrs $ text value
2727
2828-- | Scans the "common" and "frontend" configuration folders and produces
lib/frontend/obelisk-frontend.cabal+3
@@ -7,12 +7,14 @@ library
77 hs-source-dirs: src
88 build-depends: base,
99 bytestring,
10+ containers,
1011 cookie,
1112 dependent-sum,
1213 ghcjs-dom,
1314 jsaddle,
1415 lens,
1516 mtl,
17+ obelisk-executable-config,
1618 obelisk-executable-config-inject,
1719 obelisk-route,
1820 primitive,
@@ -23,5 +25,6 @@ library
2325 transformers
2426 exposed-modules:
2527 Obelisk.Frontend
28+ Obelisk.Frontend.Config
2629 Obelisk.Frontend.Cookie
2730 ghc-options: -Wall
lib/frontend/src/Obelisk/Frontend.hs+49−11
@@ -27,16 +27,27 @@ import Control.Monad.IO.Class
2727import Control.Monad.Primitive
2828import Control.Monad.Reader
2929import Control.Monad.Ref
30+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
3031import Data.ByteString (ByteString)
32+import Data.Foldable (for_)
3133import Data.Functor.Sum
34+import qualified Data.Map as Map
35+import Data.Maybe (catMaybes, isJust)
3236import Data.Monoid ((<>))
3337import Data.Text (Text)
38+import GHCJS.DOM (currentDocument)
39+import GHCJS.DOM.Document (getHead)
40+import GHCJS.DOM.Element (getAttribute, getElementsByTagName)
41+import GHCJS.DOM.HTMLCollection (item, getLength)
42+import GHCJS.DOM.Node (removeChild_)
3443import Language.Javascript.JSaddle (JSM)
44+import Obelisk.Frontend.Config
3545import Obelisk.Frontend.Cookie
3646import Obelisk.Route.Frontend
3747import Reflex.Dom.Core
3848import Reflex.Host.Class
3949import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)
50+import Obelisk.ExecutableConfig.Internal (getFrontendConfigs)
4051import Web.Cookie
4152
4253makePrisms ''Sum
@@ -60,6 +71,7 @@ type ObeliskWidget js t route m =
6071 , Prerender js t m
6172 , PrebuildAgnostic t route m
6273 , PrebuildAgnostic t route (Client m)
74+ , HasConfigs m
6375 , HasCookies m
6476 -- TODO Remove these. Probably requires a new class to allow executable-configs to work without being inside a `prerender`
6577 , MonadIO m
@@ -77,6 +89,23 @@ data Frontend route = Frontend
7789 , _frontend_body :: !(forall js t m. ObeliskWidget js t route m => RoutedT t route m ())
7890 }
7991
92+baseTag :: forall route js t m. ObeliskWidget js t route m => RoutedT t route m ()
93+baseTag = elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes
94+
95+removeHTMLConfigs :: JSM ()
96+removeHTMLConfigs = void $ runMaybeT $ do
97+ doc <- MaybeT currentDocument
98+ hd <- MaybeT $ getHead doc
99+ es <- collToList =<< getElementsByTagName hd ("script" :: Text)
100+ for_ es $ \e -> do
101+ isConfig <- (isJust :: Maybe Text -> Bool) <$> getAttribute e ("data-executable-config-inject" :: Text)
102+ when isConfig $ removeChild_ hd e
103+ where
104+ collToList es = do
105+ len <- getLength es
106+ lst <- traverse (item es) $ take (fromIntegral len) $ [0..] -- fun with unsigned types ...
107+ pure $ catMaybes lst
108+
80109runFrontend
81110 :: forall backendRoute route
82111 . Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
@@ -87,14 +116,18 @@ runFrontend validFullEncoder frontend = do
87116 errorLeft = \case
88117 Left _ -> error "runFrontend: Unexpected non-app ObeliskRoute reached the frontend. This shouldn't happen."
89118 Right x -> Identity x
119+ configs <- liftIO $ Map.fromList <$> getFrontendConfigs
120+ removeHTMLConfigs
90121 runHydrationWidgetWithHeadAndBody (pure ()) $ \appendHead appendBody -> do
91122 rec switchover <- runRouteViewT ve switchover $ do
92123 (switchover'', fire) <- newTriggerEvent
93− mapRoutedT (mapSetRouteT (mapRouteToUrlT appendHead)) $ do
124+ mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendHead . runConfigsT configs))) $ do
125+ -- The order here is important - baseTag has to be before headWidget!
126+ baseTag
94127 _frontend_head frontend
95− mapRoutedT (mapSetRouteT (mapRouteToUrlT appendBody)) $ do
128+ mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendBody . runConfigsT configs))) $ do
96129 _frontend_body frontend
97− switchover' <- lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
130+ switchover' <- lift $ lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
98131 performEvent_ $ liftIO (fire ()) <$ switchover'
99132 pure switchover''
100133 pure ()
@@ -102,21 +135,26 @@ runFrontend validFullEncoder frontend = do
102135renderFrontendHtml
103136 :: ( t ~ DomTimeline
104137 , MonadIO m
105− , widget ~ RoutedT t r (SetRouteT t r' (RouteToUrlT r' (CookiesT (PostBuildT t (StaticDomBuilderT t (PerformEventT t DomHost))))))
138+ , widget ~ RoutedT t r (SetRouteT t r (RouteToUrlT r (ConfigsT (CookiesT (PostBuildT t (StaticDomBuilderT t (PerformEventT t DomHost)))))))
106139 )
107140 => Cookies
108− -> (r' -> Text)
141+ -> (r -> Text)
109142 -> r
143+ -> Frontend r
110144 -> widget ()
111145 -> widget ()
112146 -> m ByteString
113−renderFrontendHtml cookies urlEnc route headWidget bodyWidget = do
147+renderFrontendHtml cookies urlEnc route frontend headExtra bodyExtra = do
114148 --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline
115− html <- fmap snd $ liftIO $ renderStatic $ fmap fst $ runCookiesT cookies $ flip runRouteToUrlT urlEnc $ runSetRouteT $ flip runRoutedT (pure route) $
149+ configs <- liftIO $ Map.fromList <$> getFrontendConfigs
150+ html <- fmap snd $ liftIO $ renderStatic $ fmap fst $ runCookiesT cookies $ runConfigsT configs $ flip runRouteToUrlT urlEnc $ runSetRouteT $ flip runRoutedT (pure route) $
116151 el "html" $ do
117152 el "head" $ do
118− let baseTag = elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes
119− -- The order here is important - baseTag has to be before headWidget!
120− baseTag >> injectExecutableConfigs >> headWidget
121− el "body" bodyWidget
153+ baseTag
154+ injectExecutableConfigs
155+ _frontend_head frontend
156+ headExtra
157+ el "body" $ do
158+ _frontend_body frontend
159+ bodyExtra
122160 return $ "<!DOCTYPE html>" <> html
lib/frontend/src/Obelisk/Frontend/Config.hsnew file+107
@@ -0,0 +1,107 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DefaultSignatures #-}
4+{-# LANGUAGE DeriveFunctor #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+module Obelisk.Frontend.Config where
14+
15+import Control.Monad.Fix
16+import Control.Monad.Primitive
17+import Control.Monad.Ref
18+import Control.Monad.IO.Class
19+import Control.Monad.Trans.Class
20+import Control.Monad.Trans.Reader
21+import Data.Map (Map)
22+import qualified Data.Map as Map
23+import Data.Text (Text)
24+import Reflex
25+import Reflex.Host.Class
26+import Reflex.Dom.Core
27+import GHCJS.DOM.Types (MonadJSM)
28+
29+import Obelisk.Frontend.Cookie (CookiesT, HasCookies)
30+import Obelisk.Route.Frontend
31+
32+newtype Configs = Configs { unConfigs :: Map Text Text }
33+
34+class Monad m => HasConfigs m where
35+ askConfigs :: m Configs
36+ default askConfigs :: (HasConfigs m', m ~ t m', MonadTrans t) => m Configs
37+ askConfigs = lift askConfigs
38+
39+instance HasConfigs m => HasConfigs (BehaviorWriterT t w m)
40+instance HasConfigs m => HasConfigs (DynamicWriterT t w m)
41+instance HasConfigs m => HasConfigs (EventWriterT t w m)
42+instance HasConfigs m => HasConfigs (PostBuildT t m)
43+instance HasConfigs m => HasConfigs (QueryT t q m)
44+instance HasConfigs m => HasConfigs (ReaderT r m)
45+instance HasConfigs m => HasConfigs (RequesterT t request response m)
46+instance HasConfigs m => HasConfigs (RouteToUrlT t m)
47+instance HasConfigs m => HasConfigs (SetRouteT t r m)
48+instance HasConfigs m => HasConfigs (StaticDomBuilderT t m)
49+instance HasConfigs m => HasConfigs (TriggerEventT t m)
50+instance HasConfigs m => HasConfigs (RoutedT t r m)
51+instance HasConfigs m => HasConfigs (CookiesT m)
52+instance HasCookies m => HasCookies (ConfigsT m)
53+
54+newtype ConfigsT m a = ConfigsT { unConfigsT :: ReaderT Configs m a }
55+ deriving
56+ ( Functor
57+ , Applicative
58+ , DomBuilder t
59+ , Monad
60+ , MonadFix
61+ , MonadHold t
62+ , MonadIO
63+#ifndef ghcjs_HOST_OS
64+ , MonadJSM
65+#endif
66+ , MonadRef
67+ , MonadReflexCreateTrigger t
68+ , MonadSample t
69+ , MonadTrans
70+ , NotReady t
71+ , PerformEvent t
72+ , PostBuild t
73+ , Prerender js t
74+ , TriggerEvent t
75+ , HasDocument
76+ )
77+
78+instance Adjustable t m => Adjustable t (ConfigsT m) where
79+ runWithReplace a e = ConfigsT $ runWithReplace (unConfigsT a) (unConfigsT <$> e)
80+ traverseDMapWithKeyWithAdjust f m e = ConfigsT $ traverseDMapWithKeyWithAdjust (\k v -> unConfigsT $ f k v) m e
81+ traverseIntMapWithKeyWithAdjust f m e = ConfigsT $ traverseIntMapWithKeyWithAdjust (\k v -> unConfigsT $ f k v) m e
82+ traverseDMapWithKeyWithAdjustWithMove f m e = ConfigsT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unConfigsT $ f k v) m e
83+
84+instance PrimMonad m => PrimMonad (ConfigsT m) where
85+ type PrimState (ConfigsT m) = PrimState m
86+ primitive = lift . primitive
87+
88+runConfigsT
89+ :: Map Text Text
90+ -> ConfigsT m a
91+ -> m a
92+runConfigsT cs child = runReaderT (unConfigsT child) (Configs cs)
93+
94+instance Monad m => HasConfigs (ConfigsT m) where
95+ askConfigs = ConfigsT ask
96+
97+mapConfigsT
98+ :: (forall x. m x -> n x)
99+ -> ConfigsT m a
100+ -> ConfigsT n a
101+mapConfigsT f (ConfigsT x) = ConfigsT $ mapReaderT f x
102+
103+getConfig
104+ :: HasConfigs m
105+ => Text
106+ -> m (Maybe Text)
107+getConfig key = Map.lookup key . unConfigs <$> askConfigs
lib/run/src/Obelisk/Run.hs+1−1
@@ -149,7 +149,7 @@ renderJsaddleFrontend :: Cookies -> (route -> Text) -> route -> Frontend route -
149149renderJsaddleFrontend cookies urlEnc r f =
150150 let jsaddleScript = elAttr "script" ("src" =: "/jsaddle/jsaddle.js") blank
151151 jsaddlePreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: "/jsaddle/jsaddle.js") blank
152− in renderFrontendHtml cookies urlEnc r (_frontend_head f >> jsaddlePreload) (_frontend_body f >> jsaddleScript)
152+ in renderFrontendHtml cookies urlEnc r f jsaddlePreload jsaddleScript
153153
154154-- | like 'bindPortTCP' but reconnects on exception
155155bindPortTCPRetry :: Settings