diff --git a/lib/backend/src/Obelisk/Backend.hs b/lib/backend/src/Obelisk/Backend.hs index 80dadaecf..1a7fc16d1 100644 --- a/lib/backend/src/Obelisk/Backend.hs +++ b/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 diff --git a/lib/command/src/Obelisk/Command/Run.hs b/lib/command/src/Obelisk/Command/Run.hs index 8c44ef9c6..3b8f20016 100644 --- a/lib/command/src/Obelisk/Command/Run.hs +++ b/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" diff --git a/lib/run/obelisk-run.cabal b/lib/run/obelisk-run.cabal index d1e72585e..15aed1c0b 100644 --- a/lib/run/obelisk-run.cabal +++ b/lib/run/obelisk-run.cabal @@ -36,6 +36,7 @@ library , reflex , reflex-dom-core , snap-core + , snap-server , streaming-commons , text , time diff --git a/lib/run/src/Obelisk/Run.hs b/lib/run/src/Obelisk/Run.hs index 11c64a2e4..30f0ad69f 100644 --- a/lib/run/src/Obelisk/Run.hs +++ b/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 diff --git a/skeleton/backend/src/Backend.hs b/skeleton/backend/src/Backend.hs index 5842ce9fd..a83659ea2 100644 --- a/skeleton/backend/src/Backend.hs +++ b/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 } +