jsaddle-warp 0.9.0.0 → 0.9.1.0

raw patch · 3 files changed

+129/−49 lines, 3 filesdep +uuiddep +uuid-typesdep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: uuid, uuid-types

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• jsaddle-warp.cabal +4/−1
• src/Language/Javascript/JSaddle/Warp.hs +3/−4
• src/Language/Javascript/JSaddle/WebSockets.hs +122/−44

@@ -1,5 +1,5 @@ name: jsaddle-warp-version: 0.9.0.0+version: 0.9.1.0 cabal-version: >=1.10 build-type: Simple license: MIT@@ -26,6 +26,7 @@             Language.Javascript.JSaddle.WebSockets         build-depends:             aeson >=0.8.0.2 && <1.3,+            bytestring >=0.10.6.0 && <0.11,             containers >=0.5.6.2 && <0.6,             http-types >=0.8.6 && <0.10,             jsaddle >=0.9.0.0 && <0.10,@@ -33,6 +34,8 @@             text >=1.2.1.3 && <1.3,             time >=1.5.0.1 && <1.8,             transformers >=0.4.2.0 && <0.6,+            uuid >=1.3.13 && <1.4,+            uuid-types >=1.0.3 && <1.1,             wai >=3.0.3.0 && <3.3,             wai-websockets >=3.0.0.6 && <3.1,             warp >=3.1.2 && <3.3,

@@ -17,8 +17,7 @@   -- * Running JSM over WebSockets     run #ifndef ghcjs_HOST_OS-  , jsaddleOr-  , jsaddleApp+  , module Language.Javascript.JSaddle.WebSockets #endif ) where @@ -29,7 +28,7 @@  import Language.Javascript.JSaddle.Types (JSM) import Language.Javascript.JSaddle.Run (syncPoint)-import Language.Javascript.JSaddle.WebSockets (jsaddleOr, jsaddleApp)+import Language.Javascript.JSaddle.WebSockets #endif  -- | Run the given 'JSM' action as the main entry point.  Either directly@@ -40,6 +39,6 @@ #else run :: Int -> JSM () -> IO () run port f =-    runSettings (setPort port (setTimeout 3600 defaultSettings)) $+    runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<         jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp #endif

@@ -16,6 +16,8 @@   -- * Running JSM over WebSockets     jsaddleOr   , jsaddleApp+  , jsaddleWithAppOr+  , jsaddleAppPartial ) where  import Control.Monad (forever)@@ -25,7 +27,8 @@ import Data.Monoid ((<>)) import Data.Aeson (encode, decode) -import Network.Wai (Application)+import Network.Wai+       (lazyRequestBody, Application, Request, Response, ResponseReceived) import Network.WebSockets        (ConnectionOptions(..), sendTextData, receiveDataMessage,         acceptRequest, ServerApp, sendPing)@@ -34,55 +37,130 @@  import Language.Javascript.JSaddle.Types (JSM(..)) import qualified Network.Wai as W-       (responseLBS, requestMethod, Application, pathInfo)-import Data.Text (Text)+       (responseLBS, requestMethod, pathInfo) import qualified Data.Text as T (pack) import qualified Network.HTTP.Types as H-       (status403, status200, status405)+       (status403, status200) import Language.Javascript.JSaddle.Run (runJavaScript)-import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)+import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)+import Data.Maybe (fromMaybe)+import qualified Data.Map as M (empty, insert, lookup)+import Data.IORef (readIORef, newIORef, atomicModifyIORef')+import Data.ByteString.Lazy (fromStrict, ByteString)+import Data.Text (Text)+import Data.UUID.Types (toText)+import Data.UUID.V4 (nextRandom) -jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application-jsaddleOr opts entryPoint = websocketsOr opts wsApp-  where-    wsApp :: ServerApp-    wsApp pending_conn = do-        conn <- acceptRequest pending_conn-        (processResult, _, start) <- runJavaScript (sendTextData conn . encode) 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+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application+jsaddleOr opts entryPoint otherApp = do+    syncHandlers <- newIORef M.empty+    let wsApp :: ServerApp+        wsApp pending_conn = do+            conn <- acceptRequest pending_conn+            (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) 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"+            syncKey <- toText <$> nextRandom+            atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))+            sendTextData conn (encode syncKey)+            start+            waitTillClosed conn -    -- Based on Network.WebSocket.forkPingThread-    waitTillClosed conn = ignore `handle` go 1-      where-        go :: Int -> IO ()-        go i = do-            threadDelay (1 * 1000 * 1000)-            sendPing conn (T.pack $ show i)-            go (i + 1)+        -- Based on Network.WebSocket.forkPingThread+        waitTillClosed conn = ignore `handle` go 1+          where+            go :: Int -> IO ()+            go i = do+                threadDelay (1 * 1000 * 1000)+                sendPing conn (T.pack $ show i)+                go (i + 1) -    ignore e = case fromException e of-        Just async -> throwIO (async :: AsyncException)-        Nothing    -> return ()+        ignore e = case fromException e of+            Just async -> throwIO (async :: AsyncException)+            Nothing    -> return () +        syncHandler :: Application+        syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of+            ("POST", ["sync", syncKey]) -> do+                body <- lazyRequestBody req+                case decode body of+                    Nothing -> error $ "jsaddle sync message decode failed : " <> show body+                    Just result ->+                        M.lookup syncKey <$> readIORef syncHandlers >>= \case+                            Nothing -> error "jsaddle missing sync message handler"+                            Just handler -> do+                                next <- encode <$> handler result+                                sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next+            _ -> otherApp req sendResponse+    return $ websocketsOr opts wsApp syncHandler++ jsaddleApp :: Application-jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req+jsaddleApp req sendResponse =+    fromMaybe+        (sendResponse $  W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")+        (jsaddleAppPartial req sendResponse) -jsaddleAppPieces :: [Text] -> W.Application-jsaddleAppPieces _ req sendResponse-    | W.requestMethod req `notElem` ["GET", "HEAD"] = sendResponse $ W.responseLBS-        H.status405-        [("Content-Type", "text/plain")]-        "Only GET or HEAD is supported"-jsaddleAppPieces [] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml-jsaddleAppPieces ["jsaddle.js"] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs-jsaddleAppPieces _rawPieces _req sendResponse = sendResponse $ W.responseLBS H.status403-            [ ("Content-Type", "text/plain")-            ] "Forbidden"+jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application+jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->+  (fromMaybe (otherApp req sendResponse)+     (jsaddleAppPartial req sendResponse))++jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)+jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of+    ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml+    ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] 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 :: ByteString+jsaddleJs = "\+    \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\+    \\n\+    \    var ws = new WebSocket(wsaddress);\n\+    \    var syncKey = \"\";\n\+    \\n\+    \    ws.onopen = function(e) {\n\+    \ " <> initState <> "\n\+    \        var inXhrSend = false;\n\+    \\n\+    \        ws.onmessage = function(e) {\n\+    \            if(inXhrSend) return;\n\+    \            var batch = JSON.parse(e.data);\n\+    \            if(typeof batch === \"string\") {\n\+    \                syncKey = batch;\n\+    \                return;\n\+    \            }\n\+    \\n\+    \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")+              (Just (\a -> "(function(){\n\+                  \                       inXhrSend = true;\n\+                  \                       var xhr = new XMLHttpRequest();\n\+                  \                       xhr.open('POST', '/sync/'+syncKey, false);\n\+                  \                       xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\+                  \                       xhr.send(JSON.stringify(" <> a <> "));\n\+                  \                       inXhrSend = false;\n\+                  \                       return JSON.parse(xhr.response);})()")) <> "\+    \        };\n\+    \    };\n\+    \    ws.onerror = function() {\n\+    \        setTimeout(connect, 1000);\n\+    \    };\n\+    \}\n\+    \\n\+    \ " <> ghcjsHelpers <> "\+    \connect();\n\+    \"+