From 8ebf96891fe9580fc16e1fe99b0ca503b9cf2ed8 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Tue, 26 Nov 2024 01:14:22 +0000 Subject: [PATCH] Allow custom HTML head --- .../src/Language/Javascript/JSaddle/Warp.hs | 12 +++-- .../Language/Javascript/JSaddle/WebSockets.hs | 54 +++++++++---------- .../Language/Javascript/JSaddle/Run/Files.hs | 15 ++++-- 3 files changed, 44 insertions(+), 37 deletions(-) diff --git a/jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs b/jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs index 1a0a3c9c..4483ce83 100644 --- a/jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs +++ b/jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs @@ -21,6 +21,8 @@ module Language.Javascript.JSaddle.Warp ( #endif ) where +import Data.ByteString.Lazy (ByteString) + #ifndef ghcjs_HOST_OS import Network.Wai.Handler.Warp (defaultSettings, setTimeout, setPort, runSettings) @@ -34,11 +36,11 @@ import Language.Javascript.JSaddle.WebSockets -- | Run the given 'JSM' action as the main entry point. Either directly -- in GHCJS or as a Warp server on the given port on GHC. #ifdef ghcjs_HOST_OS -run :: Int -> IO () -> IO () -run _port = id +run :: Maybe ByteString -> Int -> IO () -> IO () +run _head _port = id #else -run :: Int -> JSM () -> IO () -run port f = +run :: Maybe ByteString -> Int -> JSM () -> IO () +run head_ port f = runSettings (setPort port (setTimeout 3600 defaultSettings)) =<< - jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp + jsaddleOr head_ defaultConnectionOptions (f >> syncPoint) (jsaddleApp head_) #endif diff --git a/jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs b/jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs index 14df014f..ddb3b333 100644 --- a/jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs +++ b/jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs @@ -74,8 +74,8 @@ import Control.Monad.IO.Class (MonadIO(..)) import Language.Javascript.JSaddle.WebSockets.Compat (getTextMessageByteString) import qualified Data.Text.Encoding as T (decodeUtf8) -jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application -jsaddleOr opts entryPoint otherApp = do +jsaddleOr :: Maybe ByteString -> ConnectionOptions -> JSM () -> Application -> IO Application +jsaddleOr head_ opts entryPoint otherApp = do syncHandlers <- newIORef M.empty asyncHandlers <- newIORef M.empty let wsApp :: ServerApp @@ -133,39 +133,39 @@ jsaddleOr opts entryPoint otherApp = do (method, _) -> (catch404 otherApp) req sendResponse where catch404 = W.modifyResponse $ \resp -> case (method, W.responseStatus resp) of - ("GET", Status 404 _) -> indexResponse + ("GET", Status 404 _) -> indexResponse head_ _ -> resp return $ websocketsOr opts wsApp syncHandler -jsaddleApp :: Application -jsaddleApp = jsaddleAppWithJs $ jsaddleJs False +jsaddleApp :: Maybe ByteString -> Application +jsaddleApp head_ = jsaddleAppWithJs head_ $ jsaddleJs False -jsaddleAppWithJs :: ByteString -> Application -jsaddleAppWithJs js req sendResponse = - jsaddleAppWithJsOr js +jsaddleAppWithJs :: Maybe ByteString -> ByteString -> Application +jsaddleAppWithJs head_ js req sendResponse = + jsaddleAppWithJsOr head_ js (\_ _ -> sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden") req sendResponse -jsaddleAppWithJsOr :: ByteString -> Application -> Application -jsaddleAppWithJsOr js otherApp req sendResponse = +jsaddleAppWithJsOr :: Maybe ByteString -> ByteString -> Application -> Application +jsaddleAppWithJsOr head_ js otherApp req sendResponse = fromMaybe (otherApp req sendResponse) - (jsaddleAppPartialWithJs js req sendResponse) + (jsaddleAppPartialWithJs head_ js req sendResponse) -jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application -jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse -> +jsaddleWithAppOr :: Maybe ByteString -> ConnectionOptions -> JSM () -> Application -> IO Application +jsaddleWithAppOr head_ opts entryPoint otherApp = jsaddleOr head_ opts entryPoint $ \req sendResponse -> (fromMaybe (otherApp req sendResponse) - (jsaddleAppPartial req sendResponse)) + (jsaddleAppPartial head_ req sendResponse)) -jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived) -jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False +jsaddleAppPartial :: Maybe ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived) +jsaddleAppPartial head_ = jsaddleAppPartialWithJs head_ $ jsaddleJs False -indexResponse :: Response -indexResponse = W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml +indexResponse :: Maybe ByteString -> Response +indexResponse = W.responseLBS H.status200 [("Content-Type", "text/html")] . indexHtml -jsaddleAppPartialWithJs :: ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived) -jsaddleAppPartialWithJs js req sendResponse = case (W.requestMethod req, W.pathInfo req) of - ("GET", []) -> Just $ sendResponse indexResponse +jsaddleAppPartialWithJs :: Maybe ByteString -> ByteString -> Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived) +jsaddleAppPartialWithJs head_ js req sendResponse = case (W.requestMethod req, W.pathInfo req) of + ("GET", []) -> Just $ sendResponse $ indexResponse head_ ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js _ -> Nothing @@ -246,18 +246,18 @@ jsaddleJs' jsaddleUri refreshOnLoad = "\ -- To run this as part of every GHCI @:reload@ use: -- -- >>> :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction") -debug :: Int -> JSM () -> IO () -debug port f = do +debug :: Maybe ByteString -> Int -> JSM () -> IO () +debug head_ port f = do debugWrapper $ \withRefresh registerContext -> runSettings (setPort port (setTimeout 3600 defaultSettings)) =<< - jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs True) + jsaddleOr head_ defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs head_ $ jsaddleJs True) putStrLn $ " show port <> "\">run" -debugOr :: Int -> JSM () -> Application -> IO () -debugOr port f b = do +debugOr :: Maybe ByteString -> Int -> JSM () -> Application -> IO () +debugOr head_ port f b = do debugWrapper $ \withRefresh registerContext -> runSettings (setPort port (setTimeout 3600 defaultSettings)) =<< - jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJsOr (jsaddleJs True) b) + jsaddleOr head_ defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJsOr head_ (jsaddleJs True) b) putStrLn $ " show port <> "\">run" refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware diff --git a/jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs b/jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs index 7f7fdf6b..2365008a 100644 --- a/jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs +++ b/jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs @@ -22,14 +22,19 @@ import Prelude () import Prelude.Compat import Data.ByteString.Lazy (ByteString) +import Data.Maybe (fromMaybe) -indexHtml :: ByteString -indexHtml = +indexHtml :: Maybe ByteString -> ByteString +indexHtml head_ = "\n\ \\n\ - \\n\ - \JSaddle\n\ - \\n\ + \\n" + <> + fromMaybe + "JSaddle\n" + head_ + <> + "\n\ \\n\ \\n\ \\n\