@@ -1,3 +1,4 @@
1+{-# LANGUAGE DeriveFunctor #-}
12{-# LANGUAGE FlexibleContexts #-}
23{-# LANGUAGE FlexibleInstances #-}
34{-# LANGUAGE GADTs #-}
@@ -12,9 +13,15 @@ module Obelisk.Backend
1213 -- * Running a backend
1314 , runBackend
1415 , runBackendWith
16+ -- * Configuration of backend
17+ , GhcjsWidgets
18+ , GhcjsWidgetsImpl(..)
19+ , defaultGhcjsWidgets
1520 -- * all.js script loading functions
1621 , deferredGhcjsScript
1722 , delayedGhcjsScript
23+ -- * all.js preload functions
24+ , preloadGhcjs
1825 -- * Re-exports
1926 , Default (def)
2027 , getPageName
@@ -63,20 +70,37 @@ data GhcjsApp route = GhcjsApp
6370 , _ghcjsApp_value :: !(Frontend route)
6471 }
6572
73+type GhcjsWidgets r = GhcjsWidgetsImpl (Text -> FrontendWidgetT r ())
74+
75+-- | Widgets used to load all.js on the frontend
76+data GhcjsWidgetsImpl a = GhcjsWidgets
77+ { _ghcjsWidgets_preload :: a
78+ -- ^ A preload widget, placed in the document head
79+ , _ghcjsWidgets_script :: a
80+ -- ^ A script widget, placed in the document body
81+ } deriving Functor
82+
83+-- | Given the URL of all.js, return the widgets which are responsible for
84+-- loading the script. Defaults to 'preloadGhcjs' and 'deferredGhcjsScript'.
85+defaultGhcjsWidgets :: GhcjsWidgets r
86+defaultGhcjsWidgets = GhcjsWidgets
87+ { _ghcjsWidgets_preload = preloadGhcjs
88+ , _ghcjsWidgets_script = deferredGhcjsScript
89+ }
90+
6691-- | Serve a frontend, which must be the same frontend that Obelisk has built and placed in the default location
6792--TODO: The frontend should be provided together with the asset paths so that this isn't so easily breakable; that will probably make this function obsolete
6893serveDefaultObeliskApp
6994 :: (MonadSnap m, HasCookies m, MonadFail m)
7095 => (R appRoute -> Text)
71− -> Text -- ^ URL to GHCJS app JavaScript
72− -> (Text -> FrontendWidgetT (R appRoute) ()) -- ^ GHCJS all.js script widget
96+ -> GhcjsWidgetsImpl (FrontendWidgetT (R appRoute) ())
7397 -> ([Text] -> m ())
7498 -> Frontend (R appRoute)
7599 -> Map Text ByteString
76100 -> R (ObeliskRoute appRoute)
77101 -> m ()
78−serveDefaultObeliskApp urlEnc allJsUrl ghcjsScript serveStaticAsset frontend =
79− serveObeliskApp urlEnc allJsUrl ghcjsScript serveStaticAsset frontendApp
102+serveDefaultObeliskApp urlEnc ghcjsWidgets serveStaticAsset frontend =
103+ serveObeliskApp urlEnc ghcjsWidgets serveStaticAsset frontendApp
80104 where frontendApp = GhcjsApp
81105 { _ghcjsApp_compiled = defaultFrontendGhcjsAssets
82106 , _ghcjsApp_value = frontend
@@ -130,18 +154,17 @@ renderAllJsPath validFullEncoder =
130154serveObeliskApp
131155 :: (MonadSnap m, HasCookies m, MonadFail m)
132156 => (R appRoute -> Text)
133− -> Text -- ^ URL to GHCJS app JavaScript
134− -> (Text -> FrontendWidgetT (R appRoute) ()) -- ^ GHCJS all.js script widget
157+ -> GhcjsWidgetsImpl (FrontendWidgetT (R appRoute) ())
135158 -> ([Text] -> m ())
136159 -> GhcjsApp (R appRoute)
137160 -> Map Text ByteString
138161 -> R (ObeliskRoute appRoute)
139162 -> m ()
140−serveObeliskApp urlEnc allJsUrl ghcjsScript serveStaticAsset frontendApp config = \case
141− ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc allJsUrl ghcjsScript frontendApp config $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest
163+serveObeliskApp urlEnc ghcjsWidgets serveStaticAsset frontendApp config = \case
164+ ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc ghcjsWidgets frontendApp config $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest
142165 ObeliskRoute_Resource resComponent :=> Identity resRest -> case resComponent :=> Identity resRest of
143166 ResourceRoute_Static :=> Identity pathSegments -> serveStaticAsset pathSegments
144− ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc allJsUrl ghcjsScript frontendApp config $ GhcjsAppRoute_Resource :/ pathSegments
167+ ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc ghcjsWidgets frontendApp config $ GhcjsAppRoute_Resource :/ pathSegments
145168 ResourceRoute_JSaddleWarp :=> Identity _ -> do
146169 let msg = "Error: Obelisk.Backend received jsaddle request"
147170 liftIO $ putStrLn $ T.unpack msg
@@ -168,28 +191,29 @@ staticRenderContentType = "text/html; charset=utf-8"
168191serveGhcjsApp
169192 :: (MonadSnap m, HasCookies m, MonadFail m)
170193 => (R appRouteComponent -> Text)
171− -> Text -- ^ URL to GHCJS app JavaScript
172− -> (Text -> FrontendWidgetT (R appRouteComponent) ()) -- ^ GHCJS all.js script widget
194+ -> GhcjsWidgetsImpl (FrontendWidgetT (R appRouteComponent) ())
173195 -> GhcjsApp (R appRouteComponent)
174196 -> Map Text ByteString
175197 -> R (GhcjsAppRoute appRouteComponent)
176198 -> m ()
177−serveGhcjsApp urlEnc allJsUrl ghcjsScript app config = \case
199+serveGhcjsApp urlEnc ghcjsWidgets app config = \case
178200 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do
179201 modifyResponse $ setContentType staticRenderContentType
180202 modifyResponse $ setHeader "Cache-Control" "no-store private"
181− writeBS <=< renderGhcjsFrontend urlEnc allJsUrl ghcjsScript (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app
203+ writeBS <=< renderGhcjsFrontend urlEnc ghcjsWidgets (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app
182204 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments
183205
184206runBackend :: Backend backendRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
185−runBackend = runBackendWith deferredGhcjsScript
207+runBackend = runBackendWith defaultGhcjsWidgets
186208
187209runBackendWith
188− :: (Text -> FrontendWidgetT (R frontendRoute) ()) -- ^ GHCJS all.js script widget
210+ :: GhcjsWidgets (R frontendRoute)
211+ -- ^ Given the URL of all.js, return the widgets which are responsible for
212+ -- loading the script.
189213 -> Backend backendRoute frontendRoute
190214 -> Frontend (R frontendRoute)
191215 -> IO ()
192−runBackendWith ghcjsScript backend frontend = case checkEncoder $ _backend_routeEncoder backend of
216+runBackendWith ghcjsWidgets backend frontend = case checkEncoder $ _backend_routeEncoder backend of
193217 Left e -> fail $ "backend error:\n" <> T.unpack e
194218 Right validFullEncoder -> do
195219 publicConfigs <- getPublicConfigs
@@ -199,7 +223,7 @@ runBackendWith ghcjsScript backend frontend = case checkEncoder $ _backend_route
199223 Identity r -> case r of
200224 FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a
201225 FullRoute_Frontend obeliskRoute :/ a ->
202− serveDefaultObeliskApp routeToUrl allJsUrl ghcjsScript (serveStaticAssets defaultStaticAssets) frontend publicConfigs $
226+ serveDefaultObeliskApp routeToUrl (($ allJsUrl) <$> ghcjsWidgets) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $
203227 obeliskRoute :/ a
204228 where
205229 routeToUrl (k :/ v) = renderObeliskRoute validFullEncoder $ FullRoute_Frontend (ObeliskRoute_App k) :/ v
@@ -208,16 +232,19 @@ runBackendWith ghcjsScript backend frontend = case checkEncoder $ _backend_route
208232renderGhcjsFrontend
209233 :: (MonadSnap m, HasCookies m)
210234 => (route -> Text)
211− -> Text
212− -> (Text -> FrontendWidgetT route ()) -- ^ GHCJS all.js script widget
235+ -> GhcjsWidgetsImpl (FrontendWidgetT route ())
213236 -> route
214237 -> Map Text ByteString
215238 -> Frontend route
216239 -> m ByteString
217−renderGhcjsFrontend urlEnc allJsUrl ghcjsScript route configs f = do
218− let ghcjsPreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: allJsUrl) blank
240+renderGhcjsFrontend urlEnc ghcjsWidgets route configs f = do
219241 cookies <- askCookies
220− renderFrontendHtml configs cookies urlEnc route f ghcjsPreload (ghcjsScript allJsUrl)
242+ renderFrontendHtml configs cookies urlEnc route f (_ghcjsWidgets_preload ghcjsWidgets) (_ghcjsWidgets_script ghcjsWidgets)
243+
244+-- | Preload all.js in a link tag.
245+-- This is the default preload method.
246+preloadGhcjs :: Text -> FrontendWidgetT r ()
247+preloadGhcjs allJsUrl = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: allJsUrl) blank
221248
222249-- | Load the script from the given URL in a deferred script tag.
223250-- This is the default method.