git.iko.soy/obelisk
on master help sign in
executable-config: Move injectExecutableConfigs; Platform-specific html rendering
commit409d25dbffa6c5011467f94cf65298e2a578ac99 authorAli Abrar <aliabrar@gmail.com> dateTue 7 Aug 2018, 21:23 (8 years ago) parentcc3e53c
7 files changed+64−57
compare with master
unifiedsplit
lib/backend/src/Obelisk/Backend.hs+9−23 lib/executable-config/inject/obelisk-executable-config-inject.cabal+2 lib/executable-config/inject/src/Obelisk/ExecutableConfig/Inject.hs+37−7 lib/frontend/obelisk-frontend.cabal+1 lib/frontend/src/Obelisk/Frontend.hs+7−25 lib/run/obelisk-run.cabal+1 lib/run/src/Obelisk/Run.hs+7−2
lib/backend/src/Obelisk/Backend.hs+9−23
@@ -16,11 +16,11 @@ module Obelisk.Backend
1616 , serveDefaultObeliskApp
1717 , prettifyOutput
1818 , runBackend
19− , configureFrontend
2019 ) where
2120
2221import Control.Monad
2322import Control.Monad.Except
23+import Data.ByteString (ByteString)
2424import qualified Data.ByteString.Char8 as BSC8
2525import Data.Default (Default (..))
2626import Data.Dependent.Sum
@@ -28,17 +28,15 @@ import Data.Functor.Sum
2828import Data.Functor.Identity
2929import Data.Text (Text)
3030import qualified Data.Text as T
31−import qualified Data.Text.IO as T
3231import Data.Text.Encoding
3332import Obelisk.Asset.Serve.Snap (serveAsset)
34−import Obelisk.ExecutableConfig.Inject (injectPure)
33+import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)
3534import Obelisk.Frontend
3635import Obelisk.Route
36+import Reflex.Dom
3737import Snap (MonadSnap, Snap, commandLineConfig, defaultConfig, getsRequest, httpServe, rqPathInfo,
3838 rqQueryString, writeBS, writeText)
3939import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog (ConfigIoLog))
40−import System.Directory
41−import System.FilePath
4240import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
4341
4442data Backend backendRoute frontendRoute = Backend
@@ -155,7 +153,7 @@ data GhcjsAppRoute :: (* -> *) -> * -> * where
155153serveGhcjsApp :: MonadSnap m => GhcjsApp (R appRouteComponent) -> R (GhcjsAppRoute appRouteComponent) -> m ()
156154serveGhcjsApp app = \case
157155 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest ->
158− writeBS <=< liftIO $ renderFrontendHtml (appRouteComponent :/ appRouteRest) <=< configureFrontend $ ghcjsFrontend $ _ghcjsApp_value app
156+ writeBS <=< liftIO $ renderGhcjsFrontend (appRouteComponent :/ appRouteRest) $ _ghcjsApp_value app
159157 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments
160158
161159runBackend :: Backend fullRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
@@ -169,20 +167,8 @@ runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend
169167 InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a
170168 InR obeliskRoute :=> Identity a -> serveDefaultObeliskApp frontend $ obeliskRoute :/ a
171169
172−configureFrontend :: Frontend a -> IO (Frontend a)
173−configureFrontend f = do
174− cfgC <- getConfigs "config/common"
175− cfgF <- getConfigs "config/frontend"
176− return $ f { _frontend_head = _frontend_head f >> mapM_ (uncurry injectPure) (cfgC <> cfgF) }
177− where
178− getConfigs :: FilePath -> IO [(FilePath, Text)]
179− getConfigs fp = do
180− ps <- listDirectory fp
181− fmap concat $ forM ps $ \p -> do
182− let fullpath = fp </> p
183− dir <- doesDirectoryExist p
184− if dir
185− then getConfigs fullpath
186− else do
187− v <- T.readFile fullpath
188− return [(fullpath, v)]
170+renderGhcjsFrontend :: route -> Frontend route -> IO ByteString
171+renderGhcjsFrontend route f = do
172+ let baseTag = elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes
173+ ghcjsScript = elAttr "script" ("language" =: "javascript" <> "src" =: "ghcjs/all.js" <> "defer" =: "defer") blank
174+ renderFrontendHtml route (_frontend_head f >> injectExecutableConfigs >> baseTag) (_frontend_body f >> ghcjsScript)
lib/executable-config/inject/obelisk-executable-config-inject.cabal+2
@@ -9,8 +9,10 @@ library
99 build-depends:
1010 base,
1111 bytestring,
12+ directory,
1213 filepath,
1314 reflex-dom,
1415 text
1516
1617 exposed-modules: Obelisk.ExecutableConfig.Inject
18+ ghc-options: -Wall
lib/executable-config/inject/src/Obelisk/ExecutableConfig/Inject.hs+37−7
@@ -1,18 +1,48 @@
11{-# LANGUAGE OverloadedStrings #-}
22module Obelisk.ExecutableConfig.Inject where
33
4+import Control.Monad (forM, mapM_)
5+import Control.Monad.IO.Class (MonadIO, liftIO)
46import Data.Semigroup ((<>))
57import Data.ByteString (ByteString)
8+import Data.Text (Text)
69import qualified Data.Text as T
710import qualified Data.Text.IO as T
8−import Reflex.Dom
11+import Reflex.Dom hiding (value)
12+import System.Directory
913import System.FilePath ((</>))
1014
15+-- | Produces a @<script>@ tag containing the contents of the config item,
16+-- rendered as a 'ByteString'.
1117inject :: FilePath -> IO ByteString
12−inject item = do
13− f <- T.readFile item
14− fmap snd $ renderStatic $ injectPure item f
18+inject key = do
19+ value <- T.readFile key
20+ fmap snd $ renderStatic $ injectPure (T.pack key) value
1521
16−injectPure :: DomBuilder t m => FilePath -> T.Text -> m ()
17−injectPure item content = elAttr "script" ("type" =: "text/plain" <> "id" =: ("config-" <> T.pack item)) $
18− text content
22+-- | Produces a @<script>@ tag with an @id@ attribute containing the key and
23+-- whose value is the provided configuration
24+injectPure :: DomBuilder t m => Text -> Text -> m ()
25+injectPure key value =
26+ let attrs = ("type" =: "text/plain" <> "id" =: ("config-" <> key))
27+ in elAttr "script" attrs $ text value
28+
29+-- | Scans the "common" and "frontend" configuration folders and produces
30+-- injectable @<script>@ tags containing the configuration keys (filepaths) and
31+-- values.
32+injectExecutableConfigs :: (MonadIO m, DomBuilder t m) => m ()
33+injectExecutableConfigs = do
34+ cfgC <- getConfigs "config/common"
35+ cfgF <- getConfigs "config/frontend"
36+ mapM_ (uncurry injectPure) (cfgC <> cfgF)
37+ where
38+ getConfigs :: MonadIO m => FilePath -> m [(Text, Text)]
39+ getConfigs fp = liftIO $ do
40+ ps <- listDirectory fp
41+ fmap concat $ forM ps $ \p -> do
42+ let fullpath = fp </> p
43+ dir <- doesDirectoryExist p
44+ if dir
45+ then getConfigs fullpath
46+ else do
47+ v <- T.readFile fullpath
48+ return [(T.pack fullpath, v)]
lib/frontend/obelisk-frontend.cabal+1
@@ -19,3 +19,4 @@ library
1919 text,
2020 transformers
2121 exposed-modules: Obelisk.Frontend
22+ ghc-options: -Wall
lib/frontend/src/Obelisk/Frontend.hs+7−25
@@ -14,8 +14,6 @@ module Obelisk.Frontend
1414 , Frontend (..)
1515 , runFrontend
1616 , renderFrontendHtml
17− , ghcjsFrontend
18− , jsaddleFrontend
1917 ) where
2018
2119import Prelude hiding ((.))
@@ -158,31 +156,15 @@ instance PrimMonad m => PrimMonad (EventWriterT t w m) where
158156 primitive = lift . primitive
159157
160158renderFrontendHtml
161− :: forall route a.
162− R route
163− -> Frontend (R route)
159+ :: (Semigroup w, t ~ SpiderTimeline Global)
160+ => r
161+ -> RoutedT t r (EventWriterT t w (PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global))))) ()
162+ -> RoutedT t r (EventWriterT t w (PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global))))) ()
164163 -> IO ByteString
165−renderFrontendHtml route f = do
164+renderFrontendHtml route headWidget bodyWidget = do
166165 --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline
167166 html <- fmap snd $ renderStatic $ fmap fst $ runEventWriterT $ flip runRoutedT (pure route) $
168167 el "html" $ do
169− el "head" $ _frontend_head f
170− el "body" $ _frontend_body f
168+ el "head" headWidget
169+ el "body" bodyWidget
171170 return $ "<!DOCTYPE html>" <> html
172−
173−ghcjsScript :: DomBuilder t m => m ()
174−ghcjsScript = elAttr "script" ("language" =: "javascript" <> "src" =: "ghcjs/all.js" <> "defer" =: "defer") blank
175−
176−ghcjsFrontend :: Frontend a -> Frontend a
177−ghcjsFrontend f = f
178− { _frontend_head = _frontend_head f >> elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes
179− , _frontend_body = _frontend_body f >> ghcjsScript
180− }
181−
182−jsaddleScript :: DomBuilder t m => m ()
183−jsaddleScript = elAttr "script" ("src" =: "/jsaddle/jsaddle.js") blank
184−
185−jsaddleFrontend :: Frontend a -> Frontend a
186−jsaddleFrontend f = f
187− { _frontend_body = _frontend_body f >> jsaddleScript
188− }
lib/run/obelisk-run.cabal+1
@@ -24,6 +24,7 @@ library
2424 , network
2525 , obelisk-backend
2626 , obelisk-executable-config
27+ , obelisk-executable-config-inject
2728 , obelisk-frontend
2829 , obelisk-route
2930 , process
lib/run/src/Obelisk/Run.hs+7−2
@@ -23,7 +23,6 @@ import Control.Category
2323import Control.Concurrent
2424import Control.Exception
2525import Control.Lens ((%~), (^?), _Just, _Right)
26−import Control.Monad
2726import qualified Data.Attoparsec.ByteString.Char8 as A
2827import Data.ByteString (ByteString)
2928import qualified Data.ByteString.Char8 as BSC
@@ -52,6 +51,7 @@ import Network.Wai.Handler.Warp.Internal (settingsHost, settingsPort)
5251import Network.WebSockets (ConnectionOptions)
5352import Network.WebSockets.Connection (defaultConnectionOptions)
5453import Obelisk.ExecutableConfig (get)
54+import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)
5555import Obelisk.Frontend
5656import Obelisk.Route.Frontend
5757import Reflex.Dom.Core
@@ -140,10 +140,15 @@ obeliskApp opts frontend validFullEncoder uri backend = do
140140 { W.pathInfo = fst $ _validEncoder_encode jsaddleWarpRouteValidEncoder jsaddleRoute
141141 }
142142 InR (ObeliskRoute_App appRouteComponent) :=> Identity appRouteRest -> do
143− html <- renderFrontendHtml (appRouteComponent :/ appRouteRest) <=< configureFrontend $ jsaddleFrontend frontend
143+ html <- renderJsaddleFrontend (appRouteComponent :/ appRouteRest) frontend
144144 sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] $ BSLC.fromStrict html
145145 _ -> backend req sendResponse
146146
147+renderJsaddleFrontend :: route -> Frontend route -> IO ByteString
148+renderJsaddleFrontend r f =
149+ let jsaddleScript = elAttr "script" ("src" =: "/jsaddle/jsaddle.js") blank
150+ in renderFrontendHtml r (_frontend_head f >> injectExecutableConfigs) (_frontend_body f >> jsaddleScript)
151+
147152-- | like 'bindPortTCP' but reconnects on exception
148153bindPortTCPRetry :: Settings
149154 -> (IOError -> IO ()) -- ^ Action to run the first time an exception is caught