@@ -3,7 +3,7 @@
33{-# LANGUAGE OverloadedStrings #-}
44-----------------------------------------------------------------------------
55--
6−-- Module : Language.Javascript.JSaddle.WebSockets
6+-- Module : Language.Javascript.JSaddle.Run
77-- Copyright : (c) Hamish Mackenzie
88-- License : MIT
99--
@@ -13,16 +13,15 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−module Language.Javascript.JSaddle.WebSockets (
17− -- * Running JSM over WebSockets
18− run
16+module Language.Javascript.JSaddle.Run (
17+ -- * Running JSM
18+ runJavaScript
1919 , syncPoint
2020 , syncAfter
2121 , waitForAnimationFrame
2222 , nextAnimationFrame
2323#ifndef ghcjs_HOST_OS
24− , jsaddleOr
25− -- * Functions used to implement JSaddle over WebSockets
24+ -- * Functions used to implement JSaddle using JSON messaging
2625 , AsyncCommand(..)
2726 , Command(..)
2827 , Result(..)
@@ -53,40 +52,13 @@ import Control.Concurrent.MVar
5352import Data.Monoid ((<>))
5453import qualified Data.Text as T (unpack)
5554import qualified Data.Map as M (lookup, delete, insert, empty)
56−import Data.Aeson (encode, decode)
5755import Data.Time.Clock (getCurrentTime,diffUTCTime)
5856
59−import Network.Wai (Application)
60−import Network.Wai.Handler.Warp
61− (defaultSettings, setTimeout, setPort, runSettings)
62−import Network.WebSockets
63− (ConnectionOptions(..), sendTextData, receiveDataMessage,
64− acceptRequest, defaultConnectionOptions, ServerApp)
65−import qualified Network.WebSockets as WS (DataMessage(..))
66−import Network.Wai.Handler.WebSockets (websocketsOr)
67−
6857import Language.Javascript.JSaddle.Types
6958 (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),
7059 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
7160import Language.Javascript.JSaddle.Exception (JSException(..))
7261import Language.Javascript.JSaddle.Native (wrapJSVal)
73−import Language.Javascript.JSaddle.WebSockets.Files (indexHtml, jsaddleJs)
74−import qualified Network.Wai as W
75− (responseLBS, requestMethod, Application, pathInfo)
76−import Data.Text (Text)
77−import qualified Network.HTTP.Types as H
78− (status403, status200, status405)
79−#endif
80−
81−-- | Run the given 'JSM' action as the main entry point. Either directly
82−-- in GHCJS or as a Warp server on the given port on GHC.
83−run :: Int -> JSM () -> IO ()
84−#ifdef ghcjs_HOST_OS
85−run _port = id
86−#else
87−run port f =
88− runSettings (setPort port (setTimeout 3600 defaultSettings)) $
89− jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp
9062#endif
9163
9264-- | Forces execution of pending asyncronous code
@@ -154,58 +126,49 @@ sendAsyncCommand cmd = do
154126 s <- doSendAsyncCommand <$> JSM ask
155127 liftIO $ s cmd
156128
157−jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application
158−jsaddleOr opts entryPoint = websocketsOr opts wsApp
129+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Result -> IO (), IO ())
130+runJavaScript sendBatch entryPoint = do
131+ startTime' <- getCurrentTime
132+ recvChan <- newTChanIO
133+ commandChan <- newTChanIO
134+ callbacks <- newTVarIO M.empty
135+ nextRef' <- newTVarIO 0
136+ let ctx = JSContextRef {
137+ startTime = startTime'
138+ , doSendCommand = \cmd -> do
139+ result <- newEmptyMVar
140+ atomically $ writeTChan commandChan (Right (cmd, result))
141+ takeMVar result >>= \case
142+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
143+ r -> return r
144+ , doSendAsyncCommand = atomically . writeTChan commandChan . Left
145+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
146+ , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
147+ , nextRef = nextRef'
148+ }
149+ let processResult = \case
150+ (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
151+ (Callback f this a) -> do
152+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
153+ this' <- runReaderT (unJSM $ wrapJSVal this) ctx
154+ args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
155+ (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
156+ Nothing -> liftIO $ putStrLn "Callback called after it was freed"
157+ Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
158+ m -> atomically $ writeTChan recvChan m
159+ _ <- forkIO . forever $ readBatch commandChan >>= \case
160+ (batch, Just resultMVar) -> do
161+ sendBatch batch
162+ atomically (readTChan recvChan) >>= putMVar resultMVar
163+ (batch, Nothing) -> do
164+ sendBatch batch
165+ atomically (readTChan recvChan) >>= \case
166+ SyncResult -> return ()
167+ ThrowJSValue e -> atomically (discardToSyncPoint commandChan) >>= (`putMVar` ThrowJSValue e)
168+ _ -> error "Unexpected result processing batch"
169+ return ()
170+ return (processResult, runReaderT (unJSM entryPoint) ctx)
159171 where
160− wsApp :: ServerApp
161− wsApp pending_conn = do
162− startTime <- getCurrentTime
163− conn <- acceptRequest pending_conn
164− recvChan <- newTChanIO
165− commandChan <- newTChanIO
166− callbacks <- newTVarIO M.empty
167− nextRef <- newTVarIO 0
168− let ctx = JSContextRef {
169− startTime = startTime
170− , doSendCommand = \cmd -> do
171− result <- newEmptyMVar
172− atomically $ writeTChan commandChan (Right (cmd, result))
173− takeMVar result >>= \case
174− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
175− result -> return result
176− , doSendAsyncCommand = atomically . writeTChan commandChan . Left
177− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
178− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
179− , nextRef = nextRef
180− }
181− forkIO . forever $
182− receiveDataMessage conn >>= \case
183− (WS.Text t) ->
184− case decode t of
185− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show t
186− Just (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
187− Just (Callback f this a) -> do
188− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
189− this' <- runReaderT (unJSM $ wrapJSVal this) ctx
190− args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
191− (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
192− Nothing -> liftIO $ putStrLn "Callback called after it was freed"
193− Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
194− Just m -> atomically $ writeTChan recvChan m
195− _ -> error "jsaddle WebSocket unexpected binary data"
196− forkIO . forever $ readBatch commandChan >>= \case
197− (batch, Just resultMVar) -> do
198− sendTextData conn $ encode batch
199− atomically (readTChan recvChan) >>= putMVar resultMVar
200− (batch, Nothing) -> do
201− sendTextData conn $ encode batch
202− atomically (readTChan recvChan) >>= \case
203− SyncResult -> return ()
204− ThrowJSValue e -> atomically (discardToSyncPoint commandChan) >>= (`putMVar` ThrowJSValue e)
205− _ -> error "Unexpected result processing batch"
206− return ()
207− runReaderT (unJSM entryPoint) ctx
208−
209172 readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, Maybe (MVar Result))
210173 readBatch chan = do
211174 first <- atomically $ readTChan chan -- We want at least one command to send
@@ -230,19 +193,4 @@ jsaddleOr opts entryPoint = websocketsOr opts wsApp
230193 readTChan chan >>= \case
231194 Right (_, resultMVar) -> return resultMVar
232195 _ -> discardToSyncPoint chan
233−
234−jsaddleApp :: Application
235−jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req
236−
237−jsaddleAppPieces :: [Text] -> W.Application
238−jsaddleAppPieces _ req sendResponse
239− | notElem (W.requestMethod req) ["GET", "HEAD"] = sendResponse $ W.responseLBS
240− H.status405
241− [("Content-Type", "text/plain")]
242− "Only GET or HEAD is supported"
243−jsaddleAppPieces [] req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] indexHtml
244−jsaddleAppPieces ["jsaddle.js"] req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] jsaddleJs
245−jsaddleAppPieces rawPieces req sendResponse = sendResponse $ W.responseLBS H.status403
246− [ ("Content-Type", "text/plain")
247− ] "Forbidden"
248196#endif