git.iko.soy/obelisk
on master help sign in
run: Use config/common/route to specify jsaddle uri; de-dupe html rendering
commit6cf35d700252406c22ff156107d0208b807e8f98 authorAli Abrar <aliabrar@gmail.com> dateTue 7 Aug 2018, 14:42 (8 years ago) parentf045057
4 files changed+52−33
compare with master
unifiedsplit
lib/backend/src/Obelisk/Backend.hs+2−16 lib/frontend/obelisk-frontend.cabal+1 lib/frontend/src/Obelisk/Frontend.hs+35 lib/run/src/Obelisk/Run.hs+14−17
lib/backend/src/Obelisk/Backend.hs+2−16
@@ -30,8 +30,6 @@ import Data.Text.Encoding
3030import Obelisk.Asset.Serve.Snap (serveAsset)
3131import Obelisk.Frontend
3232import Obelisk.Route
33−import Obelisk.Route.Frontend
34−import Reflex.Dom
3533import Snap (MonadSnap, Snap, commandLineConfig, defaultConfig, getsRequest, httpServe, rqPathInfo,
3634 rqQueryString, writeBS, writeText)
3735import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog (ConfigIoLog))
@@ -150,22 +148,10 @@ data GhcjsAppRoute :: (* -> *) -> * -> * where
150148--TODO: Don't assume we're being served at "/"
151149serveGhcjsApp :: MonadSnap m => GhcjsApp (R appRouteComponent) -> R (GhcjsAppRoute appRouteComponent) -> m ()
152150serveGhcjsApp app = \case
153− GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do
154− indexHtml <- liftIO $ fmap snd $ renderStatic $ fmap fst $ runEventWriterT $ flip runRoutedT (pure $ appRouteComponent :/ appRouteRest) $ blankLoader (_frontend_head $ _ghcjsApp_value app) (_frontend_body $ _ghcjsApp_value app)
155− --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline
156− writeBS $ "<!DOCTYPE html>\n" <> indexHtml
151+ GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest ->
152+ writeBS <=< liftIO $ renderFrontendHtml (appRouteComponent :/ appRouteRest) $ ghcjsFrontend $ _ghcjsApp_value app
157153 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments
158154
159−blankLoader :: DomBuilder t m => m () -> m () -> m ()
160−blankLoader headHtml bodyHtml = el "html" $ do
161− el "head" $ do
162− elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes
163− headHtml
164− el "body" $ do
165− bodyHtml
166− --TODO: Hash the all.js path
167− elAttr "script" ("language" =: "javascript" <> "src" =: "ghcjs/all.js" <> "defer" =: "defer") blank
168−
169155runBackend :: Backend fullRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
170156runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of
171157 Left e -> fail $ "backend error:\n" <> T.unpack e
lib/frontend/obelisk-frontend.cabal+1
@@ -6,6 +6,7 @@ build-type: Simple
66library
77 hs-source-dirs: src
88 build-depends: base,
9+ bytestring,
910 dependent-sum,
1011 ghcjs-dom,
1112 jsaddle,
lib/frontend/src/Obelisk/Frontend.hs+35
@@ -3,6 +3,7 @@
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE LambdaCase #-}
55{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE OverloadedStrings #-}
67{-# LANGUAGE RankNTypes #-}
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TemplateHaskell #-}
@@ -12,6 +13,9 @@ module Obelisk.Frontend
1213 ( ObeliskWidget
1314 , Frontend (..)
1415 , runFrontend
16+ , renderFrontendHtml
17+ , ghcjsFrontend
18+ , jsaddleFrontend
1519 ) where
1620
1721import Prelude hiding ((.))
@@ -25,6 +29,7 @@ import Control.Monad.IO.Class
2529import Control.Monad.Primitive
2630import Control.Monad.Ref
2731import Control.Monad.Trans.Class
32+import Data.ByteString (ByteString)
2833import Data.Dependent.Sum (DSum (..))
2934import Data.Functor.Sum
3035import Data.IORef
@@ -151,3 +156,33 @@ runFrontend validFullEncoder frontend = do
151156instance PrimMonad m => PrimMonad (EventWriterT t w m) where
152157 type PrimState (EventWriterT t w m) = PrimState m
153158 primitive = lift . primitive
159+
160+renderFrontendHtml
161+ :: forall route a.
162+ R route
163+ -> Frontend (R route)
164+ -> IO ByteString
165+renderFrontendHtml route f = do
166+ --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline
167+ html <- fmap snd $ renderStatic $ fmap fst $ runEventWriterT $ flip runRoutedT (pure route) $
168+ el "html" $ do
169+ el "head" $ _frontend_head f
170+ el "body" $ _frontend_body f
171+ 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/src/Obelisk/Run.hs+14−17
@@ -22,7 +22,7 @@ import Prelude hiding ((.), id)
2222import Control.Category
2323import Control.Concurrent
2424import Control.Exception
25−import Control.Lens ((^?), _Just, _Right)
25+import Control.Lens ((%~), (^?), _Just, _Right)
2626import qualified Data.Attoparsec.ByteString.Char8 as A
2727import Data.ByteString (ByteString)
2828import qualified Data.ByteString.Char8 as BSC
@@ -112,40 +112,37 @@ runWidget conf frontend validFullEncoder = do
112112 close
113113 (\skt -> do
114114 man <- newManager defaultManagerSettings
115− app <- obeliskApp defaultConnectionOptions frontend validFullEncoder $ fallbackProxy redirectHost redirectPort man
115+ app <- obeliskApp defaultConnectionOptions frontend validFullEncoder uri $ fallbackProxy redirectHost redirectPort man
116116 runSettingsSocket settings skt app)
117117
118−obeliskApp :: forall route backendRoute. ConnectionOptions -> Frontend (R route) -> ValidEncoder (Either Text) (R (Sum backendRoute (ObeliskRoute route))) PageName -> Application -> IO Application
119−obeliskApp opts frontend validFullEncoder backend = do
118+obeliskApp
119+ :: forall route backendRoute. ConnectionOptions
120+ -> Frontend (R route)
121+ -> ValidEncoder (Either Text) (R (Sum backendRoute (ObeliskRoute route))) PageName
122+ -> URI
123+ -> Application
124+ -> IO Application
125+obeliskApp opts frontend validFullEncoder uri backend = do
120126 let entryPoint = do
121127 runFrontend validFullEncoder frontend
122128 syncPoint
129+ jsaddlePath <- URI.mkPathPiece "jsaddle"
130+ let jsaddleUri = BSLC.fromStrict $ URI.renderBs $ uri & uriPath %~ (<>[jsaddlePath])
123131 Right (jsaddleWarpRouteValidEncoder :: ValidEncoder (Either Text) (R JSaddleWarpRoute) PageName) <- return $ checkEncoder jsaddleWarpRouteEncoder
124132 jsaddle <- jsaddleWithAppOr opts entryPoint $ \_ sendResponse -> sendResponse $ W.responseLBS H.status500 [("Content-Type", "text/plain")] "obeliskApp: jsaddle got a bad URL"
125133 return $ \req sendResponse -> case _validEncoder_decode validFullEncoder (W.pathInfo req, mempty) of --TODO: Query strings
126134 Left e -> sendResponse $ W.responseLBS H.status404 [("Content-Type", "text/plain")] $ LBS.fromStrict $ encodeUtf8 e
127135 Right r -> case r of
128136 InR (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :=> Identity jsaddleRoute -> case jsaddleRoute of
129− JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just "http://localhost:8000/jsaddle") False
137+ JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False
130138 _ -> flip jsaddle sendResponse $ req
131139 { W.pathInfo = fst $ _validEncoder_encode jsaddleWarpRouteValidEncoder jsaddleRoute
132140 }
133141 InR (ObeliskRoute_App appRouteComponent) :=> Identity appRouteRest -> do
134− html <- renderStaticHtml $ fmap fst $ runEventWriterT $ flip runRoutedT (pure $ appRouteComponent :/ appRouteRest) $ indexHtml (_frontend_head frontend) (_frontend_body frontend)
142+ html <- renderFrontendHtml (appRouteComponent :/ appRouteRest) $ jsaddleFrontend frontend
135143 sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] $ BSLC.fromStrict html
136144 _ -> backend req sendResponse
137145
138−renderStaticHtml :: StaticWidget () () -> IO ByteString
139−renderStaticHtml w = do
140− (_, bs) <- renderStatic w
141− return $ "<!DOCTYPE html>" <> bs
142−
143−indexHtml :: DomBuilder t m => m () -> m () -> m ()
144−indexHtml h b = el "html" $ do
145− el "head" $ h
146− el "body" $ b
147− elAttr "script" ("src" =: "/jsaddle/jsaddle.js") $ return ()
148−
149146-- | like 'bindPortTCP' but reconnects on exception
150147bindPortTCPRetry :: Settings
151148 -> (IOError -> IO ()) -- ^ Action to run the first time an exception is caught