git.iko.soy/reflex-dom
on develop help sign in
Fix and clean up WebSockets on ghcjs
7a1a500Ryan Trinkle
src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+17−49
compare with develop
unifiedsplit
@@ -1,75 +1,43 @@
1−{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP #-}
2
2
3module Reflex.Dom.WebSocket.Foreign where
3module Reflex.Dom.WebSocket.Foreign where
4
4
5import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
5import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
6
6
7−import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
8import Data.ByteString (ByteString)
7import Data.ByteString (ByteString)
9−import Data.Text.Encoding
10import qualified Data.ByteString as BS
8import qualified Data.ByteString as BS
11−import Foreign.Ptr
12−import GHCJS.Foreign
13import GHCJS.Types
9import GHCJS.Types
14−import Data.JSString.Text
15−import GHCJS.DOM.WebSocket (WebSocket, message, closeEvent)
10+import GHCJS.DOM.WebSocket (message, closeEvent)
16import qualified GHCJS.DOM.WebSocket as GD
11import qualified GHCJS.DOM.WebSocket as GD
17import GHCJS.DOM.MessageEvent
12import GHCJS.DOM.MessageEvent
18import GHCJS.DOM.EventM (on)
13import GHCJS.DOM.EventM (on)
19import GHCJS.DOM.Types
14import GHCJS.DOM.Types
20import Control.Monad.IO.Class
15import Control.Monad.IO.Class
21import Control.Monad.Reader
16import Control.Monad.Reader
17+import GHCJS.Buffer
18+import JavaScript.TypedArray.ArrayBuffer as JS
19+import GHCJS.Marshal.Pure
22
20
23data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
21data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
24
22
25newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket
23newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket
26newWebSocket _ url onMessage onClose = do
24newWebSocket _ url onMessage onClose = do
27− ws <- GD.newWebSocket url (Nothing :: Maybe [String])
25+ ws <- GD.newWebSocket url (Just [] :: Maybe [String])
26+ GD.setBinaryType ws "arraybuffer"
28− on ws message $ do
27+ _ <- on ws message $ do
29 e <- ask
28 e <- ask
30 d <- getData e
29 d <- getData e
31− liftIO $ onMessage $ encodeUtf8 $ textFromJSVal d
30+ ab <- liftIO $ unsafeFreeze $ pFromJSVal d
31+ liftIO $ onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab
32− on ws closeEvent $ liftIO onClose
32+ _ <- on ws closeEvent $ liftIO onClose
33 return $ JSWebSocket ws
33 return $ JSWebSocket ws
34
34
35webSocketSend :: JSWebSocket -> ByteString -> IO ()
35webSocketSend :: JSWebSocket -> ByteString -> IO ()
36webSocketSend (JSWebSocket ws) bs = do
36webSocketSend (JSWebSocket ws) bs = do
37− undefined
37+ let (b, off, len) = fromByteString bs
38+ ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed
39+ then jsval . getArrayBuffer <$> create 0
40+ else return $ js_dataView off len $ jsval $ getArrayBuffer b
41+ GD.send ws $ Just ab
38
42
39−{-
43+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
40−#define JS(name, js, type) foreign import javascript unsafe js name :: type
41−
42−newtype JSWebSocket = JSWebSocket { unWebSocket :: JSRef JSWebSocket }
43−
44−data JSByteArray
45−JS(extractByteArray, "new Uint8Array($1_1.buf, $1_2, $2)", Ptr a -> Int -> IO (JSRef JSByteArray))
46−
47−JS(newWebSocket_, "(function() { var ws = new WebSocket($1); ws['binaryType'] = 'arraybuffer'; ws['onmessage'] = function(e){ $2(e['data']); }; ws['onclose'] = function(e){ $3(); }; return ws; })()", JSString -> JSFun (JSString -> IO ()) -> JSFun (IO ()) -> IO (JSRef JSWebSocket))
48−
49−JS(webSocketSend_, "$1['send'](String.fromCharCode.apply(null, $2))", JSRef JSWebSocket -> JSRef JSByteArray -> IO ())
50−
51−webSocketSend :: JSWebSocket -> ByteString -> IO ()
52−webSocketSend ws bs = BS.useAsCString bs $ \cStr -> do
53− ba <- extractByteArray cStr $ BS.length bs
54− webSocketSend_ (unWebSocket ws) ba
55−
56−JS(getLocationHost_, "location.host", IO JSString)
57−
58−getLocationHost :: FromJSString r => a -> IO r
59−getLocationHost _ = liftM fromJSString getLocationHost_
60−
61−JS(getLocationProtocol_, "location.protocol", IO JSString)
62−
63−getLocationProtocol :: FromJSString r => a -> IO r
64−getLocationProtocol _ = liftM fromJSString getLocationProtocol_
65−
66−newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket
67−newWebSocket _ url onMessage onClose = do
68− onMessageFun <- syncCallback1 AlwaysRetain True $ onMessage <=< return . encodeUtf8 . fromJSString
69− rec onCloseFun <- syncCallback AlwaysRetain True $ do
70− release onMessageFun
71− release onCloseFun
72− onClose
73− liftM JSWebSocket $ newWebSocket_ (toJSString url) onMessageFun onCloseFun
74−
75−-}