module Haste.WebSockets (
module Haste.Concurrent,
WebSocket,
withWebSocket, withBinaryWebSocket, wsSend, wsSendBlob
) where
import Haste
import Haste.Foreign
import Haste.Concurrent
import Haste.Binary (Blob)
newtype WebSocket = WebSocket JSAny deriving (ToAny, FromAny)
withWebSocket :: URL
-> (WebSocket -> JSString -> CIO ())
-> CIO a
-> (WebSocket -> CIO a)
-> CIO a
withWebSocket url cb err f = do
result <- newEmptyMVar
let f' = \ws -> concurrent $ f ws >>= putMVar result
liftIO $ new url cb' f' $ concurrent $ err >>= putMVar result
takeMVar result
where
cb' = \ws msg -> concurrent $ cb ws msg
withBinaryWebSocket :: URL
-> (WebSocket -> Blob -> CIO ())
-> CIO a
-> (WebSocket -> CIO a)
-> CIO a
withBinaryWebSocket url cb err f = do
result <- newEmptyMVar
let f' = \ws -> concurrent $ f ws >>= putMVar result
liftIO $ newBin url cb' f' $ concurrent $ err >>= putMVar result
takeMVar result
where
cb' = \ws msg -> concurrent $ cb ws msg
new :: URL
-> (WebSocket -> JSString -> IO ())
-> (WebSocket -> IO ())
-> IO ()
-> IO ()
new = ffi "(function(url, cb, f, err) {\
\var ws = new WebSocket(url);\
\ws.onmessage = function(e) {cb(ws,e.data);};\
\ws.onopen = function(e) {f(ws);};\
\ws.onerror = function(e) {err());};\
\return ws;\
\})"
newBin :: URL
-> (WebSocket -> Blob -> IO ())
-> (WebSocket -> IO ())
-> IO ()
-> IO ()
newBin = ffi "(function(url, cb, f, err) {\
\var ws = new WebSocket(url);\
\ws.binaryType = 'blob';\
\ws.onmessage = function(e) {cb(ws,e.data);};\
\ws.onopen = function(e) {f(ws);};\
\ws.onerror = function(e) {err();};\
\return ws;\
\})"
wsSend :: WebSocket -> JSString -> CIO ()
wsSend ws str = liftIO $ sendS ws str
wsSendBlob :: WebSocket -> Blob -> CIO ()
wsSendBlob ws b = liftIO $ sendB ws b
sendS :: WebSocket -> JSString -> IO ()
sendS = ffi "(function(s, msg) {s.send(msg);})"
sendB :: WebSocket -> Blob -> IO ()
sendB = ffi "(function(s, msg) {s.send(msg);})"