@@ -20,6 +20,7 @@ module Obelisk.Backend
2020 , runBackendWith
2121 -- * Configuration of backend
2222 , GhcjsWidgets(..)
23+ , GhcjsWasmAssets(..)
2324 , defaultGhcjsWidgets
2425 -- * all.js script loading functions
2526 , deferredGhcjsScript
@@ -39,13 +40,16 @@ module Obelisk.Backend
3940 , getPublicConfigs
4041 ) where
4142
43+import Control.Exception (try)
4244import Control.Monad
4345import Control.Monad.Except
4446import Control.Monad.Fail (MonadFail)
47+import Control.Lens (view, _1, _2, _3)
4548import Data.ByteString (ByteString)
4649import qualified Data.ByteString.Char8 as BSC8
4750import Data.Default (Default (..))
4851import Data.Dependent.Sum
52+import Data.Either (isRight)
4953import Data.Functor.Identity
5054import Data.Map (Map)
5155import qualified Data.Map as Map
@@ -63,6 +67,7 @@ import Snap (MonadSnap, Snap, commandLineConfig, defaultConfig, getsRequest, htt
6367 , rqPathInfo, rqQueryString, setContentType, writeBS, writeText
6468 , rqCookies, Cookie(..) , setHeader)
6569import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog (ConfigIoLog))
70+import System.FilePath ((</>))
6671import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
6772
6873data Backend backendRoute frontendRoute = Backend
@@ -73,8 +78,9 @@ data Backend backendRoute frontendRoute = Backend
7378data BackendConfig frontendRoute = BackendConfig
7479 { _backendConfig_runSnap :: !(Snap () -> IO ()) -- ^ Function to run the snap server
7580 , _backendConfig_staticAssets :: !StaticAssets -- ^ Static assets
76− , _backendConfig_ghcjsWidgets :: !(GhcjsWidgets (Text -> FrontendWidgetT (R frontendRoute) ()))
77− -- ^ Given the URL of all.js, return the widgets which are responsible for
81+ , _backendConfig_ghcjsAssets :: !StaticAssets -- ^ Frontend ghcjs (and wasm) assets
82+ , _backendConfig_ghcjsWidgets :: !(GhcjsWidgets (GhcjsWasmAssets -> FrontendWidgetT (R frontendRoute) ()))
83+ -- ^ Given the URL of all.js and wasm files, return the widgets which are responsible for
7884 -- loading the script.
7985 } deriving (Generic)
8086
@@ -92,10 +98,14 @@ data GhcjsWidgets a = GhcjsWidgets
9298 -- ^ A script widget, placed in the document body
9399 } deriving (Functor, Generic)
94100
101+data GhcjsWasmAssets = GhcjsWasmAssets
102+ { _ghcjsWasmAssets_allJs :: Text
103+ , _ghcjsWasmAssets_wasmPathRoot :: Maybe Text
104+ }
95105
96106-- | Given the URL of all.js, return the widgets which are responsible for
97107-- loading the script. Defaults to 'preloadGhcjs' and 'deferredGhcjsScript'.
98−defaultGhcjsWidgets :: GhcjsWidgets (Text -> FrontendWidgetT r ())
108+defaultGhcjsWidgets :: GhcjsWidgets (GhcjsWasmAssets -> FrontendWidgetT r ())
99109defaultGhcjsWidgets = GhcjsWidgets
100110 { _ghcjsWidgets_preload = preloadGhcjs
101111 , _ghcjsWidgets_script = deferredGhcjsScript
@@ -132,6 +142,9 @@ defaultStaticAssets = StaticAssets
132142 , _staticAssets_unprocessed = "static"
133143 }
134144
145+-- This has both ghcjs and wasm assets.
146+-- The 'unprocessed' is a fallback path, and in case of wasm is invalid (does not contain wasm files)
147+-- For the standard obelisk deployment the unprocessed path would not be used.
135148defaultFrontendGhcjsAssets :: StaticAssets
136149defaultFrontendGhcjsAssets = StaticAssets
137150 { _staticAssets_processed = "frontend.jsexe.assets"
@@ -167,6 +180,10 @@ renderAllJsPath :: Encoder Identity Identity (R (FullRoute a b)) PageName -> Tex
167180renderAllJsPath validFullEncoder =
168181 renderObeliskRoute validFullEncoder $ FullRoute_Frontend (ObeliskRoute_Resource ResourceRoute_Ghcjs) :/ ["all.js"]
169182
183+renderWasmPathRoot :: Encoder Identity Identity (R (FullRoute a b)) PageName -> Text
184+renderWasmPathRoot validFullEncoder =
185+ renderObeliskRoute validFullEncoder $ FullRoute_Frontend (ObeliskRoute_Resource ResourceRoute_Ghcjs) :/ []
186+
170187serveObeliskApp
171188 :: (MonadSnap m, HasCookies m, MonadFail m)
172189 => (R appRoute -> Text)
@@ -221,7 +238,7 @@ serveGhcjsApp urlEnc ghcjsWidgets app config = \case
221238
222239-- | Default obelisk backend configuration.
223240defaultBackendConfig :: BackendConfig frontendRoute
224−defaultBackendConfig = BackendConfig runSnapWithCommandLineArgs defaultStaticAssets defaultGhcjsWidgets
241+defaultBackendConfig = BackendConfig runSnapWithCommandLineArgs defaultStaticAssets defaultFrontendGhcjsAssets defaultGhcjsWidgets
225242
226243-- | Run an obelisk backend with the default configuration.
227244runBackend :: Backend backendRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
@@ -233,21 +250,34 @@ runBackendWith
233250 -> Backend backendRoute frontendRoute
234251 -> Frontend (R frontendRoute)
235252 -> IO ()
236−runBackendWith (BackendConfig runSnap staticAssets ghcjsWidgets) backend frontend = case checkEncoder $ _backend_routeEncoder backend of
253+runBackendWith (BackendConfig runSnap staticAssets ghcjsAssets ghcjsWidgets) backend frontend = case checkEncoder $ _backend_routeEncoder backend of
237254 Left e -> fail $ "backend error:\n" <> T.unpack e
238255 Right validFullEncoder -> do
239256 publicConfigs <- getPublicConfigs
257+ enableWasm <- checkWasmFile
240258 _backend_run backend $ \serveRoute ->
241259 runSnap $
242260 getRouteWith validFullEncoder >>= \case
243261 Identity r -> case r of
244262 FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a
245263 FullRoute_Frontend obeliskRoute :/ a ->
246− serveDefaultObeliskApp routeToUrl (($ allJsUrl) <$> ghcjsWidgets) (serveStaticAssets staticAssets) frontend publicConfigs $
264+ serveObeliskApp routeToUrl widgets (serveStaticAssets staticAssets) frontendApp publicConfigs $
247265 obeliskRoute :/ a
248266 where
249267 routeToUrl (k :/ v) = renderObeliskRoute validFullEncoder $ FullRoute_Frontend (ObeliskRoute_App k) :/ v
250268 allJsUrl = renderAllJsPath validFullEncoder
269+ mWasmUrls = if enableWasm then Just (renderWasmPathRoot validFullEncoder) else Nothing
270+ widgets = ($ GhcjsWasmAssets allJsUrl mWasmUrls) <$> ghcjsWidgets
271+ frontendApp = GhcjsApp
272+ { _ghcjsApp_compiled = ghcjsAssets
273+ , _ghcjsApp_value = frontend
274+ }
275+ where
276+ checkWasmFile = do
277+ let base = _staticAssets_processed ghcjsAssets
278+ p = "frontend.wasm"
279+ assetType :: (Either IOError ByteString) <- liftIO $ try $ BSC8.readFile $ base </> p </> "type"
280+ pure $ isRight assetType
251281
252282renderGhcjsFrontend
253283 :: (MonadSnap m, HasCookies m)
@@ -263,29 +293,100 @@ renderGhcjsFrontend urlEnc ghcjsWidgets route configs f = do
263293
264294-- | Preload all.js in a link tag.
265295-- This is the default preload method.
266−preloadGhcjs :: Text -> FrontendWidgetT r ()
267−preloadGhcjs allJsUrl = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: allJsUrl) blank
296+preloadGhcjs :: GhcjsWasmAssets -> FrontendWidgetT r ()
297+preloadGhcjs (GhcjsWasmAssets allJsUrl mWasm) = case mWasm of
298+ Nothing -> elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: allJsUrl) blank
299+ Just wasmAssets -> scriptTag $ view _1 (wasmScripts allJsUrl wasmAssets)
268300
269301-- | Load the script from the given URL in a deferred script tag.
270302-- This is the default method.
271−deferredGhcjsScript :: Text -> FrontendWidgetT r ()
272−deferredGhcjsScript allJsUrl = elAttr "script" ("type" =: "text/javascript" <> "src" =: allJsUrl <> "defer" =: "defer") blank
303+deferredGhcjsScript :: GhcjsWasmAssets -> FrontendWidgetT r ()
304+deferredGhcjsScript (GhcjsWasmAssets allJsUrl mWasm) = case mWasm of
305+ Nothing -> elAttr "script" ("type" =: "text/javascript" <> "src" =: allJsUrl <> "defer" =: "defer") blank
306+ Just wasmAssets -> scriptTag $ view _2 (wasmScripts allJsUrl wasmAssets)
307+
308+scriptTag :: DomBuilder t m => Text -> m ()
309+scriptTag t = elAttr "script" ("type" =: "text/javascript") $ text t
310+
311+wasmScripts :: Text -> Text -> (Text, Text, (Int -> Text))
312+wasmScripts allJsUrl wasmRoot = (preloadScript, runJsScript, delayedJsScript)
313+ where
314+ jsaddleJs = wasmRoot <> "/jsaddle_core.js"
315+ interfaceJs = wasmRoot <> "/jsaddle_mainthread_interface.js"
316+ runnerJs = wasmRoot <> "/mainthread_runner.js"
317+ wasmUrl = wasmRoot <> "/frontend.wasm"
318+
319+ preloadScript =
320+ "add_preload_tag = function (docSrc, docType) { \
321+ \ var link_tag = document.createElement('link'); \
322+ \ link_tag.rel = 'preload'; \
323+ \ link_tag.as = docType; \
324+ \ link_tag.href = docSrc; \
325+ \ document.head.appendChild(link_tag); \
326+ \}; \
327+ \if (typeof(WebAssembly) === 'undefined') { \
328+ \ add_preload_tag('" <> allJsUrl <> "', 'script'); \
329+ \} else { \
330+ \ add_preload_tag('" <> wasmUrl <> "', 'script'); \
331+ \ add_preload_tag('" <> jsaddleJs <> "', 'script'); \
332+ \ add_preload_tag('" <> interfaceJs <> "', 'script'); \
333+ \ add_preload_tag('" <> runnerJs <> "', 'script'); \
334+ \}"
335+
336+ runJsScript =
337+ "add_deferload_tag = function (docSrc) { \
338+ \ var tag = document.createElement('script'); \
339+ \ tag.type = 'text/javascript'; \
340+ \ tag.src = docSrc; \
341+ \ tag.setAttribute = ('defer', 'defer'); \
342+ \ document.body.appendChild(tag); \
343+ \}; \
344+ \if (typeof(WebAssembly) === 'undefined') { \
345+ \ add_deferload_tag('" <> allJsUrl <> "'); \
346+ \} else { \
347+ \ var wasmFile = '" <> wasmUrl <> "'; \
348+ \ add_deferload_tag('" <> jsaddleJs <> "'); \
349+ \ add_deferload_tag('" <> interfaceJs <> "'); \
350+ \ add_deferload_tag('" <> runnerJs <> "'); \
351+ \}"
352+
353+ delayedJsScript n =
354+ "var wasmFile = '" <> wasmUrl <> "'; \
355+ \setTimeout(function() { \
356+ \ add_load_tag = function (docSrc) { \
357+ \ var tag = document.createElement('script');\
358+ \ tag.type = 'text/javascript'; \
359+ \ tag.src = docSrc; \
360+ \ document.body.appendChild(tag); \
361+ \ }; \
362+ \ if (typeof(WebAssembly) === 'undefined') { \
363+ \ add_load_tag('" <> allJsUrl <> "'); \
364+ \ } else { \
365+ \ add_load_tag('" <> jsaddleJs <> "'); \
366+ \ add_load_tag('" <> interfaceJs <> "'); \
367+ \ add_load_tag('" <> runnerJs <> "'); \
368+ \ } \
369+ \}, " <> T.pack (show n) <> ");"
273370
274371-- | An all.js script which is loaded after waiting for some time to pass. This
275372-- is useful to ensure any CSS animations on the page can play smoothly before
276373-- blocking the UI thread by running all.js.
277374delayedGhcjsScript
278375 :: Int -- ^ The number of milliseconds to delay loading by
279− -> Text -- ^ URL to GHCJS app JavaScript
376+ -> GhcjsWasmAssets
280377 -> FrontendWidgetT r ()
281−delayedGhcjsScript n allJsUrl = elAttr "script" ("type" =: "text/javascript") $ text $ T.unlines
282− [ "setTimeout(function() {"
283− , " var all_js_script = document.createElement('script');"
284− , " all_js_script.type = 'text/javascript';"
285− , " all_js_script.src = '" <> allJsUrl <> "';"
286− , " document.body.appendChild(all_js_script);"
287− , "}, " <> T.pack (show n) <> ");"
288− ]
378+delayedGhcjsScript n (GhcjsWasmAssets allJsUrl mWasm) = scriptTag scriptToRun
379+ where
380+ scriptToRun = case mWasm of
381+ Nothing -> T.unlines
382+ [ "setTimeout(function() {"
383+ , " var all_js_script = document.createElement('script');"
384+ , " all_js_script.type = 'text/javascript';"
385+ , " all_js_script.src = '" <> allJsUrl <> "';"
386+ , " document.body.appendChild(all_js_script);"
387+ , "}, " <> T.pack (show n) <> ");"
388+ ]
389+ Just wasmAssets -> (view _3 (wasmScripts allJsUrl wasmAssets)) n
289390
290391instance HasCookies Snap where
291392 askCookies = map (\c -> (cookieName c, cookieValue c)) <$> getsRequest rqCookies