@@ -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 #-}
22
33module Reflex.Dom.WebSocket.Foreign where
44
55import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
66
7−import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
87import Data.ByteString (ByteString)
9−import Data.Text.Encoding
108import qualified Data.ByteString as BS
11−import Foreign.Ptr
12−import GHCJS.Foreign
139import GHCJS.Types
14−import Data.JSString.Text
15−import GHCJS.DOM.WebSocket (WebSocket, message, closeEvent)
10+import GHCJS.DOM.WebSocket (message, closeEvent)
1611import qualified GHCJS.DOM.WebSocket as GD
1712import GHCJS.DOM.MessageEvent
1813import GHCJS.DOM.EventM (on)
1914import GHCJS.DOM.Types
2015import Control.Monad.IO.Class
2116import Control.Monad.Reader
17+import GHCJS.Buffer
18+import JavaScript.TypedArray.ArrayBuffer as JS
19+import GHCJS.Marshal.Pure
2220
2321data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
2422
2523newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket
2624newWebSocket _ url onMessage onClose = do
27− ws <- GD.newWebSocket url (Nothing :: Maybe [String])
28− on ws message $ do
25+ ws <- GD.newWebSocket url (Just [] :: Maybe [String])
26+ GD.setBinaryType ws "arraybuffer"
27+ _ <- on ws message $ do
2928 e <- ask
3029 d <- getData e
31− liftIO $ onMessage $ encodeUtf8 $ textFromJSVal d
32− on ws closeEvent $ liftIO onClose
30+ ab <- liftIO $ unsafeFreeze $ pFromJSVal d
31+ liftIO $ onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab
32+ _ <- on ws closeEvent $ liftIO onClose
3333 return $ JSWebSocket ws
3434
3535webSocketSend :: JSWebSocket -> ByteString -> IO ()
3636webSocketSend (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
3842
39−{-
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−-}
43+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal