@@ -1,4 +1,5 @@
11{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveGeneric #-}
23{-# LANGUAGE FlexibleContexts #-}
34{-# LANGUAGE FlexibleInstances #-}
45{-# LANGUAGE GADTs #-}
@@ -10,6 +11,10 @@
1011{-# OPTIONS_GHC -fno-warn-orphans #-}
1112module Obelisk.Backend
1213 ( Backend (..)
14+ , BackendConfig (..)
15+ , defaultBackendConfig
16+ , StaticAssets (..)
17+ , defaultStaticAssets
1318 -- * Running a backend
1419 , runBackend
1520 , runBackendWith
@@ -21,14 +26,15 @@ module Obelisk.Backend
2126 , delayedGhcjsScript
2227 -- * all.js preload functions
2328 , preloadGhcjs
29+ , renderAllJsPath
2430 -- * Re-exports
2531 , Default (def)
2632 , getPageName
2733 , getRouteWith
2834 , runSnapWithCommandLineArgs
35+ , runSnapWithConfig
2936 , serveDefaultObeliskApp
3037 , prettifyOutput
31− , renderAllJsPath
3238 , staticRenderContentType
3339 , getPublicConfigs
3440 ) where
@@ -46,6 +52,7 @@ import qualified Data.Map as Map
4652import Data.Monoid ((<>))
4753import Data.Text (Text)
4854import qualified Data.Text as T
55+import GHC.Generics (Generic)
4956import Obelisk.Asset.Serve.Snap (serveAsset)
5057import qualified Obelisk.ExecutableConfig.Lookup as Lookup
5158import Obelisk.Frontend
@@ -61,13 +68,21 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
6168data Backend backendRoute frontendRoute = Backend
6269 { _backend_routeEncoder :: Encoder (Either Text) Identity (R (FullRoute backendRoute frontendRoute)) PageName
6370 , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()
64− }
71+ } deriving (Generic)
72+
73+data BackendConfig frontendRoute = BackendConfig
74+ { _backendConfig_runSnap :: !(Snap () -> IO ()) -- ^ Function to run the snap server
75+ , _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
78+ -- loading the script.
79+ } deriving (Generic)
6580
6681-- | The static assets provided must contain a compiled GHCJS app that corresponds exactly to the Frontend provided
6782data GhcjsApp route = GhcjsApp
6883 { _ghcjsApp_compiled :: !StaticAssets
6984 , _ghcjsApp_value :: !(Frontend route)
70− }
85+ } deriving (Generic)
7186
7287-- | Widgets used to load all.js on the frontend
7388data GhcjsWidgets a = GhcjsWidgets
@@ -75,7 +90,8 @@ data GhcjsWidgets a = GhcjsWidgets
7590 -- ^ A preload widget, placed in the document head
7691 , _ghcjsWidgets_script :: a
7792 -- ^ A script widget, placed in the document body
78− } deriving Functor
93+ } deriving (Functor, Generic)
94+
7995
8096-- | Given the URL of all.js, return the widgets which are responsible for
8197-- loading the script. Defaults to 'preloadGhcjs' and 'deferredGhcjsScript'.
@@ -122,17 +138,20 @@ defaultFrontendGhcjsAssets = StaticAssets
122138 , _staticAssets_unprocessed = "frontend.jsexe"
123139 }
124140
125−runSnapWithCommandLineArgs :: MonadIO m => Snap () -> m ()
126−runSnapWithCommandLineArgs a = do
127− -- Get the web server configuration from the command line
128− cmdLineConf <- liftIO $ commandLineConfig defaultConfig
129− let httpConf = cmdLineConf
141+runSnapWithConfig :: MonadIO m => Config Snap a -> Snap () -> m ()
142+runSnapWithConfig conf a = do
143+ let httpConf = conf
130144 { accessLog = Just $ ConfigIoLog BSC8.putStrLn
131145 , errorLog = Just $ ConfigIoLog BSC8.putStrLn
132146 }
133147 -- Start the web server
134148 liftIO $ httpServe httpConf a
135149
150+-- Get the web server configuration from the command line
151+runSnapWithCommandLineArgs :: MonadIO m => Snap () -> m ()
152+runSnapWithCommandLineArgs s = liftIO (commandLineConfig defaultConfig) >>= \c ->
153+ runSnapWithConfig c s
154+
136155getPageName :: (MonadSnap m) => m PageName
137156getPageName = do
138157 p <- getsRequest rqPathInfo
@@ -200,27 +219,31 @@ serveGhcjsApp urlEnc ghcjsWidgets app config = \case
200219 writeBS <=< renderGhcjsFrontend urlEnc ghcjsWidgets (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app
201220 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments
202221
222+-- | Default obelisk backend configuration.
223+defaultBackendConfig :: BackendConfig frontendRoute
224+defaultBackendConfig = BackendConfig runSnapWithCommandLineArgs defaultStaticAssets defaultGhcjsWidgets
225+
226+-- | Run an obelisk backend with the default configuration.
203227runBackend :: Backend backendRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
204−runBackend = runBackendWith defaultGhcjsWidgets
228+runBackend = runBackendWith defaultBackendConfig
205229
230+-- | Run an obelisk backend with the given configuration.
206231runBackendWith
207− :: GhcjsWidgets (Text -> FrontendWidgetT (R frontendRoute) ())
208− -- ^ Given the URL of all.js, return the widgets which are responsible for
209− -- loading the script.
232+ :: BackendConfig frontendRoute
210233 -> Backend backendRoute frontendRoute
211234 -> Frontend (R frontendRoute)
212235 -> IO ()
213−runBackendWith ghcjsWidgets backend frontend = case checkEncoder $ _backend_routeEncoder backend of
236+runBackendWith (BackendConfig runSnap staticAssets ghcjsWidgets) backend frontend = case checkEncoder $ _backend_routeEncoder backend of
214237 Left e -> fail $ "backend error:\n" <> T.unpack e
215238 Right validFullEncoder -> do
216239 publicConfigs <- getPublicConfigs
217240 _backend_run backend $ \serveRoute ->
218− runSnapWithCommandLineArgs $
241+ runSnap $
219242 getRouteWith validFullEncoder >>= \case
220243 Identity r -> case r of
221244 FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a
222245 FullRoute_Frontend obeliskRoute :/ a ->
223− serveDefaultObeliskApp routeToUrl (($ allJsUrl) <$> ghcjsWidgets) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $
246+ serveDefaultObeliskApp routeToUrl (($ allJsUrl) <$> ghcjsWidgets) (serveStaticAssets staticAssets) frontend publicConfigs $
224247 obeliskRoute :/ a
225248 where
226249 routeToUrl (k :/ v) = renderObeliskRoute validFullEncoder $ FullRoute_Frontend (ObeliskRoute_App k) :/ v