git.iko.soy/jsaddle
on master help sign in
Refactor to make it easier to serve static files along with jsaddle-warp
86b8193Ryan Trinkle
jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs+2−3
compare with master
unifiedsplit
@@ -17,8 +17,7 @@ module Language.Javascript.JSaddle.Warp (
17 -- * Running JSM over WebSockets
17 -- * Running JSM over WebSockets
18 run
18 run
19#ifndef ghcjs_HOST_OS
19#ifndef ghcjs_HOST_OS
20− , jsaddleOr
20+ , module Language.Javascript.JSaddle.WebSockets
21− , jsaddleApp
22#endif
21#endif
23) where
22) where
24
23
@@ -29,7 +28,7 @@ import Network.WebSockets (defaultConnectionOptions)
29
28
30import Language.Javascript.JSaddle.Types (JSM)
29import Language.Javascript.JSaddle.Types (JSM)
31import Language.Javascript.JSaddle.Run (syncPoint)
30import Language.Javascript.JSaddle.Run (syncPoint)
32−import Language.Javascript.JSaddle.WebSockets (jsaddleOr, jsaddleApp)
31+import Language.Javascript.JSaddle.WebSockets
33#endif
32#endif
34
33
35-- | Run the given 'JSM' action as the main entry point. Either directly
34-- | Run the given 'JSM' action as the main entry point. Either directly
jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+21−16
@@ -16,6 +16,8 @@ module Language.Javascript.JSaddle.WebSockets (
16 -- * Running JSM over WebSockets
16 -- * Running JSM over WebSockets
17 jsaddleOr
17 jsaddleOr
18 , jsaddleApp
18 , jsaddleApp
19+ , jsaddleWithAppOr
20+ , jsaddleAppPartial
19) where
21) where
20
22
21import Control.Monad (forever)
23import Control.Monad (forever)
@@ -25,7 +27,7 @@ import Control.Exception (handle, AsyncException, throwIO, fromException)
25import Data.Monoid ((<>))
27import Data.Monoid ((<>))
26import Data.Aeson (encode, decode)
28import Data.Aeson (encode, decode)
27
29
28−import Network.Wai (Application)
30+import Network.Wai (Application, Request, Response, ResponseReceived)
29import Network.WebSockets
31import Network.WebSockets
30 (ConnectionOptions(..), sendTextData, receiveDataMessage,
32 (ConnectionOptions(..), sendTextData, receiveDataMessage,
31 acceptRequest, ServerApp, sendPing)
33 acceptRequest, ServerApp, sendPing)
@@ -34,11 +36,10 @@ import Network.Wai.Handler.WebSockets (websocketsOr)
34
36
35import Language.Javascript.JSaddle.Types (JSM(..))
37import Language.Javascript.JSaddle.Types (JSM(..))
36import qualified Network.Wai as W
38import qualified Network.Wai as W
37− (responseLBS, requestMethod, Application, pathInfo)
39+ (responseLBS, requestMethod, pathInfo)
38−import Data.Text (Text)
39import qualified Data.Text as T (pack)
40import qualified Data.Text as T (pack)
40import qualified Network.HTTP.Types as H
41import qualified Network.HTTP.Types as H
41− (status403, status200, status405)
42+ (status403, status200)
42import Language.Javascript.JSaddle.Run (runJavaScript)
43import Language.Javascript.JSaddle.Run (runJavaScript)
43import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)
44import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)
44
45
@@ -73,16 +74,20 @@ jsaddleOr opts entryPoint = websocketsOr opts wsApp
73 Nothing -> return ()
74 Nothing -> return ()
74
75
75jsaddleApp :: Application
76jsaddleApp :: 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"
77
82
78−jsaddleAppPieces :: [Text] -> W.Application
83+jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> Application
84+jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
79−jsaddleAppPieces _ req sendResponse
85+ jsaddleAppPartial req sendResponse >>= \case
80− | W.requestMethod req `notElem` ["GET", "HEAD"] = sendResponse $ W.responseLBS
86+ Just r -> return r
81− H.status405
87+ Nothing -> otherApp req sendResponse
82− [("Content-Type", "text/plain")]
88+
83− "Only GET or HEAD is supported"
89+jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> IO (Maybe ResponseReceived)
90+jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of
84−jsaddleAppPieces [] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
91+ ("GET", []) -> fmap Just $ 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
92+ ("GET", ["jsaddle.js"]) -> fmap Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs
86−jsaddleAppPieces _rawPieces _req sendResponse = sendResponse $ W.responseLBS H.status403
93+ _ -> return Nothing
87− [ ("Content-Type", "text/plain")
88− ] "Forbidden"