@@ -16,6 +16,8 @@ module Language.Javascript.JSaddle.WebSockets (
1616 -- * Running JSM over WebSockets
1717 jsaddleOr
1818 , jsaddleApp
19+ , jsaddleWithAppOr
20+ , jsaddleAppPartial
1921) where
2022
2123import Control.Monad (forever)
@@ -25,7 +27,7 @@ import Control.Exception (handle, AsyncException, throwIO, fromException)
2527import Data.Monoid ((<>))
2628import Data.Aeson (encode, decode)
2729
28−import Network.Wai (Application)
30+import Network.Wai (Application, Request, Response, ResponseReceived)
2931import Network.WebSockets
3032 (ConnectionOptions(..), sendTextData, receiveDataMessage,
3133 acceptRequest, ServerApp, sendPing)
@@ -34,11 +36,10 @@ import Network.Wai.Handler.WebSockets (websocketsOr)
3436
3537import Language.Javascript.JSaddle.Types (JSM(..))
3638import qualified Network.Wai as W
37− (responseLBS, requestMethod, Application, pathInfo)
38−import Data.Text (Text)
39+ (responseLBS, requestMethod, pathInfo)
3940import qualified Data.Text as T (pack)
4041import qualified Network.HTTP.Types as H
41− (status403, status200, status405)
42+ (status403, status200)
4243import Language.Javascript.JSaddle.Run (runJavaScript)
4344import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)
4445
@@ -73,16 +74,20 @@ jsaddleOr opts entryPoint = websocketsOr opts wsApp
7374 Nothing -> return ()
7475
7576jsaddleApp :: Application
76−jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req
77+jsaddleApp req sendResponse = jsaddleAppPartial req sendResponse >>= \case
78+ Just r -> return r
79+ Nothing -> sendResponse $ W.responseLBS H.status403
80+ [ ("Content-Type", "text/plain")
81+ ] "Forbidden"
7782
78−jsaddleAppPieces :: [Text] -> W.Application
79−jsaddleAppPieces _ req sendResponse
80− | W.requestMethod req `notElem` ["GET", "HEAD"] = sendResponse $ W.responseLBS
81− H.status405
82− [("Content-Type", "text/plain")]
83− "Only GET or HEAD is supported"
84−jsaddleAppPieces [] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
85−jsaddleAppPieces ["jsaddle.js"] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
86−jsaddleAppPieces _rawPieces _req sendResponse = sendResponse $ W.responseLBS H.status403
87− [ ("Content-Type", "text/plain")
88− ] "Forbidden"
83+jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> Application
84+jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
85+ jsaddleAppPartial req sendResponse >>= \case
86+ Just r -> return r
87+ Nothing -> otherApp req sendResponse
88+
89+jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> IO (Maybe ResponseReceived)
90+jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of
91+ ("GET", []) -> fmap Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
92+ ("GET", ["jsaddle.js"]) -> fmap Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
93+ _ -> return Nothing