git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/frontend/src/Obelisk/Frontend.hs
253 lines 9.1 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE UndecidableInstances #-}
14module Obelisk.Frontend
15 ( ObeliskWidget
16 , Frontend (..)
17 , runFrontend
18 , runFrontendWithConfigsAndCurrentRoute
19 , renderFrontendHtml
20 , removeHTMLConfigs
21 , FrontendMode (..)
22 , module Obelisk.Frontend.Cookie
23 ) where
25import Prelude hiding ((.))
27import Control.Category
28import Control.Lens
29import Control.Monad.Fix
30import Control.Monad.IO.Class
31import Control.Monad.Primitive
32import Control.Monad.Reader
33import Control.Monad.Ref
34import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
35import Data.ByteString (ByteString)
36import Data.Foldable (for_)
37import Data.Functor.Sum
38import Data.Map (Map)
39import Data.Maybe (catMaybes)
40import Data.Monoid ((<>))
41import Data.Text (Text)
42import qualified GHCJS.DOM as DOM
43import qualified GHCJS.DOM.Types as DOM
44import qualified GHCJS.DOM.History as DOM
45import qualified GHCJS.DOM.Window as DOM
46import Language.Javascript.JSaddle (MonadJSM, JSM, jsNull)
47import GHCJS.DOM (currentDocument)
48import GHCJS.DOM.Document (getHead)
49import GHCJS.DOM.Node (Node, removeChild_)
50import GHCJS.DOM.NodeList (IsNodeList, item, getLength)
51import GHCJS.DOM.ParentNode (querySelectorAll)
52import Obelisk.Frontend.Cookie
53import Obelisk.Route.Frontend
54import Reflex.Dom.Core
55import Reflex.Host.Class
56import Obelisk.Configs
57import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)
58import qualified Obelisk.ExecutableConfig.Lookup as Lookup
59import Web.Cookie
61import Debug.Trace
63makePrisms ''Sum
65type ObeliskWidget js t route m =
66 ( DomBuilder t m
67 , MonadFix m
68 , MonadHold t m
69 , MonadSample t (Performable m)
70 , MonadReflexCreateTrigger t m
71 , PostBuild t m
72 , PerformEvent t m
73 , TriggerEvent t m
74 , HasDocument m
75 , MonadRef m
76 , Ref m ~ Ref IO
77 , MonadRef (Performable m)
78 , Ref (Performable m) ~ Ref IO
79 , MonadFix (Performable m)
80 , PrimMonad m
81 , Prerender js t m
82 , PrebuildAgnostic t route m
83 , PrebuildAgnostic t route (Client m)
84 , HasConfigs m
85 , HasCookies m
86 )
88type PrebuildAgnostic t route m =
89 ( SetRoute t route m
90 , RouteToUrl route m
91 , MonadFix m
92 , HasConfigs m
93 , HasConfigs (Performable m)
94 )
96data Frontend route = Frontend
97 { _frontend_head :: !(forall js t m. ObeliskWidget js t route m => RoutedT t route m ())
98 , _frontend_body :: !(forall js t m. ObeliskWidget js t route m => RoutedT t route m ())
99 }
101baseTag :: forall route js t m. ObeliskWidget js t route m => RoutedT t route m ()
102baseTag = elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes
104removeHTMLConfigs :: JSM ()
105removeHTMLConfigs = void $ runMaybeT $ do
106 doc <- MaybeT currentDocument
107 hd <- MaybeT $ getHead doc
108 es <- nodeListNodes =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)
109 for_ es $ removeChild_ hd
111-- | Collect all nodes in the node list.
112--
113-- TODO: this and the version in exe-config/ghcjs/lookup should be
114-- upstreamed to jsaddle.
115nodeListNodes :: (IsNodeList l, MonadJSM m) => l -> m [Node]
116nodeListNodes es = do
117 len <- getLength es
118 -- Warning! len is unsigned. If the NodeList is empty, we must avoid
119 -- accidentally traversing over [0..maxBound::Word]
120 nodes <- traverse (item es) $ if len == 0 then [] else [0..len-1]
121 pure $ catMaybes nodes
123setInitialRoute :: Bool -> JSM ()
124setInitialRoute useHash = do
125 traceM "setInitialRoute"
126 window <- DOM.currentWindowUnchecked
127 initialLocation <- DOM.getLocation window
128 initialUri <- getLocationUri initialLocation
129 history <- DOM.getHistory window
130 DOM.replaceState history jsNull ("" :: Text) $ Just $
131 show $ setAdaptedUriPath useHash "/" initialUri
133data FrontendMode = FrontendMode
134 { _frontendMode_hydrate :: Bool
135 -- ^ There is already a rendering of the DOM in place; hydrate it rather
136 -- than building new DOM
137 , _frontendMode_adjustRoute :: Bool
138 -- ^ The page can't use regular routes, so encode routes into the hash
139 -- instead
140 }
142-- | Run the frontend, setting the initial route to "/" on platforms where no
143-- route exists ambiently in the context (e.g. anything but web).
144-- Selects FrontendMode based on platform; this doesn't work for jsaddle-warp
145runFrontend
146 :: forall backendRoute route
147 . Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
148 -> Frontend (R route)
149 -> JSM ()
150runFrontend validFullEncoder frontend = do
151 let mode = FrontendMode
152 { _frontendMode_hydrate =
153#ifdef ghcjs_HOST_OS
154 True
155#else
156 False
157#endif
158 , _frontendMode_adjustRoute =
159#ifdef ghcjs_HOST_OS
160 False
161#else
162 True
163#endif
164 }
165 configs <- liftIO Lookup.getConfigs
166 when (_frontendMode_hydrate mode) removeHTMLConfigs
167 -- There's no fundamental reason that adjustRoute needs to control setting the
168 -- initial route and *also* the useHash parameter; that's why these are
169 -- separate here. However, currently, they are always the same.
170 when (_frontendMode_adjustRoute mode) $ do
171 setInitialRoute $ _frontendMode_adjustRoute mode
172 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend
174runFrontendWithConfigsAndCurrentRoute
175 :: forall backendRoute route
176 . FrontendMode
177 -> Map Text ByteString
178 -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
179 -> Frontend (R route)
180 -> JSM ()
181runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do
182 let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _InR . _ObeliskRoute_App))
183 errorLeft = \case
184 Left _ -> error "runFrontend: Unexpected non-app ObeliskRoute reached the frontend. This shouldn't happen."
185 Right x -> Identity x
186 w :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s DomTimeline m)) ~ DOM.Document
187 , Ref (Performable m) ~ Ref IO
188 , Ref m ~ Ref IO
189 , DomBuilder DomTimeline (HydrationDomBuilderT s DomTimeline m)
190 , MonadHold DomTimeline m
191 , MonadRef m
192 , MonadRef (Performable m)
193 , MonadReflexCreateTrigger DomTimeline m
194 , PerformEvent DomTimeline m
195 , PostBuild DomTimeline m
196 , PrimMonad m
197 , MonadSample DomTimeline (Performable m)
198 , DOM.MonadJSM m
199 , Monad (Performable (Client (HydrationDomBuilderT s DomTimeline m)))
200 , MonadFix (Client (HydrationDomBuilderT s DomTimeline m))
201 , MonadFix (Performable m)
202 , MonadFix m
203 , Prerender js DomTimeline (HydrationDomBuilderT s DomTimeline m)
204 , MonadIO (Performable m)
205 )
206 => (forall c. HydrationDomBuilderT s DomTimeline m c -> FloatingWidget () c)
207 -> (forall c. HydrationDomBuilderT s DomTimeline m c -> FloatingWidget () c)
208 -> FloatingWidget () ()
209 w appendHead appendBody = do
210 rec switchover <- runRouteViewT ve switchover (_frontendMode_adjustRoute mode) $ do
211 (switchover'', fire) <- newTriggerEvent
212 mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendHead . runConfigsT configs))) $ do
213 -- The order here is important - baseTag has to be before headWidget!
214 baseTag
215 _frontend_head frontend
216 mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendBody . runConfigsT configs))) $ do
217 _frontend_body frontend
218 switchover' <- case _frontendMode_hydrate mode of
219 True -> lift $ lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
220 False -> getPostBuild
221 performEvent_ $ liftIO (fire ()) <$ switchover'
222 pure switchover''
223 pure ()
224 if _frontendMode_hydrate mode
225 then runHydrationWidgetWithHeadAndBody (pure ()) w
226 else runImmediateWidgetWithHeadAndBody w
228renderFrontendHtml
229 :: ( t ~ DomTimeline
230 , MonadIO m
231 , widget ~ RoutedT t r (SetRouteT t r (RouteToUrlT r (ConfigsT (CookiesT (PostBuildT t (StaticDomBuilderT t (PerformEventT t DomHost)))))))
232 )
233 => Map Text ByteString
234 -> Cookies
235 -> (r -> Text)
236 -> r
237 -> Frontend r
238 -> widget ()
239 -> widget ()
240 -> m ByteString
241renderFrontendHtml configs cookies urlEnc route frontend headExtra bodyExtra = do
242 --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline
243 html <- fmap snd $ liftIO $ renderStatic $ fmap fst $ runCookiesT cookies $ runConfigsT configs $ flip runRouteToUrlT urlEnc $ runSetRouteT $ flip runRoutedT (pure route) $
244 el "html" $ do
245 el "head" $ do
246 baseTag
247 injectExecutableConfigs configs
248 _frontend_head frontend
249 headExtra
250 el "body" $ do
251 _frontend_body frontend
252 bodyExtra
253 return $ "<!DOCTYPE html>" <> html