@@ -1,5 +1,5 @@
1−{-# LANGUAGE ConstraintKinds #-}
21{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE LambdaCase #-}
@@ -15,9 +15,10 @@ module Obelisk.Frontend
1515 ( ObeliskWidget
1616 , Frontend (..)
1717 , runFrontend
18− , runFrontendWithConfigs
18+ , runFrontendWithConfigsAndCurrentRoute
1919 , renderFrontendHtml
2020 , removeHTMLConfigs
21+ , FrontendMode (..)
2122 , module Obelisk.Frontend.Cookie
2223 ) where
2324
@@ -38,12 +39,16 @@ import Data.Map (Map)
3839import Data.Maybe (catMaybes)
3940import Data.Monoid ((<>))
4041import Data.Text (Text)
42+import qualified GHCJS.DOM as DOM
43+import qualified GHCJS.DOM.Types as DOM
44+import qualified GHCJS.DOM.History as DOM
45+import qualified GHCJS.DOM.Window as DOM
46+import Language.Javascript.JSaddle (JSM, jsNull)
4147import GHCJS.DOM (currentDocument)
4248import GHCJS.DOM.Document (getHead)
4349import GHCJS.DOM.Node (removeChild_)
4450import GHCJS.DOM.NodeList (item, getLength)
4551import GHCJS.DOM.ParentNode (querySelectorAll)
46−import Language.Javascript.JSaddle (JSM)
4752import Obelisk.Frontend.Cookie
4853import Obelisk.Route.Frontend
4954import Reflex.Dom.Core
@@ -53,6 +58,8 @@ import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)
5358import Obelisk.ExecutableConfig.Lookup (getConfigs)
5459import Web.Cookie
5560
61+import Debug.Trace
62+
5663makePrisms ''Sum
5764
5865type ObeliskWidget js t route m =
@@ -106,42 +113,110 @@ removeHTMLConfigs = void $ runMaybeT $ do
106113 lst <- traverse (item es) $ take (fromIntegral len) $ [0..] -- fun with unsigned types ...
107114 pure $ catMaybes lst
108115
116+setInitialRoute :: Bool -> JSM ()
117+setInitialRoute useHash = do
118+ traceM "setInitialRoute"
119+ window <- DOM.currentWindowUnchecked
120+ initialLocation <- DOM.getLocation window
121+ initialUri <- getLocationUri initialLocation
122+ history <- DOM.getHistory window
123+ DOM.replaceState history jsNull ("" :: Text) $ Just $
124+ show $ setAdaptedUriPath useHash "/" initialUri
125+
126+data FrontendMode = FrontendMode
127+ { _frontendMode_hydrate :: Bool
128+ -- ^ There is already a rendering of the DOM in place; hydrate it rather
129+ -- than building new DOM
130+ , _frontendMode_adjustRoute :: Bool
131+ -- ^ The page can't use regular routes, so encode routes into the hash
132+ -- instead
133+ }
134+
135+-- | Run the frontend, setting the initial route to "/" on platforms where no
136+-- route exists ambiently in the context (e.g. anything but web).
137+-- Selects FrontendMode based on platform; this doesn't work for jsaddle-warp
109138runFrontend
110139 :: forall backendRoute route
111140 . Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
112141 -> Frontend (R route)
113142 -> JSM ()
114143runFrontend validFullEncoder frontend = do
115− configs <- liftIO getConfigs
144+ let mode = FrontendMode
145+ { _frontendMode_hydrate =
116146#ifdef ghcjs_HOST_OS
117− removeHTMLConfigs
147+ True
148+#else
149+ False
118150#endif
119− runFrontendWithConfigs configs validFullEncoder frontend
151+ , _frontendMode_adjustRoute =
152+#ifdef ghcjs_HOST_OS
153+ False
154+#else
155+ True
156+#endif
157+ }
158+ configs <- liftIO getConfigs
159+ when (_frontendMode_hydrate mode) removeHTMLConfigs
160+ -- There's no fundamental reason that adjustRoute needs to control setting the
161+ -- initial route and *also* the useHash parameter; that's why these are
162+ -- separate here. However, currently, they are always the same.
163+ when (_frontendMode_adjustRoute mode) $ do
164+ setInitialRoute $ _frontendMode_adjustRoute mode
165+ runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend
120166
121−runFrontendWithConfigs
167+runFrontendWithConfigsAndCurrentRoute
122168 :: forall backendRoute route
123− . Map Text Text
169+ . FrontendMode
170+ -> Map Text Text
124171 -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
125172 -> Frontend (R route)
126173 -> JSM ()
127−runFrontendWithConfigs configs validFullEncoder frontend = do
174+runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do
128175 let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _InR . _ObeliskRoute_App))
129176 errorLeft = \case
130177 Left _ -> error "runFrontend: Unexpected non-app ObeliskRoute reached the frontend. This shouldn't happen."
131178 Right x -> Identity x
132− runHydrationWidgetWithHeadAndBody (pure ()) $ \appendHead appendBody -> do
133− rec switchover <- runRouteViewT ve switchover $ do
134− (switchover'', fire) <- newTriggerEvent
135− mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendHead . runFrontendConfigsT configs))) $ do
136− -- The order here is important - baseTag has to be before headWidget!
137− baseTag
138− _frontend_head frontend
139− mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendBody . runFrontendConfigsT configs))) $ do
140− _frontend_body frontend
141− switchover' <- lift $ lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
142− performEvent_ $ liftIO (fire ()) <$ switchover'
143− pure switchover''
144− pure ()
179+ w :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s DomTimeline m)) ~ DOM.Document
180+ , Ref (Performable m) ~ Ref IO
181+ , Ref m ~ Ref IO
182+ , DomBuilder DomTimeline (HydrationDomBuilderT s DomTimeline m)
183+ , MonadHold DomTimeline m
184+ , MonadRef m
185+ , MonadRef (Performable m)
186+ , MonadReflexCreateTrigger DomTimeline m
187+ , PerformEvent DomTimeline m
188+ , PostBuild DomTimeline m
189+ , PrimMonad m
190+ , MonadSample DomTimeline (Performable m)
191+ , DOM.MonadJSM m
192+ , Monad (Performable (Client (HydrationDomBuilderT s DomTimeline m)))
193+ , MonadFix (Client (HydrationDomBuilderT s DomTimeline m))
194+ , MonadFix (Performable m)
195+ , MonadFix m
196+ , Prerender js DomTimeline (HydrationDomBuilderT s DomTimeline m)
197+ , MonadIO (Performable m)
198+ )
199+ => (forall c. HydrationDomBuilderT s DomTimeline m c -> FloatingWidget () c)
200+ -> (forall c. HydrationDomBuilderT s DomTimeline m c -> FloatingWidget () c)
201+ -> FloatingWidget () ()
202+ w appendHead appendBody = do
203+ rec switchover <- runRouteViewT ve switchover (_frontendMode_adjustRoute mode) $ do
204+ (switchover'', fire) <- newTriggerEvent
205+ mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendHead . runFrontendConfigsT configs))) $ do
206+ -- The order here is important - baseTag has to be before headWidget!
207+ baseTag
208+ _frontend_head frontend
209+ mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendBody . runFrontendConfigsT configs))) $ do
210+ _frontend_body frontend
211+ switchover' <- case _frontendMode_hydrate mode of
212+ True -> lift $ lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
213+ False -> getPostBuild
214+ performEvent_ $ liftIO (fire ()) <$ switchover'
215+ pure switchover''
216+ pure ()
217+ if _frontendMode_hydrate mode
218+ then runHydrationWidgetWithHeadAndBody (pure ()) w
219+ else runImmediateWidgetWithHeadAndBody w
145220
146221renderFrontendHtml
147222 :: ( t ~ DomTimeline