git.iko.soy/reflex-dom
on develop help sign in
Provide instance XhrPayload ByteString, factor out ByteString ArrayBuffer conversions
commit1d879316e78a3394f7a42dba3d5b6a3178cdfa2c authorMaciej Kazulak <kazulakm@gmail.com> dateThu 13 Apr 2017, 15:54 (10 years ago) parentec0ca04
3 files changed+58−34
compare with develop
unifiedsplit
reflex-dom-core/src/Foreign/JavaScript/Utils.hs+42 reflex-dom-core/src/Reflex/Dom/WebSocket/Foreign.hs+4−22 reflex-dom-core/src/Reflex/Dom/Xhr/Foreign.hs+12−12
reflex-dom-core/src/Foreign/JavaScript/Utils.hsnew file+42
@@ -0,0 +1,42 @@
1+{-# LANGUAGE CPP #-}
2+#ifdef __GHCJS__
3+{-# LANGUAGE ForeignFunctionInterface #-}
4+{-# LANGUAGE JavaScriptFFI #-}
5+#endif
6+
7+module Foreign.JavaScript.Utils
8+ ( bsFromMutableArrayBuffer
9+ , bsToArrayBuffer
10+ ) where
11+
12+import Data.ByteString (ByteString)
13+import qualified Data.ByteString as BS
14+import qualified GHCJS.Buffer as JS
15+import GHCJS.DOM.Types (ArrayBuffer (..))
16+import qualified JavaScript.TypedArray.ArrayBuffer as JS
17+import Language.Javascript.JSaddle.Types (JSVal, JSM, MonadJSM, liftJSM, ghcjsPure, jsval)
18+#ifndef __GHCJS__
19+import Language.Javascript.JSaddle.Object (new, jsg)
20+#endif
21+
22+{-# INLINABLE bsFromMutableArrayBuffer #-}
23+bsFromMutableArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString
24+bsFromMutableArrayBuffer ab = liftJSM $ JS.unsafeFreeze ab >>=
25+ ghcjsPure . JS.createFromArrayBuffer >>= ghcjsPure . JS.toByteString 0 Nothing
26+
27+{-# INLINABLE bsToArrayBuffer #-}
28+bsToArrayBuffer :: MonadJSM m => ByteString -> m ArrayBuffer
29+bsToArrayBuffer bs = liftJSM $ do
30+ (b, off, len) <- ghcjsPure $ JS.fromByteString bs
31+ ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed
32+ then JS.create 0 >>= ghcjsPure . JS.getArrayBuffer >>= ghcjsPure . jsval
33+ else do
34+ ref <- ghcjsPure (JS.getArrayBuffer b) >>= ghcjsPure . jsval
35+ js_dataView off len ref
36+
37+#ifdef __GHCJS__
38+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> IO JSVal
39+#else
40+js_dataView :: Int -> Int -> JSVal -> JSM JSVal
41+js_dataView off len ref = new (jsg "DataView") (ref, off, len)
42+#endif
reflex-dom-core/src/Reflex/Dom/WebSocket/Foreign.hs+4−22
@@ -14,24 +14,18 @@ import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)
1414
1515import Control.Monad.Reader
1616import Data.ByteString (ByteString)
17−import qualified Data.ByteString as BS
1817import Data.Text (Text)
1918import qualified Data.Text as T (unpack)
2019import Data.Text.Encoding
21−import GHCJS.Buffer
20+import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)
2221import GHCJS.DOM.CloseEvent
2322import GHCJS.DOM.EventM (on)
2423import GHCJS.DOM.MessageEvent
2524import GHCJS.DOM.Types hiding (Text)
2625import qualified GHCJS.DOM.WebSocket as GD
2726import GHCJS.Foreign (JSType(..), jsTypeOf)
28−import GHCJS.Types
29−import JavaScript.TypedArray.ArrayBuffer as JS
3027import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)
3128import Language.Javascript.JSaddle.Types (ghcjsPure)
32−#ifndef ghcjs_HOST_OS
33−import Language.Javascript.JSaddle.Object (new, jsg)
34−#endif
3529
3630data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
3731
@@ -42,12 +36,7 @@ class IsWebSocketMessage a where
4236-- Note: Binary websockets may not work correctly in IE 11 and below
4337instance IsWebSocketMessage ByteString where
4438 webSocketSend (JSWebSocket ws) bs = do
45− (b, off, len) <- ghcjsPure $ fromByteString bs
46− ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed
47− then create 0 >>= ghcjsPure . getArrayBuffer >>= ghcjsPure . jsval
48− else do
49− ref <- ghcjsPure (getArrayBuffer b) >>= ghcjsPure . jsval
50− js_dataView off len ref -- new (jsg "DataView") (ref, off, len)
39+ ab <- bsToArrayBuffer bs
5140 GD.send ws $ Just ab
5241
5342-- Use plaintext websocket communication for Text, and String
@@ -82,16 +71,9 @@ newWebSocket _ url onMessage onOpen onError onClose = do
8271 liftJSM $ ghcjsPure (jsTypeOf d) >>= \case
8372 String -> onMessage $ Right d
8473 _ -> do
85− ab <- mutableArrayBufferFromJSVal d >>= unsafeFreeze
86− ghcjsPure (createFromArrayBuffer ab) >>= ghcjsPure . toByteString 0 Nothing >>= onMessage . Left
74+ ab <- mutableArrayBufferFromJSVal d
75+ bsFromMutableArrayBuffer ab >>= onMessage . Left
8776 return $ JSWebSocket ws
8877
89−#ifdef ghcjs_HOST_OS
90−foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> IO JSVal
91−#else
92−js_dataView :: Int -> Int -> JSVal -> JSM JSVal
93−js_dataView off len ref = new (jsg "DataView") (ref, off, len)
94−#endif
95−
9678onBSMessage :: Either ByteString JSVal -> JSM ByteString
9779onBSMessage = either return (\v -> encodeUtf8 <$> fromJSValUnchecked v)
reflex-dom-core/src/Reflex/Dom/Xhr/Foreign.hs+12−12
@@ -15,21 +15,17 @@ import Control.Monad.IO.Class (MonadIO(..))
1515import Data.Maybe (fromMaybe)
1616import Data.Text (Text)
1717import Data.ByteString (ByteString)
18+import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)
1819import GHCJS.DOM.Enums
1920import GHCJS.DOM.EventM (EventM, on)
2021import GHCJS.DOM.EventTarget (dispatchEvent)
2122import GHCJS.DOM.Types hiding (Text)
2223import GHCJS.DOM.XMLHttpRequest
23−-- import GHCJS.Types
24+import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)
25+import qualified Language.Javascript.JSaddle.Monad as JS (catch)
2426import Prelude hiding (error)
2527import Reflex.Dom.Xhr.Exception
2628import Reflex.Dom.Xhr.ResponseType
27−import Language.Javascript.JSaddle.Types (ghcjsPure)
28−import qualified Language.Javascript.JSaddle.Monad as JS (catch)
29−import qualified GHCJS.Buffer as JS
30− (createFromArrayBuffer, toByteString)
31−import qualified JavaScript.TypedArray.ArrayBuffer as JS
32− (unsafeFreeze, MutableArrayBuffer)
3329
3430xmlHttpRequestNew :: MonadJSM m => m XMLHttpRequest
3531xmlHttpRequestNew = newXMLHttpRequest
@@ -65,6 +61,12 @@ instance IsXhrPayload Document where
6561instance IsXhrPayload Blob where
6662 sendXhrPayload = sendBlob
6763
64+instance IsXhrPayload ArrayBuffer where
65+ sendXhrPayload xhr ab = sendArrayBuffer xhr (ArrayBufferView $ unArrayBuffer ab)
66+
67+instance IsXhrPayload ByteString where
68+ sendXhrPayload xhr bs = sendXhrPayload xhr =<< liftJSM (bsToArrayBuffer bs)
69+
6870newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }
6971
7072-- This used to be a non blocking call, but now it uses an interruptible ffi
@@ -178,9 +180,7 @@ xmlHttpRequestGetResponse xhr = do
178180 Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr
179181 Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of
180182 Nothing -> return Nothing
181− Just ptr -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer (pFromJSVal ptr)
183+ Just ptr -> do
184+ ab <- liftJSM $ mutableArrayBufferFromJSVal ptr
185+ Just . XhrResponseBody_ArrayBuffer <$> bsFromMutableArrayBuffer ab
182186 _ -> return Nothing
183−
184−bsFromArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString
185−bsFromArrayBuffer ab = liftJSM $ JS.unsafeFreeze ab >>=
186− ghcjsPure . JS.createFromArrayBuffer >>= ghcjsPure . JS.toByteString 0 Nothing