@@ -1,3 +1,4 @@
1+{-# LANGUAGE DeriveFunctor #-}
12{-# LANGUAGE FlexibleContexts #-}
23{-# LANGUAGE FlexibleInstances #-}
34{-# LANGUAGE GADTs #-}
@@ -9,6 +10,17 @@
910{-# OPTIONS_GHC -fno-warn-orphans #-}
1011module Obelisk.Backend
1112 ( Backend (..)
13+ -- * Running a backend
14+ , runBackend
15+ , runBackendWith
16+ -- * Configuration of backend
17+ , GhcjsWidgets(..)
18+ , defaultGhcjsWidgets
19+ -- * all.js script loading functions
20+ , deferredGhcjsScript
21+ , delayedGhcjsScript
22+ -- * all.js preload functions
23+ , preloadGhcjs
1224 -- * Re-exports
1325 , Default (def)
1426 , getPageName
@@ -17,7 +29,6 @@ module Obelisk.Backend
1729 , serveDefaultObeliskApp
1830 , prettifyOutput
1931 , renderAllJsPath
20− , runBackend
2132 , staticRenderContentType
2233 , getPublicConfigs
2334 ) where
@@ -58,19 +69,35 @@ data GhcjsApp route = GhcjsApp
5869 , _ghcjsApp_value :: !(Frontend route)
5970 }
6071
72+-- | Widgets used to load all.js on the frontend
73+data GhcjsWidgets a = GhcjsWidgets
74+ { _ghcjsWidgets_preload :: a
75+ -- ^ A preload widget, placed in the document head
76+ , _ghcjsWidgets_script :: a
77+ -- ^ A script widget, placed in the document body
78+ } deriving Functor
79+
80+-- | Given the URL of all.js, return the widgets which are responsible for
81+-- loading the script. Defaults to 'preloadGhcjs' and 'deferredGhcjsScript'.
82+defaultGhcjsWidgets :: GhcjsWidgets (Text -> FrontendWidgetT r ())
83+defaultGhcjsWidgets = GhcjsWidgets
84+ { _ghcjsWidgets_preload = preloadGhcjs
85+ , _ghcjsWidgets_script = deferredGhcjsScript
86+ }
87+
6188-- | Serve a frontend, which must be the same frontend that Obelisk has built and placed in the default location
6289--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
6390serveDefaultObeliskApp
6491 :: (MonadSnap m, HasCookies m, MonadFail m)
6592 => (R appRoute -> Text)
66− -> Text -- ^ URL to GHCJS app JavaScript
93+ -> GhcjsWidgets (FrontendWidgetT (R appRoute) ())
6794 -> ([Text] -> m ())
6895 -> Frontend (R appRoute)
6996 -> Map Text ByteString
7097 -> R (ObeliskRoute appRoute)
7198 -> m ()
72−serveDefaultObeliskApp urlEnc allJsUrl serveStaticAsset frontend =
73− serveObeliskApp urlEnc allJsUrl serveStaticAsset frontendApp
99+serveDefaultObeliskApp urlEnc ghcjsWidgets serveStaticAsset frontend =
100+ serveObeliskApp urlEnc ghcjsWidgets serveStaticAsset frontendApp
74101 where frontendApp = GhcjsApp
75102 { _ghcjsApp_compiled = defaultFrontendGhcjsAssets
76103 , _ghcjsApp_value = frontend
@@ -124,17 +151,17 @@ renderAllJsPath validFullEncoder =
124151serveObeliskApp
125152 :: (MonadSnap m, HasCookies m, MonadFail m)
126153 => (R appRoute -> Text)
127− -> Text -- ^ URL to GHCJS app JavaScript
154+ -> GhcjsWidgets (FrontendWidgetT (R appRoute) ())
128155 -> ([Text] -> m ())
129156 -> GhcjsApp (R appRoute)
130157 -> Map Text ByteString
131158 -> R (ObeliskRoute appRoute)
132159 -> m ()
133−serveObeliskApp urlEnc allJsUrl serveStaticAsset frontendApp config = \case
134− ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc allJsUrl frontendApp config $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest
160+serveObeliskApp urlEnc ghcjsWidgets serveStaticAsset frontendApp config = \case
161+ ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc ghcjsWidgets frontendApp config $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest
135162 ObeliskRoute_Resource resComponent :=> Identity resRest -> case resComponent :=> Identity resRest of
136163 ResourceRoute_Static :=> Identity pathSegments -> serveStaticAsset pathSegments
137− ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc allJsUrl frontendApp config $ GhcjsAppRoute_Resource :/ pathSegments
164+ ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc ghcjsWidgets frontendApp config $ GhcjsAppRoute_Resource :/ pathSegments
138165 ResourceRoute_JSaddleWarp :=> Identity _ -> do
139166 let msg = "Error: Obelisk.Backend received jsaddle request"
140167 liftIO $ putStrLn $ T.unpack msg
@@ -161,20 +188,29 @@ staticRenderContentType = "text/html; charset=utf-8"
161188serveGhcjsApp
162189 :: (MonadSnap m, HasCookies m, MonadFail m)
163190 => (R appRouteComponent -> Text)
164− -> Text -- ^ URL to GHCJS app JavaScript
191+ -> GhcjsWidgets (FrontendWidgetT (R appRouteComponent) ())
165192 -> GhcjsApp (R appRouteComponent)
166193 -> Map Text ByteString
167194 -> R (GhcjsAppRoute appRouteComponent)
168195 -> m ()
169−serveGhcjsApp urlEnc allJsUrl app config = \case
196+serveGhcjsApp urlEnc ghcjsWidgets app config = \case
170197 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do
171198 modifyResponse $ setContentType staticRenderContentType
172199 modifyResponse $ setHeader "Cache-Control" "no-store private"
173− writeBS <=< renderGhcjsFrontend urlEnc allJsUrl (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app
200+ writeBS <=< renderGhcjsFrontend urlEnc ghcjsWidgets (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app
174201 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments
175202
176203runBackend :: Backend backendRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
177−runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of
204+runBackend = runBackendWith defaultGhcjsWidgets
205+
206+runBackendWith
207+ :: GhcjsWidgets (Text -> FrontendWidgetT (R frontendRoute) ())
208+ -- ^ Given the URL of all.js, return the widgets which are responsible for
209+ -- loading the script.
210+ -> Backend backendRoute frontendRoute
211+ -> Frontend (R frontendRoute)
212+ -> IO ()
213+runBackendWith ghcjsWidgets backend frontend = case checkEncoder $ _backend_routeEncoder backend of
178214 Left e -> fail $ "backend error:\n" <> T.unpack e
179215 Right validFullEncoder -> do
180216 publicConfigs <- getPublicConfigs
@@ -184,7 +220,7 @@ runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend
184220 Identity r -> case r of
185221 FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a
186222 FullRoute_Frontend obeliskRoute :/ a ->
187− serveDefaultObeliskApp routeToUrl allJsUrl (serveStaticAssets defaultStaticAssets) frontend publicConfigs $
223+ serveDefaultObeliskApp routeToUrl (($ allJsUrl) <$> ghcjsWidgets) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $
188224 obeliskRoute :/ a
189225 where
190226 routeToUrl (k :/ v) = renderObeliskRoute validFullEncoder $ FullRoute_Frontend (ObeliskRoute_App k) :/ v
@@ -193,16 +229,40 @@ runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend
193229renderGhcjsFrontend
194230 :: (MonadSnap m, HasCookies m)
195231 => (route -> Text)
196− -> Text -- ^ URL to GHCJS app JavaScript
232+ -> GhcjsWidgets (FrontendWidgetT route ())
197233 -> route
198234 -> Map Text ByteString
199235 -> Frontend route
200236 -> m ByteString
201−renderGhcjsFrontend urlEnc allJsUrl route configs f = do
202− let ghcjsPreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: allJsUrl) blank
203− ghcjsScript = elAttr "script" ("language" =: "javascript" <> "src" =: allJsUrl <> "defer" =: "defer") blank
237+renderGhcjsFrontend urlEnc ghcjsWidgets route configs f = do
204238 cookies <- askCookies
205− renderFrontendHtml configs cookies urlEnc route f ghcjsPreload ghcjsScript
239+ renderFrontendHtml configs cookies urlEnc route f (_ghcjsWidgets_preload ghcjsWidgets) (_ghcjsWidgets_script ghcjsWidgets)
240+
241+-- | Preload all.js in a link tag.
242+-- This is the default preload method.
243+preloadGhcjs :: Text -> FrontendWidgetT r ()
244+preloadGhcjs allJsUrl = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: allJsUrl) blank
245+
246+-- | Load the script from the given URL in a deferred script tag.
247+-- This is the default method.
248+deferredGhcjsScript :: Text -> FrontendWidgetT r ()
249+deferredGhcjsScript allJsUrl = elAttr "script" ("type" =: "text/javascript" <> "src" =: allJsUrl <> "defer" =: "defer") blank
250+
251+-- | An all.js script which is loaded after waiting for some time to pass. This
252+-- is useful to ensure any CSS animations on the page can play smoothly before
253+-- blocking the UI thread by running all.js.
254+delayedGhcjsScript
255+ :: Int -- ^ The number of milliseconds to delay loading by
256+ -> Text -- ^ URL to GHCJS app JavaScript
257+ -> FrontendWidgetT r ()
258+delayedGhcjsScript n allJsUrl = elAttr "script" ("type" =: "text/javascript") $ text $ T.unlines
259+ [ "setTimeout(function() {"
260+ , " var all_js_script = document.createElement('script');"
261+ , " all_js_script.type = 'text/javascript';"
262+ , " all_js_script.src = '" <> allJsUrl <> "';"
263+ , " document.body.appendChild(all_js_script);"
264+ , "}, " <> T.pack (show n) <> ");"
265+ ]
206266
207267instance HasCookies Snap where
208268 askCookies = map (\c -> (cookieName c, cookieValue c)) <$> getsRequest rqCookies