diff --git a/jsaddle-warp.cabal b/jsaddle-warp.cabal
--- a/jsaddle-warp.cabal
+++ b/jsaddle-warp.cabal
@@ -1,5 +1,5 @@
name: jsaddle-warp
-version: 0.9.5.0
+version: 0.9.6.0
cabal-version: >=1.10
build-type: Simple
license: MIT
@@ -24,21 +24,23 @@
if !impl(ghcjs -any)
exposed-modules:
Language.Javascript.JSaddle.WebSockets
+ other-modules:
+ Language.Javascript.JSaddle.WebSockets.Compat
build-depends:
- aeson >=0.8.0.2 && <1.3,
+ aeson >=0.8.0.2 && <1.5,
bytestring >=0.10.6.0 && <0.11,
- containers >=0.5.6.2 && <0.6,
+ containers >=0.5.6.2 && <0.7,
foreign-store >=0.2 && <0.3,
- http-types >=0.8.6 && <0.10,
+ http-types >=0.8.6 && <0.13,
jsaddle >=0.9.4.0 && <0.10,
- stm >=2.4.4 && <2.5,
+ stm >=2.4.4 && <2.6,
text >=1.2.1.3 && <1.3,
time >=1.5.0.1 && <1.9,
transformers >=0.4.2.0 && <0.6,
wai >=3.0.3.0 && <3.3,
wai-websockets >=3.0.0.6 && <3.1,
warp >=3.1.2 && <3.3,
- websockets >=0.9.5.0 && <0.11
+ websockets >=0.9.5.0 && <0.13
exposed-modules:
Language.Javascript.JSaddle.Warp
build-depends:
@@ -57,8 +59,10 @@
bytestring -any,
containers -any,
deepseq -any,
- doctest >=0.10.1 && <0.12,
+ doctest >=0.10.1 && <0.17,
+ exceptions -any,
filepath >=1.4.0.0 && <1.5,
+ foreign-store -any,
ghc-prim -any,
http-types -any,
jsaddle -any,
@@ -68,10 +72,12 @@
ref-tf -any,
primitive -any,
process >=1.2.3.0 && <1.7,
+ random -any,
stm -any,
text -any,
time -any,
transformers -any,
+ unliftio-core -any,
wai -any,
wai-websockets -any,
warp -any,
diff --git a/src/Language/Javascript/JSaddle/WebSockets.hs b/src/Language/Javascript/JSaddle/WebSockets.hs
--- a/src/Language/Javascript/JSaddle/WebSockets.hs
+++ b/src/Language/Javascript/JSaddle/WebSockets.hs
@@ -19,8 +19,13 @@
jsaddleOr
, jsaddleApp
, jsaddleWithAppOr
+ , jsaddleAppWithJs
+ , jsaddleAppWithJsOr
, jsaddleAppPartial
+ , jsaddleJs
+ , jsaddleJs'
, debug
+ , debugOr
, debugWrapper
) where
@@ -37,12 +42,12 @@
import Network.WebSockets
(defaultConnectionOptions, ConnectionOptions(..), sendTextData,
receiveDataMessage, acceptRequest, ServerApp, sendPing)
-import qualified Network.WebSockets as WS (DataMessage(..))
import Network.Wai.Handler.WebSockets (websocketsOr)
+import Network.HTTP.Types (Status(..))
import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))
import qualified Network.Wai as W
- (responseLBS, requestMethod, pathInfo)
+ (responseLBS, requestMethod, pathInfo, modifyResponse, responseStatus)
import qualified Data.Text as T (pack)
import qualified Network.HTTP.Types as H
(status403, status200)
@@ -55,42 +60,57 @@
import Data.IORef
(readIORef, newIORef, atomicModifyIORef')
import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+ (toStrict, stripPrefix)
import Control.Concurrent.MVar
(tryTakeMVar, MVar, tryPutMVar, modifyMVar_, putMVar, takeMVar,
readMVar, newMVar, newEmptyMVar, modifyMVar)
import Network.Wai.Handler.Warp
(defaultSettings, setTimeout, setPort, runSettings)
-import Foreign.Store (newStore, readStore, lookupStore)
+import Foreign.Store (readStore, lookupStore, writeStore, Store(..))
import Language.Javascript.JSaddle (askJSM)
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
syncHandlers <- newIORef M.empty
+ asyncHandlers <- newIORef M.empty
let wsApp :: ServerApp
wsApp pending_conn = do
conn <- acceptRequest pending_conn
- rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
- syncKey <- T.pack . show . contextId <$> askJSM
- liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))
- liftIO $ sendTextData conn (encode syncKey)
- entryPoint
- _ <- forkIO . forever $
- receiveDataMessage conn >>= \case
- (WS.Text t) ->
- case decode t of
- Nothing -> error $ "jsaddle Results decode failed : " <> show t
- Just r -> processResult r
- _ -> error "jsaddle WebSocket unexpected binary data"
- start
- waitTillClosed conn
+ initMsg <- receiveDataMessage conn
+ case getTextMessageByteString initMsg of
+ Just "" -> do
+ rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do
+ syncKey <- T.pack . show . contextId <$> askJSM
+ liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))
+ liftIO $ atomicModifyIORef' asyncHandlers (\m -> (M.insert syncKey processResult m, ()))
+ liftIO $ sendTextData conn (encode syncKey)
+ entryPoint
+ start
+ waitTillClosed conn
+ Just syncKey ->
+ M.lookup (T.decodeUtf8 $ LBS.toStrict syncKey) <$> readIORef syncHandlers >>= \case
+ Nothing -> error "jsaddle missing sync message handler"
+ Just processResult ->
+ forever $
+ receiveDataMessage conn >>= \msg -> case getTextMessageByteString msg of
+ Just t ->
+ case decode t of
+ Nothing -> error $ "jsaddle Results decode failed : " <> show t
+ Just r -> processResult r
+ _ -> error "jsaddle WebSocket unexpected binary data"
+ _ -> error "jsaddle WebSocket unexpected binary data"
-- Based on Network.WebSocket.forkPingThread
waitTillClosed conn = ignore `handle` go 1
where
go :: Int -> IO ()
go i = do
- threadDelay (1 * 1000 * 1000)
+ threadDelay (10 * 1000 * 1000)
sendPing conn (T.pack $ show i)
go (i + 1)
@@ -110,7 +130,11 @@
Just handler -> do
next <- encode <$> handler result
sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next
- _ -> otherApp req sendResponse
+ (method, _) -> (catch404 otherApp) req sendResponse
+ where catch404 = W.modifyResponse $ \resp ->
+ case (method, W.responseStatus resp) of
+ ("GET", Status 404 _) -> indexResponse
+ _ -> resp
return $ websocketsOr opts wsApp syncHandler
@@ -119,10 +143,15 @@
jsaddleAppWithJs :: ByteString -> Application
jsaddleAppWithJs js req sendResponse =
- fromMaybe
- (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
- (jsaddleAppPartialWithJs js req sendResponse)
+ jsaddleAppWithJsOr js
+ (\_ _ -> sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")
+ req sendResponse
+jsaddleAppWithJsOr :: ByteString -> Application -> Application
+jsaddleAppWithJsOr js otherApp req sendResponse =
+ fromMaybe (otherApp req sendResponse)
+ (jsaddleAppPartialWithJs js req sendResponse)
+
jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application
jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->
(fromMaybe (otherApp req sendResponse)
@@ -131,38 +160,58 @@
jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)
jsaddleAppPartial = jsaddleAppPartialWithJs $ jsaddleJs False
+indexResponse :: 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 $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml
+ ("GET", []) -> Just $ sendResponse indexResponse
("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] js
_ -> Nothing
+jsaddleJs :: Bool -> ByteString
+jsaddleJs = jsaddleJs' Nothing
+
-- Use this to generate this string for embedding
-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy
-jsaddleJs :: Bool -> ByteString
-jsaddleJs refreshOnLoad = "\
+jsaddleJs' :: Maybe ByteString -> Bool -> ByteString
+jsaddleJs' jsaddleUri refreshOnLoad = "\
\if(typeof global !== \"undefined\") {\n\
\ global.window = global;\n\
\ global.WebSocket = require('ws');\n\
\}\n\
\\n\
\var connect = function() {\n\
- \ var wsaddress = window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\
+ \ var wsaddress = "
+ <> maybe "window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\")"
+ (\ s -> "\"ws" <> s <> "\"")
+ (jsaddleUri >>= LBS.stripPrefix "http")
+ <> ";\n\
\\n\
- \ var ws = new WebSocket(wsaddress);\n\
+ \ var ws0 = new WebSocket(wsaddress);\n\
\ var syncKey = \"\";\n\
\\n\
- \ ws.onopen = function(e) {\n\
+ \ ws0.onopen = function(e) {\n\
+ \ ws0.send(\"\");\n\
+ \ var initialResults = [];\n\
+ \ var ws = {send: function(m) {initialResults.push(m);}};\n\
\ " <> initState <> "\n\
\\n\
- \ ws.onmessage = function(e) {\n\
+ \ ws0.onmessage = function(e) {\n\
\ var batch = JSON.parse(e.data);\n\
\ if(inCallback > 0) {\n\
\ asyncBatch = batch;\n\
\ return;\n\
\ }\n\
\ if(typeof batch === \"string\") {\n\
- \ syncKey = batch;\n" <>
+ \ syncKey = batch;\n\
+ \ var ws1 = new WebSocket(wsaddress);\n\
+ \ ws1.onopen = function(e) {\n\
+ \ ws1.send(syncKey);\n\
+ \ initialResults.forEach(function(m){ ws1.send(m); });\n\
+ \ initialResults = null;\n\
+ \ ws = ws1;\n\
+ \ }\n" <>
(if refreshOnLoad
then " var xhr = new XMLHttpRequest();\n\
\ xhr.open('POST', '/reload/'+syncKey, true);\n\
@@ -178,13 +227,13 @@
\ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")
(Just (\a -> "(function(){\n\
\ var xhr = new XMLHttpRequest();\n\
- \ xhr.open('POST', '/sync/'+syncKey, false);\n\
+ \ xhr.open('POST', '" <> fromMaybe "" jsaddleUri <> "/sync/'+syncKey, false);\n\
\ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\
\ xhr.send(JSON.stringify(" <> a <> "));\n\
\ return JSON.parse(xhr.response);})()")) <> "\
\ };\n\
\ };\n\
- \ ws.onerror = function() {\n\
+ \ ws0.onerror = function() {\n\
\ setTimeout(connect, 1000);\n\
\ };\n\
\}\n\
@@ -203,6 +252,13 @@
jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJs $ jsaddleJs True)
putStrLn $ " show port <> "\">run"
+debugOr :: Int -> JSM () -> Application -> IO ()
+debugOr port f b = do
+ debugWrapper $ \withRefresh registerContext ->
+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<
+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (withRefresh $ jsaddleAppWithJsOr (jsaddleJs True) b)
+ putStrLn $ " show port <> "\">run"
+
refreshMiddleware :: ((Response -> IO ResponseReceived) -> IO ResponseReceived) -> Middleware
refreshMiddleware refresh otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of
("POST", ["reload", _syncKey]) -> refresh sendResponse
@@ -251,13 +307,13 @@
start' <- takeMVar mvar
n <- stop
start' n >>= restarter mvar
- lookupStore shutdown_0 >>= \case
+ lookupStore storeId >>= \case
Nothing -> do
restartMVar <- newMVar start
void . forkIO $ restarter restartMVar (return 0)
- void $ newStore restartMVar
+ void $ writeStore (Store storeId) restartMVar
Just shutdownStore -> do
restartMVar :: MVar (Int -> IO (IO Int)) <- readStore shutdownStore
void $ tryTakeMVar restartMVar
putMVar restartMVar start
- where shutdown_0 = 0
+ where storeId = 354
diff --git a/src/Language/Javascript/JSaddle/WebSockets/Compat.hs b/src/Language/Javascript/JSaddle/WebSockets/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Javascript/JSaddle/WebSockets/Compat.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Language.Javascript.JSaddle.WebSockets.Compat
+-- Copyright : (c) Hamish Mackenzie
+-- License : MIT
+--
+-- Maintainer : Hamish Mackenzie
+--
+-- | This module is necessary to harmonize various versions of the websockets
+-- package; we can't do this CPP inline in
+-- Language.Javascript.JSaddle.WebSockets because that module uses multi-line
+-- strings, which are incompatible with CPP
+--
+-----------------------------------------------------------------------------
+module Language.Javascript.JSaddle.WebSockets.Compat where
+
+import Data.ByteString.Lazy (ByteString)
+import qualified Network.WebSockets as WS (DataMessage(..))
+
+getTextMessageByteString :: WS.DataMessage -> Maybe ByteString
+getTextMessageByteString msg = case msg of
+#if MIN_VERSION_websockets(0,11,0)
+ (WS.Text t _) ->
+#else
+ (WS.Text t) ->
+#endif
+ Just t
+ _ -> Nothing
diff --git a/tests/DocTest.hs b/tests/DocTest.hs
--- a/tests/DocTest.hs
+++ b/tests/DocTest.hs
@@ -11,18 +11,17 @@
import System.FilePath (())
import System.Exit (exitFailure, exitWith, ExitCode(..))
import System.Process (readProcess, system)
-import Control.Concurrent (forkIO)
+import Control.Concurrent
+ (takeMVar, newEmptyMVar, forkIO, threadDelay, putMVar)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Monoid ((<>))
import System.Environment (getArgs)
-import Language.Javascript.JSaddle.Run.Files (jsaddleJs)
-import qualified Data.ByteString.Lazy.Char8 as BS (unpack)
import Test.WebDriver (runSession, defaultConfig, openPage, closeSession)
main :: IO ()
main = do
- putStrLn "Hello"
+ putStrLn "Testing JSaddle"
jsaddlePath <- getArgs >>= \case
[arg] -> return arg
_ -> do
@@ -30,14 +29,18 @@
exitFailure
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
+ putStrLn "Checking for phantomjs"
node <- system "phantomjs --version" >>= \case
ExitSuccess -> return ()
e -> do
putStrLn "phantomjs not found"
exitWith e
- forkIO . void $ readProcess "phantomjs" ["--webdriver=4444"] (BS.unpack jsaddleJs) >>= putStr
- runSession defaultConfig $ do
- openPage "http://localhost:3709"
+ putStrLn "Starting phantomjs"
+ forkIO . void $ readProcess "phantomjs" ["--webdriver=4444"] "" >>= putStr
+ threadDelay 5000000
+ putStrLn "Running Tests"
+ done <- newEmptyMVar
+ forkIO $ do
liftIO $ doctest [
"-hide-all-packages",
"-package=base-" ++ VERSION_base,
@@ -61,6 +64,10 @@
"-package=ref-tf-" ++ VERSION_ref_tf,
"-package=deepseq-" ++ VERSION_deepseq,
"-package=ghc-prim-" ++ VERSION_ghc_prim,
+ "-package=exceptions-" ++ VERSION_exceptions,
+ "-package=unliftio-core-" ++ VERSION_unliftio_core,
+ "-package=random-" ++ VERSION_random,
+ "-package=foreign-store-" ++ VERSION_foreign_store,
"-i" <> "src",
"-i" <> "src-ghc",
"src/Language/Javascript/JSaddle/Test.hs",
@@ -83,6 +90,7 @@
jsaddlePath "src/Language/Javascript/JSaddle/Arguments.hs",
jsaddlePath "src/Language/Javascript/JSaddle/Classes.hs",
jsaddlePath "src/Language/Javascript/JSaddle/Classes/Internal.hs",
+ jsaddlePath "src/Language/Javascript/JSaddle/Debug.hs",
jsaddlePath "src/Language/Javascript/JSaddle/Evaluate.hs",
jsaddlePath "src/Language/Javascript/JSaddle/Exception.hs",
jsaddlePath "src/Language/Javascript/JSaddle/Monad.hs",
@@ -96,4 +104,9 @@
jsaddlePath "src/Language/Javascript/JSaddle/String.hs",
jsaddlePath "src/Language/Javascript/JSaddle/Types.hs",
jsaddlePath "src/Language/Javascript/JSaddle/Value.hs" ]
+ putMVar done ()
+ threadDelay 5000000
+ runSession defaultConfig $ do
+ openPage "http://127.0.0.1:3709"
+ liftIO $ takeMVar done
closeSession