@@ -1,3 +1,6 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE OverloadedStrings #-}
14-----------------------------------------------------------------------------
25--
36-- Module : Language.Javascript.JSaddle.WebSockets
@@ -11,63 +14,127 @@
1114-----------------------------------------------------------------------------
1215
1316module Language.Javascript.JSaddle.WebSockets (
14− Command(..)
17+ jsaddleOr
18+ , run
19+ , AsyncCommand(..)
20+ , Command(..)
1521 , Result(..)
1622 , sendCommand
1723 , sendAsyncCommand
1824) where
1925
20−import Data.Text (Text)
21−import Language.Javascript.JSaddle.Types
22− (JSStringReceived(..), JSStringForSend, JSValueForSend,
23− JSValueReceived(..), JSObjectForSend, Index)
24−import Language.Javascript.JSaddle.Monad (JSM)
26+import Control.Exception (throwIO)
27+import Control.Monad (void, forever)
28+import Control.Monad.IO.Class (MonadIO(..))
29+import Control.Monad.Trans.Reader (asks)
30+import Control.Monad.STM (STM, atomically)
31+import Control.Concurrent (forkIO)
32+import Control.Concurrent.STM.TChan
33+ (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
34+import Control.Concurrent.STM.TVar
35+ (readTVarIO, modifyTVar, newTVarIO)
36+import Control.Concurrent.MVar
37+ (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
38+
39+import Data.Monoid ((<>))
40+import qualified Data.Text as T (unpack)
41+import qualified Data.Map as M (lookup, delete, insert, empty)
42+import Data.Aeson (encode, decode)
2543
26−data Command = JSStringToText JSStringForSend
27− | TextToJSString Text
28− | DeRefVal JSValueForSend
29− | ValueToBool JSValueForSend
30− | ValueToNumber JSValueForSend
31− | ValueToString JSValueForSend
32− | ValueToJSON JSValueForSend
33− | NumberToValue Double
34− | StrictEqual JSValueForSend JSValueForSend
35− | InstanceOf JSValueForSend JSObjectForSend
36− | GetPropertyByName JSObjectForSend JSStringForSend
37− | GetPropertyAtIndex JSObjectForSend Index
38− | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend
39− | SetPropertyAtIndex JSObjectForSend Index JSValueForSend
40− | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend]
41− | CallAsConstructor JSObjectForSend [JSValueForSend]
42− | NewEmptyObject
43− | NewCallback
44− | NewArray [JSValueForSend]
45− | PropertyNames JSObjectForSend
46− | EvaluateScript JSStringForSend
47−data Result = JSStringToTextResult Text
48− | TextToJSStringResult JSStringReceived
49− | DeRefValResult Int Text
50− | ValueToBoolResult Bool
51− | ValueToNumberResult Double
52− | ValueToStringResult JSStringReceived
53− | ValueToJSONResult JSStringReceived
54− | NumberToValueResult JSValueReceived
55− | StrictEqualResult Bool
56− | InstanceOfResult Bool
57− | GetPropertyByNameResult JSValueReceived
58− | GetPropertyAtIndexResult JSValueReceived
59− | CallAsFunctionResult JSValueReceived
60− | CallAsConstructorResult JSValueReceived
61− | NewEmptyObjectResult JSValueReceived
62− | NewCallbackResult JSValueReceived
63− | Callback JSValueReceived JSValueReceived [JSValueReceived]
64− | NewArrayResult JSValueReceived
65− | PropertyNamesResult [JSStringReceived]
66− | EvaluateScriptResult JSValueReceived
44+import Network.Wai (Application)
45+import Network.WebSockets
46+ (ConnectionOptions(..), sendTextData, receiveDataMessage,
47+ acceptRequest, defaultConnectionOptions, ServerApp)
48+import qualified Network.WebSockets as WS (DataMessage(..))
49+import Network.Wai.Handler.WebSockets (websocketsOr)
50+
51+import Language.Javascript.JSaddle.Types
52+ (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),
53+ Object(..), JSValueReceived(..), JSM, Batch(..))
54+import Language.Javascript.JSaddle.Exception (JSException(..))
55+import Language.Javascript.JSaddle.Monad (runJSaddle)
56+import Language.Javascript.JSaddle.Native (wrapJSVal)
57+import Language.Javascript.JSaddle.WebSockets.Files (mkEmbedded)
58+import Network.Wai.Handler.Warp
59+ (defaultSettings, setTimeout, setPort, runSettings)
60+import Network.Wai.Application.Static
61+ (ssIndices, staticApp)
62+import WaiAppStatic.Storage.Embedded (mkSettings)
63+import WaiAppStatic.Types (unsafeToPiece)
6764
6865sendCommand :: Command -> JSM Result
69−sendCommand = undefined
66+sendCommand cmd = do
67+ s <- asks doSendCommand
68+ liftIO $ s cmd
69+
70+sendAsyncCommand :: AsyncCommand -> JSM ()
71+sendAsyncCommand cmd = do
72+ s <- asks doSendAsyncCommand
73+ liftIO $ s cmd
74+
75+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application
76+jsaddleOr opts entryPoint = websocketsOr opts wsApp
77+ where
78+ wsApp :: ServerApp
79+ wsApp pending_conn = do
80+ conn <- acceptRequest pending_conn
81+ recvChan <- newTChanIO
82+ commandChan <- newTChanIO
83+ callbacks <- newTVarIO M.empty
84+ let ctx = JSContextRef {
85+ doSendCommand = \cmd -> do
86+ result <- newEmptyMVar
87+ atomically $ writeTChan commandChan (Right (cmd, result))
88+ takeMVar result >>= \case
89+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
90+ result -> return result
91+ , doSendAsyncCommand = atomically . writeTChan commandChan . Left
92+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
93+ , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
94+ }
95+ forkIO . forever $
96+ receiveDataMessage conn >>= \case
97+ (WS.Text t) ->
98+ case decode t of
99+ Nothing -> error $ "jsaddle WebSocket decode failed : " <> show t
100+ Just (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
101+ Just (Callback f this a) -> do
102+ f'@(JSVal fNumber) <- runJSaddle ctx $ wrapJSVal f
103+ this' <- runJSaddle ctx $ wrapJSVal this
104+ args <- runJSaddle ctx $ mapM wrapJSVal a
105+ (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
106+ Nothing -> liftIO $ putStrLn "Callback called after it was freed"
107+ Just cb -> void . forkIO . runJSaddle ctx $ cb f' this' args
108+ Just m -> atomically $ writeTChan recvChan m
109+ _ -> error "jsaddle WebSocket unexpected binary data"
110+ forkIO . forever $ atomically (readBatch commandChan) >>= \case
111+ (batch, Just resultMVar) -> do
112+ sendTextData conn $ encode batch
113+ atomically (readTChan recvChan) >>= putMVar resultMVar
114+ (batch, Nothing) -> do
115+ sendTextData conn $ encode batch
116+ SyncResult <- atomically $ readTChan recvChan
117+ return ()
118+
119+ runJSaddle ctx entryPoint
120+
121+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (Batch, Maybe (MVar Result))
122+ readBatch chan = do
123+ first <- readTChan chan -- We want at least one command to send
124+ loop first []
125+ where
126+ loop (Right (cmd, resultMVar)) asyncCmds =
127+ return (Batch (reverse asyncCmds) cmd, Just resultMVar)
128+ loop (Left asyncCmd) asyncCmds' = do
129+ let asyncCmds = asyncCmd:asyncCmds'
130+ tryReadTChan chan >>= \case
131+ Nothing -> return (Batch (reverse asyncCmds) Sync, Nothing)
132+ Just cmd -> loop cmd asyncCmds
70133
71−sendAsyncCommand :: Command -> JSM ()
72−sendAsyncCommand = undefined
134+jsaddleApp :: Application
135+jsaddleApp = staticApp ($(mkSettings mkEmbedded)) {ssIndices = [unsafeToPiece "index.html"]}
73136
137+run :: Int -> JSM () -> IO ()
138+run port f =
139+ runSettings (setPort port (setTimeout 3600 defaultSettings)) $
140+ jsaddleOr defaultConnectionOptions f jsaddleApp