@@ -6,11 +6,12 @@
66{-# LANGUAGE MultiParamTypeClasses #-}
77{-# LANGUAGE OverloadedStrings #-}
88{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TemplateHaskell #-}
9+{-# OPTIONS_GHC -fno-warn-orphans #-}
1010module Obelisk.Backend
1111 ( Backend (..)
1212 -- * Re-exports
1313 , Default (def)
14+ , ComponentConfigs(..)
1415 , getPageName
1516 , getRouteWith
1617 , runSnapWithCommandLineArgs
@@ -19,6 +20,7 @@ module Obelisk.Backend
1920 , runBackend
2021 , staticRenderContentType
2122 , mkRouteToUrl
23+ , getComponentConfigs
2224 ) where
2325
2426import Prelude hiding (id, (.))
@@ -32,23 +34,35 @@ import Data.Default (Default (..))
3234import Data.Dependent.Sum
3335import Data.Functor.Sum
3436import Data.Functor.Identity
37+import Data.Map (Map)
38+import qualified Data.Map as Map
3539import Data.Monoid ((<>))
3640import Data.Text (Text)
3741import qualified Data.Text as T
3842import Data.Text.Encoding
3943import Obelisk.Asset.Serve.Snap (serveAsset)
44+import Obelisk.ExecutableConfig.Backend
45+import Obelisk.ExecutableConfig.Lookup
4046import Obelisk.Frontend
4147import Obelisk.Route
4248import Obelisk.Snap.Extras (doNotCache, serveFileIfExistsAs)
4349import Reflex.Dom
4450import Snap (MonadSnap, Snap, commandLineConfig, defaultConfig, getsRequest, httpServe, modifyResponse
45− , rqPathInfo, rqQueryString, setContentType, writeBS, writeText)
51+ , rqPathInfo, rqQueryString, setContentType, writeBS, writeText
52+ , rqCookies, Cookie(..))
4653import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog (ConfigIoLog))
4754import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
4855
4956data Backend backendRoute frontendRoute = Backend
5057 { _backend_routeEncoder :: Encoder (Either Text) Identity (R (Sum backendRoute (ObeliskRoute frontendRoute))) PageName
51− , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()
58+ , _backend_run :: ((R backendRoute -> BackendConfigsT Snap ()) -> BackendConfigsT IO ()) -> BackendConfigsT IO ()
59+ }
60+
61+-- | All the configs separated by which context they are accessible in. (Common
62+-- configs are present in both.)
63+data ComponentConfigs = ComponentConfigs
64+ { _componentConfigs_backend :: Map Text Text
65+ , _componentConfigs_frontend :: Map Text Text
5266 }
5367
5468-- | The static assets provided must contain a compiled GHCJS app that corresponds exactly to the Frontend provided
@@ -59,8 +73,17 @@ data GhcjsApp route = GhcjsApp
5973
6074-- | Serve a frontend, which must be the same frontend that Obelisk has built and placed in the default location
6175--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
62−serveDefaultObeliskApp :: MonadSnap m => (R appRoute -> Text) -> ([Text] -> m ()) -> Frontend (R appRoute) -> R (ObeliskRoute appRoute) -> m ()
63−serveDefaultObeliskApp urlEnc serveStaticAsset frontend = serveObeliskApp urlEnc serveStaticAsset frontendApp
76+serveDefaultObeliskApp
77+ :: (MonadSnap m, HasCookies m)
78+ => (R appRoute
79+ -> Text)
80+ -> ([Text]
81+ -> m ())
82+ -> Frontend (R appRoute)
83+ -> Map Text Text
84+ -> R (ObeliskRoute appRoute)
85+ -> m ()
86+serveDefaultObeliskApp urlEnc serveStaticAsset frontend configs = serveObeliskApp urlEnc serveStaticAsset frontendApp configs
6487 where frontendApp = GhcjsApp
6588 { _ghcjsApp_compiled = defaultFrontendGhcjsAssets
6689 , _ghcjsApp_value = frontend
@@ -85,16 +108,16 @@ defaultFrontendGhcjsAssets = StaticAssets
85108 , _staticAssets_unprocessed = "frontend.jsexe"
86109 }
87110
88−runSnapWithCommandLineArgs :: Snap () -> IO ()
111+runSnapWithCommandLineArgs :: MonadIO m => Snap () -> m ()
89112runSnapWithCommandLineArgs a = do
90113 -- Get the web server configuration from the command line
91− cmdLineConf <- commandLineConfig defaultConfig
114+ cmdLineConf <- liftIO $ commandLineConfig defaultConfig
92115 let httpConf = cmdLineConf
93116 { accessLog = Just $ ConfigIoLog BSC8.putStrLn
94117 , errorLog = Just $ ConfigIoLog BSC8.putStrLn
95118 }
96119 -- Start the web server
97− httpServe httpConf a
120+ liftIO $ httpServe httpConf a
98121
99122getPageName :: (MonadSnap m) => m PageName
100123getPageName = do
@@ -111,12 +134,19 @@ getRouteWith e = do
111134 pageName <- getPageName
112135 return $ tryDecode e pageName
113136
114−serveObeliskApp :: MonadSnap m => (R appRoute -> Text) -> ([Text] -> m ()) -> GhcjsApp (R appRoute) -> R (ObeliskRoute appRoute) -> m ()
115−serveObeliskApp urlEnc serveStaticAsset frontendApp = \case
116− ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc frontendApp $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest
137+serveObeliskApp
138+ :: (MonadSnap m, HasCookies m)
139+ => (R appRoute -> Text)
140+ -> ([Text] -> m ())
141+ -> GhcjsApp (R appRoute)
142+ -> Map Text Text
143+ -> R (ObeliskRoute appRoute)
144+ -> m ()
145+serveObeliskApp urlEnc serveStaticAsset frontendApp config = \case
146+ ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc frontendApp config $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest
117147 ObeliskRoute_Resource resComponent :=> Identity resRest -> case resComponent :=> Identity resRest of
118148 ResourceRoute_Static :=> Identity pathSegments -> serveStaticAsset pathSegments
119− ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc frontendApp $ GhcjsAppRoute_Resource :/ pathSegments
149+ ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc frontendApp config $ GhcjsAppRoute_Resource :/ pathSegments
120150 ResourceRoute_JSaddleWarp :=> Identity _ -> do
121151 let msg = "Error: Obelisk.Backend received jsaddle request"
122152 liftIO $ putStrLn $ T.unpack msg
@@ -140,34 +170,63 @@ staticRenderContentType :: ByteString
140170staticRenderContentType = "text/html; charset=utf-8"
141171
142172--TODO: Don't assume we're being served at "/"
143−serveGhcjsApp :: MonadSnap m => (R appRouteComponent -> Text) -> GhcjsApp (R appRouteComponent) -> R (GhcjsAppRoute appRouteComponent) -> m ()
144−serveGhcjsApp urlEnc app = \case
173+serveGhcjsApp
174+ :: (MonadSnap m, HasCookies m)
175+ => (R appRouteComponent -> Text)
176+ -> GhcjsApp (R appRouteComponent)
177+ -> Map Text Text
178+ -> R (GhcjsAppRoute appRouteComponent)
179+ -> m ()
180+serveGhcjsApp urlEnc app config = \case
145181 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do
146182 modifyResponse $ setContentType staticRenderContentType
147− writeBS <=< liftIO $ renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) $ _ghcjsApp_value app
183+ writeBS <=< renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app
148184 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments
149185
150186runBackend :: Backend fullRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
151187runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of
152188 Left e -> fail $ "backend error:\n" <> T.unpack e
153− Right validFullEncoder -> _backend_run backend $ \serveRoute -> do
154− runSnapWithCommandLineArgs $ do
155− getRouteWith validFullEncoder >>= \case
156− Identity r -> case r of
157− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a
158− InR obeliskRoute :=> Identity a ->
159− serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend $ obeliskRoute :/ a
189+ Right validFullEncoder -> do
190+ configs <- getComponentConfigs
191+ runBackendConfigsT (_componentConfigs_backend configs) $
192+ _backend_run backend $ \serveRoute -> do
193+ runSnapWithCommandLineArgs $ do
194+ getRouteWith validFullEncoder >>= \case
195+ Identity r -> case r of
196+ InL backendRoute :=> Identity a ->
197+ runBackendConfigsT (_componentConfigs_backend configs) $
198+ serveRoute $ backendRoute :/ a
199+ InR obeliskRoute :=> Identity a ->
200+ serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend (_componentConfigs_frontend configs) $ obeliskRoute :/ a
160201
161202mkRouteToUrl :: Encoder Identity parse (R (Sum f (ObeliskRoute r))) PageName -> R r -> Text
162203mkRouteToUrl validFullEncoder =
163204 let pageNameEncoder' :: Encoder Identity (Either Text) PageName PathQuery = pageNameEncoder
164205 in \(k :/ v) -> T.pack . uncurry (<>) . encode pageNameEncoder' . encode validFullEncoder $ (InR $ ObeliskRoute_App k) :/ v
165206
166−
167−renderGhcjsFrontend :: MonadIO m => (route -> Text) -> route -> Frontend route -> m ByteString
168−renderGhcjsFrontend urlEnc route f = do
207+renderGhcjsFrontend
208+ :: (MonadSnap m, HasCookies m)
209+ => (route -> Text)
210+ -> route
211+ -> Map Text Text
212+ -> Frontend route
213+ -> m ByteString
214+renderGhcjsFrontend urlEnc route configs f = do
169215 let ghcjsPreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: "ghcjs/all.js") blank
170216 ghcjsScript = elAttr "script" ("language" =: "javascript" <> "src" =: "ghcjs/all.js" <> "defer" =: "defer") blank
171− liftIO $ renderFrontendHtml urlEnc route
172− (_frontend_head f >> ghcjsPreload)
173− (_frontend_body f >> ghcjsScript)
217+ cookies <- askCookies
218+ renderFrontendHtml configs cookies urlEnc route f ghcjsPreload ghcjsScript
219+
220+instance HasCookies Snap where
221+ askCookies = map (\c -> (cookieName c, cookieValue c)) <$> getsRequest rqCookies
222+
223+getComponentConfigs :: IO ComponentConfigs
224+getComponentConfigs = do
225+ allConfigs <- getConfigs
226+ return $ ComponentConfigs
227+ { _componentConfigs_backend =
228+ Map.filterWithKey (\k _ -> isMemberOf k ["common", "backend"]) allConfigs
229+ , _componentConfigs_frontend =
230+ Map.filterWithKey (\k _ -> isMemberOf k ["common", "frontend"]) allConfigs
231+ }
232+ where isMemberOf k dirs = or $ map (\dir -> ("config/" <> dir) `T.isPrefixOf` k) dirs