Interface to change Snap config

lib/backend/src/Obelisk/Backend.hs

@@ -68,10 +68,12 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
 data Backend backendRoute frontendRoute = Backend
   { _backend_routeEncoder :: Encoder (Either Text) Identity (R (FullRoute backendRoute frontendRoute)) PageName
   , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()
+  , _backend_updateSnapConfig :: Config Snap () -> Config Snap ()
   } deriving (Generic)
 
 data BackendConfig frontendRoute = BackendConfig
-  { _backendConfig_runSnap :: !(Snap () -> IO ()) -- ^ Function to run the snap server
+  { _backendConfig_runSnap :: !((Config Snap () -> Config Snap ()) -> Snap () -> IO ())
+  -- ^ Function to run the snap server
   , _backendConfig_staticAssets :: !StaticAssets -- ^ Static assets
   , _backendConfig_ghcjsWidgets :: !(GhcjsWidgets (Text -> FrontendWidgetT (R frontendRoute) ()))
     -- ^ Given the URL of all.js, return the widgets which are responsible for
@@ -148,9 +150,9 @@ runSnapWithConfig conf a = do
   liftIO $ httpServe httpConf a
 
 -- Get the web server configuration from the command line
-runSnapWithCommandLineArgs :: MonadIO m => Snap () -> m ()
-runSnapWithCommandLineArgs s = liftIO (commandLineConfig defaultConfig) >>= \c ->
-  runSnapWithConfig c s
+runSnapWithCommandLineArgs :: MonadIO m => (Config Snap () -> Config Snap ()) -> Snap () -> m ()
+runSnapWithCommandLineArgs updateConfig s = liftIO (commandLineConfig defaultConfig) >>= \c ->
+  runSnapWithConfig (updateConfig c) s
 
 getPageName :: (MonadSnap m) => m PageName
 getPageName = do
@@ -233,12 +235,12 @@ runBackendWith
   -> Backend backendRoute frontendRoute
   -> Frontend (R frontendRoute)
   -> IO ()
-runBackendWith (BackendConfig runSnap staticAssets ghcjsWidgets) backend frontend = case checkEncoder $ _backend_routeEncoder backend of
+runBackendWith (BackendConfig runSnapWithConfigModify staticAssets ghcjsWidgets) backend frontend = case checkEncoder $ _backend_routeEncoder backend of
   Left e -> fail $ "backend error:\n" <> T.unpack e
   Right validFullEncoder -> do
     publicConfigs <- getPublicConfigs
     _backend_run backend $ \serveRoute ->
-      runSnap $
+      runSnapWithConfigModify (_backend_updateSnapConfig backend) $
         getRouteWith validFullEncoder >>= \case
           Identity r -> case r of
             FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

lib/command/src/Obelisk/Command/Run.hs

@@ -200,6 +200,7 @@ run certDir root interpretPaths = do
     runGhcid root True (ghciArgs <> dotGhciArgs) pkgs $ Just $ unwords
       [ "Obelisk.Run.run"
       , show freePort
+      , "(Obelisk.Backend._backend_updateSnapConfig Backend.backend)"
       , "(" ++ show certDir ++ ")"
       , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
       , "Backend.backend"

lib/run/obelisk-run.cabal

@@ -36,6 +36,7 @@ library
     , reflex
     , reflex-dom-core
     , snap-core
+    , snap-server
     , streaming-commons
     , text
     , time

lib/run/src/Obelisk/Run.hs

@@ -64,6 +64,7 @@ import qualified OpenSSL.X509 as X509
 import qualified OpenSSL.X509.Request as X509Request
 import Reflex.Dom.Core
 import Snap.Core (Snap)
+import Snap.Internal.Http.Server.Config (Config)
 import System.Environment
 import System.FilePath ((</>))
 import System.IO
@@ -77,15 +78,17 @@ import Web.Cookie
 import qualified System.Which
 #endif
 
+
 run
   :: Int -- ^ Port to run the backend
+  -> (Config Snap () -> Config Snap ())
   -> Maybe FilePath -- ^ Optional directory in which to find "cert.pem", "chain.pem" and "privkey.pem" to be used for TLS.
                     -- If this is Nothing and TLS is enabled, we'll generate a self-signed cert.
   -> ([Text] -> Snap ()) -- ^ Static asset handler
   -> Backend backendRoute frontendRoute -- ^ Backend
   -> Frontend (R frontendRoute) -- ^ Frontend
   -> IO ()
-run port certDir serveStaticAsset backend frontend = do
+run port updateSnapConfigs certDir serveStaticAsset backend frontend = do
   prettifyOutput
   let handleBackendErr (e :: IOException) = hPutStrLn stderr $ "backend stopped; make a change to your code to reload - error " <> show e
   --TODO: Use Obelisk.Backend.runBackend; this will require separating the checking and running phases
@@ -95,7 +98,7 @@ run port certDir serveStaticAsset backend frontend = do
       publicConfigs <- getPublicConfigs
       backendTid <- forkIO $ handle handleBackendErr $ withArgs ["--quiet", "--port", show port] $
         _backend_run backend $ \serveRoute ->
-          runSnapWithCommandLineArgs $
+          runSnapWithCommandLineArgs updateSnapConfigs $
             getRouteWith validFullEncoder >>= \case
               Identity r -> case r of
                 FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

skeleton/backend/src/Backend.hs

@@ -7,4 +7,6 @@ backend :: Backend BackendRoute FrontendRoute
 backend = Backend
   { _backend_run = \serve -> serve $ const $ return ()
   , _backend_routeEncoder = fullRouteEncoder
+  , _backend_updateSnapConfig = id 
   }
+