jsaddle-warp 0.9.5.0 → 0.9.6.0

raw patch · 4 files changed

+153/−49 lines, 4 filesdep +exceptionsdep +randomdep +unliftio-coredep ~aesondep ~containersdep ~doctestPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, random, unliftio-core

Dependency ranges changed: aeson, containers, doctest, foreign-store, http-types, stm, websockets

API changes (from Hackage documentation)

Files

• jsaddle-warp.cabal +13/−7
• src/Language/Javascript/JSaddle/WebSockets.hs +91/−35
• src/Language/Javascript/JSaddle/WebSockets/Compat.hs +29/−0
• tests/DocTest.hs +20/−7

@@ -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,

@@ -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 $ "<a href=\"http://localhost:" <> show port <> "\">run</a>" +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 $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"+ 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

@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+--+-- Module      :  Language.Javascript.JSaddle.WebSockets.Compat+-- Copyright   :  (c) Hamish Mackenzie+-- License     :  MIT+--+-- Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>+--+-- | 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

@@ -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