6979655 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge branch 'xhr-response-types' into fix-dyn-pattern-match

6979655Ali Abrar11 years ago

default.nix+1−1

compare with develop

unifiedsplit

@@ -30,6 +30,6 @@ mkDerivation {

30 zenc

31 random

32 ] ++ (if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk3-javascriptcore raw-strings-qq ]);

33− pkgconfigDepends = if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk24x ];

33+ pkgconfigDepends = if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk24x webkitgtk3-javascriptcore raw-strings-qq ];

34 license = null;

35}

reflex-dom.cabal+1−1

@@ -39,7 +39,7 @@ library

39 text == 1.2.*,

40 bytestring == 0.10.*,

41 data-default == 0.5.*,

42− aeson >= 0.8 && < 0.10,

42+ aeson >= 0.8 && < 0.11,

43 time == 1.4.* || == 1.5.*,

44 exception-transformers == 0.4.*,

45 directory == 1.2.*,

src-ghc/Reflex/Dom/Internal/Foreign.hs+38−9

@@ -1,11 +1,16 @@

1{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables, LambdaCase #-}

2module Reflex.Dom.Internal.Foreign where

4−import Control.Lens hiding (set)

5−import GHCJS.DOM hiding (runWebGUI)

6import Control.Concurrent

4import Control.Concurrent

5+import Control.Exception (bracket)

6+import Control.Lens hiding (set)

7+import Control.Monad

7import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)

8import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)

9+import Data.ByteString (ByteString)

10+import Data.List

11+import Foreign.Marshal hiding (void)

8import Foreign.Ptr

12import Foreign.Ptr

13+import GHCJS.DOM hiding (runWebGUI)

9import GHCJS.DOM.Navigator

14import GHCJS.DOM.Navigator

10import GHCJS.DOM.Window

15import GHCJS.DOM.Window

11import Graphics.UI.Gtk hiding (Widget)

16import Graphics.UI.Gtk hiding (Widget)

@@ -14,14 +19,14 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

14import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

19import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

15import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

20import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

16import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

21import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

17−import Graphics.UI.Gtk.WebKit.WebView

18import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget)

22import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget)

19−import Graphics.UI.Gtk.WebKit.WebSettings

20import Graphics.UI.Gtk.WebKit.WebFrame

23import Graphics.UI.Gtk.WebKit.WebFrame

21import Graphics.UI.Gtk.WebKit.WebInspector

24import Graphics.UI.Gtk.WebKit.WebInspector

22−import Data.List

25+import Graphics.UI.Gtk.WebKit.WebSettings

26+import Graphics.UI.Gtk.WebKit.WebView

23import System.Directory

27import System.Directory

24import System.Glib.FFI hiding (void)

28import System.Glib.FFI hiding (void)

29+import qualified Data.ByteString as BS

26#ifndef mingw32_HOST_OS

31#ifndef mingw32_HOST_OS

27import System.Posix.Signals

32import System.Posix.Signals

@@ -117,18 +122,42 @@ fromJSStringMaybe c t = do

117 return $ Just s

122 return $ Just s

118

123

119getLocationHost :: WebView -> IO String

124getLocationHost :: WebView -> IO String

120−getLocationHost wv = do

125+getLocationHost wv = withWebViewContext wv $ \c -> do

121− c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

122 script <- jsstringcreatewithutf8cstring "location.host"

126 script <- jsstringcreatewithutf8cstring "location.host"

123 lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

127 lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

124 lh' <- fromJSStringMaybe c lh

128 lh' <- fromJSStringMaybe c lh

125 return $ maybe "" id lh'

129 return $ maybe "" id lh'

126

130

127getLocationProtocol :: WebView -> IO String

131getLocationProtocol :: WebView -> IO String

128−getLocationProtocol wv = do

132+getLocationProtocol wv = withWebViewContext wv $ \c -> do

129− c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

130 script <- jsstringcreatewithutf8cstring "location.protocol"

133 script <- jsstringcreatewithutf8cstring "location.protocol"

131 lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

134 lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

132 lp' <- fromJSStringMaybe c lp

135 lp' <- fromJSStringMaybe c lp

133 return $ maybe "" id lp'

136 return $ maybe "" id lp'

134

137

138+bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef

139+bsToArrayBuffer c bs = do

140+ elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x

141+ let numElems = length elems

142+ bracket (mallocArray numElems) free $ \elemsArr -> do

143+ pokeArray elemsArr elems

144+ a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr

145+ newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"

146+ jsevaluatescript c newUint8Array a nullPtr 1 nullPtr

147+

148+bsFromArrayBuffer :: JSContextRef -> JSValueRef -> IO ByteString

149+bsFromArrayBuffer c a = do

150+ let getIntegral = fmap round . (\x -> jsvaluetonumber c x nullPtr)

151+ getByteLength <- jsstringcreatewithutf8cstring "this.byteLength"

152+ byteLength <- getIntegral =<< jsevaluatescript c getByteLength a nullPtr 1 nullPtr

153+ toUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"

154+ uint8Array <- jsevaluatescript c toUint8Array a nullPtr 1 nullPtr

155+ getIx <- jsstringcreatewithutf8cstring "this[0][this[1]]"

156+ let arrayLookup i = do

157+ i' <- jsvaluemakenumber c (fromIntegral i)

158+ args <- toJSObject c [uint8Array, i']

159+ getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr

160+ fmap BS.pack $ forM [0..byteLength-1] arrayLookup

161+

162+withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a

163+withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv

src-ghc/Reflex/Dom/WebSocket/Foreign.hs+1−3

@@ -15,7 +15,6 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

15import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

16import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

17import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

18−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

19import Graphics.UI.Gtk.WebKit.WebView

18import Graphics.UI.Gtk.WebKit.WebView

20import qualified Data.ByteString as BS

19import qualified Data.ByteString as BS

21import qualified Data.Text as T

20import qualified Data.Text as T

@@ -27,8 +26,7 @@ data JSWebSocket = JSWebSocket { wsValue :: JSValueRef

27 }

26 }

29newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

28newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

30−newWebSocket wv url onMessage onOpen onClose = do

29+newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

31− c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

32 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url

30 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url

33 newWSArgs <- toJSObject c [url']

31 newWSArgs <- toJSObject c [url']

34 newWS <- jsstringcreatewithutf8cstring "(function(that) { var ws = new WebSocket(that[0]); ws['binaryType'] = 'arraybuffer'; return ws; })(this)"

32 newWS <- jsstringcreatewithutf8cstring "(function(that) { var ws = new WebSocket(that[0]); ws['binaryType'] = 'arraybuffer'; return ws; })(this)"

src-ghc/Reflex/Dom/Xhr/Foreign.hs+41−34

@@ -3,6 +3,7 @@ module Reflex.Dom.Xhr.Foreign ( module Reflex.Dom.Xhr.Foreign

3 , XhrResponseType

4 ) where

6+import Control.Monad

6import qualified Data.Text as T

7import qualified Data.Text as T

7import Data.Text (Text)

8import Data.Text (Text)

8import System.Glib.FFI

9import System.Glib.FFI

@@ -17,6 +18,7 @@ import Reflex.Dom.Xhr.ResponseType

17import Reflex.Dom.Xhr.Exception

18import Reflex.Dom.Xhr.Exception

18import Control.Concurrent.MVar

19import Control.Concurrent.MVar

19import Control.Exception.Base

20import Control.Exception.Base

21+import Graphics.UI.Gtk.WebKit.Types hiding (Text)

21import Reflex.Dom.Internal.Foreign

23import Reflex.Dom.Internal.Foreign

@@ -28,23 +30,36 @@ data XMLHttpRequest

28 }

30 }

29 deriving (Eq, Ord)

31 deriving (Eq, Ord)

31−data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSValueRef }

33+class IsXhrPayload a where

34+ xmlHttpRequestSend :: XMLHttpRequest -> a -> IO ()

35+

36+instance IsXhrPayload () where

37+ xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr Nothing

38+

39+instance IsXhrPayload String where

40+ xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just

41+

42+instance IsXhrPayload File where

43+ xmlHttpRequestSend = error "xmlHttpRequestSend{File}: not implemented"

33stringToJSValue :: JSContextRef -> String -> IO JSValueRef

45stringToJSValue :: JSContextRef -> String -> IO JSValueRef

34stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

46stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

36−toResponseType :: XhrResponseType -> String

48+fromResponseType :: XhrResponseType -> String

37−toResponseType XhrResponseType_Default = ""

49+fromResponseType XhrResponseType_Default = ""

38−toResponseType XhrResponseType_ArrayBuffer = "arraybuffer"

50+fromResponseType XhrResponseType_ArrayBuffer = "arraybuffer"

39−toResponseType XhrResponseType_Blob = "blob"

51+fromResponseType XhrResponseType_Blob = "blob"

40−toResponseType XhrResponseType_Document = "document"

52+fromResponseType XhrResponseType_Text = "text"

41−toResponseType XhrResponseType_JSON = "json"

53+

42−toResponseType XhrResponseType_Text = "text"

54+toResponseType :: String -> Maybe XhrResponseType

55+toResponseType "" = Just XhrResponseType_Default

56+toResponseType "arraybuffer" = Just XhrResponseType_ArrayBuffer

57+toResponseType "blob" = Just XhrResponseType_Blob

58+toResponseType "text" = Just XhrResponseType_Text

59+toResponseType _ = Nothing

44xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

61xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

45−xmlHttpRequestNew wv = do

62+xmlHttpRequestNew wv = withWebViewContext wv $ \jsContext -> do

46− wf <- webViewGetMainFrame wv

47− jsContext <- webFrameGetGlobalContext wf

48 xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"

63 xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"

49 xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr

64 xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr

50 jsvalueprotect jsContext xhr'

65 jsvalueprotect jsContext xhr'

@@ -83,43 +98,35 @@ xmlHttpRequestGetReadyState xhr = do

83 d <- jsvaluetonumber c rs nullPtr

98 d <- jsvaluetonumber c rs nullPtr

84 return $ truncate d

99 return $ truncate d

100

101+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)

102+xmlHttpRequestGetResponseType xhr = do

103+ script <- jsstringcreatewithutf8cstring "this.responseType"

104+ rt <- jsevaluatescript (xhrContext xhr) script (xhrValue xhr) nullPtr 1 nullPtr

105+ ms <- fromJSStringMaybe (xhrContext xhr) rt

106+ return $ join $ fmap toResponseType ms

107+

86xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)

108xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)

87xmlHttpRequestGetResponse xhr = do

109xmlHttpRequestGetResponse xhr = do

88 let c = xhrContext xhr

110 let c = xhrContext xhr

111+ mrt <- xmlHttpRequestGetResponseType xhr

89 script <- jsstringcreatewithutf8cstring "this.response"

112 script <- jsstringcreatewithutf8cstring "this.response"

90 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

113 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

91 isNull <- jsvalueisnull c t

114 isNull <- jsvalueisnull c t

92 case isNull of

115 case isNull of

93 True -> return Nothing

116 True -> return Nothing

94− False -> return $ Just $ XhrResponseBody t

117+ False -> case mrt of

118+ Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t

119+ Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t

120+ Just XhrResponseType_Default -> fmap (XhrResponseBody_Default . T.pack) <$> fromJSStringMaybe c t

121+ Just XhrResponseType_Text -> fmap (XhrResponseBody_Text . T.pack) <$> fromJSStringMaybe c t

122+ _ -> return Nothing

123

96xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)

124xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)

97xmlHttpRequestGetResponseText xhr = do

125xmlHttpRequestGetResponseText xhr = do

98 let c = xhrContext xhr

126 let c = xhrContext xhr

99 script <- jsstringcreatewithutf8cstring "this.responseText"

127 script <- jsstringcreatewithutf8cstring "this.responseText"

100 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

128 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

101− isNull <- jsvalueisnull c t

129+ fmap (fmap T.pack) $ fromJSStringMaybe c t

102− case isNull of

103− True -> return Nothing

104− False -> do

105− j <- jsvaluetostringcopy c t nullPtr

106− l <- jsstringgetmaximumutf8cstringsize j

107− s <- allocaBytes (fromIntegral l) $ \ps -> do

108− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

109− peekCString ps

110− return $ Just $ T.pack s

111−

112−class IsXhrPayload a where

113− xmlHttpRequestSend :: XMLHttpRequest -> a -> IO ()

114−

115−instance IsXhrPayload () where

116− xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr Nothing

117−

118−instance IsXhrPayload String where

119− xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just

120−

121−instance IsXhrPayload File where

122− xmlHttpRequestSend = error "xmlHttpRequestSend{File}: not implemented"

123

130

124xmlHttpRequestSendPayload :: XMLHttpRequest -> Maybe String -> IO ()

131xmlHttpRequestSendPayload :: XMLHttpRequest -> Maybe String -> IO ()

125xmlHttpRequestSendPayload xhr payload = do

132xmlHttpRequestSendPayload xhr payload = do

src-ghcjs/Reflex/Dom/Internal/Foreign.hs+21

@@ -4,9 +4,16 @@ module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign

4 ) where

6import Control.Monad

7+import Data.ByteString (ByteString)

8+import Foreign

9+import Foreign.C

7import GHCJS.DOM

10import GHCJS.DOM

8import GHCJS.DOM.Types

11import GHCJS.DOM.Types

9import GHCJS.Types

12import GHCJS.Types

13+import JavaScript.TypedArray.ArrayBuffer as JS

14+import qualified Data.ByteString as BS

15+import qualified GHCJS.Buffer as JS

16+import qualified GHCJS.Marshal.Pure as JS

11quitWebView :: WebView -> IO ()

18quitWebView :: WebView -> IO ()

12quitWebView = error "quitWebView: unimplemented in GHCJS"

19quitWebView = error "quitWebView: unimplemented in GHCJS"

@@ -20,3 +27,17 @@ foreign import javascript unsafe "location['protocol']" getLocationProtocol_ ::

21getLocationProtocol :: FromJSString r => a -> IO r

28getLocationProtocol :: FromJSString r => a -> IO r

22getLocationProtocol _ = liftM fromJSString getLocationProtocol_

29getLocationProtocol _ = liftM fromJSString getLocationProtocol_

30+

31+withWebViewContext :: a -> (a -> IO b) -> IO b

32+withWebViewContext a f = f a

33+

34+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal

35+

36+foreign import javascript unsafe "new Uint8Array($1_1['buf'], $1_2, $2)['buffer']" extractByteArray :: Ptr CChar -> Int -> IO JSVal

37+

38+bsToArrayBuffer :: a -> ByteString -> IO JSVal

39+bsToArrayBuffer _ bs = BS.useAsCString bs $ \cStr -> do

40+ extractByteArray cStr $ BS.length bs

41+

42+bsFromArrayBuffer :: a -> JSVal -> IO ByteString

43+bsFromArrayBuffer _ ab = liftM (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JS.unsafeFreeze $ JS.pFromJSVal ab

src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+2−5

@@ -30,11 +30,8 @@ newWebSocket _ url onMessage onOpen onClose = do

30 _ <- on ws message $ do

31 e <- ask

32 d <- getData e

33− liftIO $ case jsTypeOf d of

34− String -> onMessage $ encodeUtf8 $ pFromJSVal d

35− _ -> do

36− ab <- unsafeFreeze $ pFromJSVal d

33+ ab <- liftIO $ unsafeFreeze $ pFromJSVal d

37− onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab

34+ liftIO $ onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab

38 _ <- on ws closeEvent $ liftIO onClose

35 _ <- on ws closeEvent $ liftIO onClose

39 return $ JSWebSocket ws

36 return $ JSWebSocket ws

src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+28−15

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, OverloadedStrings, FlexibleInstances #-}

1+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, ForeignFunctionInterface, JavaScriptFFI, OverloadedStrings #-}

3module Reflex.Dom.Xhr.Foreign (

4 XMLHttpRequest

@@ -9,18 +9,17 @@ module Reflex.Dom.Xhr.Foreign (

9import Prelude hiding (error)

10import Data.Text (Text)

11import GHCJS.DOM.Types hiding (Text)

12−import GHCJS.DOM.EventM

13import GHCJS.DOM

12import GHCJS.DOM

14import GHCJS.DOM.Enums

13import GHCJS.DOM.Enums

15import GHCJS.DOM.XMLHttpRequest

14import GHCJS.DOM.XMLHttpRequest

16import Data.Maybe (fromMaybe)

15import Data.Maybe (fromMaybe)

17import GHCJS.DOM.EventTarget (dispatchEvent)

16import GHCJS.DOM.EventTarget (dispatchEvent)

18−import GHCJS.Types

17+import GHCJS.DOM.EventM (EventM, on)

18+import Reflex.Dom.Internal.Foreign

19import Reflex.Dom.Xhr.Exception

20import Reflex.Dom.Xhr.ResponseType

21import Control.Exception (catch, throwIO)

22−

22+import GHCJS.Types

23−data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSVal }

25prepareWebView :: WebView -> IO ()

24prepareWebView :: WebView -> IO ()

26prepareWebView _ = return ()

25prepareWebView _ = return ()

@@ -62,6 +61,7 @@ newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }

62xmlHttpRequestSend :: IsXhrPayload payload => XMLHttpRequest -> payload -> IO ()

61xmlHttpRequestSend :: IsXhrPayload payload => XMLHttpRequest -> payload -> IO ()

63xmlHttpRequestSend self p = sendXhrPayload self p `catch` (throwIO . convertException)

62xmlHttpRequestSend self p = sendXhrPayload self p `catch` (throwIO . convertException)

64+

65xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value)

66 => XMLHttpRequest -> header -> value -> IO ()

67xmlHttpRequestSetRequestHeader = setRequestHeader

@@ -133,16 +133,21 @@ xmlHttpRequestGetResponseXML = getResponseXML

133xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO ()

134xmlHttpRequestSetResponseType = setResponseType

135

136−toResponseType :: XhrResponseType -> XMLHttpRequestResponseType

136+fromResponseType :: XhrResponseType -> XMLHttpRequestResponseType

137−toResponseType XhrResponseType_Default = XMLHttpRequestResponseType

137+fromResponseType XhrResponseType_Default = XMLHttpRequestResponseType

138−toResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer

138+fromResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer

139−toResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob

139+fromResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob

140−toResponseType XhrResponseType_Document = XMLHttpRequestResponseTypeDocument

140+fromResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText

141−toResponseType XhrResponseType_JSON = XMLHttpRequestResponseTypeJson

141+

142+toResponseType :: XMLHttpRequestResponseType -> Maybe XhrResponseType

143+toResponseType XMLHttpRequestResponseType = Just XhrResponseType_Default

144+toResponseType XMLHttpRequestResponseTypeArraybuffer = Just XhrResponseType_ArrayBuffer

145+toResponseType XMLHttpRequestResponseTypeBlob = Just XhrResponseType_Blob

142−toResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText

146+toResponseType XMLHttpRequestResponseTypeText = Just XhrResponseType_Text

147+toResponseType _ = Nothing

143

148

144−xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO XMLHttpRequestResponseType

149+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)

145−xmlHttpRequestGetResponseType = getResponseType

150+xmlHttpRequestGetResponseType = fmap toResponseType . getResponseType

146

151

147xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word

152xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word

148xmlHttpRequestGetStatus = getStatus

153xmlHttpRequestGetStatus = getStatus

@@ -156,5 +161,13 @@ xmlHttpRequestGetResponseURL = getResponseURL

156xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)

161xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)

157xmlHttpRequestGetResponse xhr = do

162xmlHttpRequestGetResponse xhr = do

158 mr <- getResponse xhr

163 mr <- getResponse xhr

159− return $ fmap (\(GObject r) -> XhrResponseBody r) mr

164+ rt <- xmlHttpRequestGetResponseType xhr

165+ case rt of

166+ Just XhrResponseType_Blob -> return $ fmap (XhrResponseBody_Blob . castToBlob) mr

167+ Just XhrResponseType_Text -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr

168+ Just XhrResponseType_Default -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr

169+ Just XhrResponseType_ArrayBuffer -> case (fmap unGObject mr) of

170+ Nothing -> return Nothing

171+ Just ptr -> fmap (Just . XhrResponseBody_ArrayBuffer) $ bsFromArrayBuffer ptr ptr

172+ _ -> return Nothing

160

173

src/Reflex/Dom/Widget/Basic.hs+7−1

@@ -167,8 +167,14 @@ widgetHoldInternal child0 newChild = do

167 forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder)

168 return ()

169 addVoidAction $ ffor newChild $ \c -> do

170+ Just df <- createDocumentFragment doc

171+ (result, postBuild, voidActions) <- runWidget df c

172+ runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)

173+ postBuild

170 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder

174 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder

171− build c

175+ mp' <- getParentNode endPlaceholder

176+ forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder)

177+ return ()

172 return (result0, fmap fst newChildBuilt)

178 return (result0, fmap fst newChildBuilt)

173

179

174diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)

180diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)

src/Reflex/Dom/Xhr.hs+6−1

@@ -17,6 +17,8 @@ module Reflex.Dom.Xhr

17 , performRequestAsyncWithError

18 , performRequestsAsync

19 , performMkRequestsAsync

20+ , performRequestAsyncWithError

21+ , performRequestsAsync

20 , performRequestsAsyncWithError

22 , performRequestsAsyncWithError

21 , getAndDecode

23 , getAndDecode

22 , postJson

24 , postJson

@@ -69,7 +71,10 @@ import Data.Maybe

69import Data.Text (Text)

71import Data.Text (Text)

70import Data.Text.Encoding

72import Data.Text.Encoding

71import Data.Traversable

73import Data.Traversable

74+import Reflex

75+import Reflex.Dom.Class

72import Reflex.Dom.Xhr.Exception

76import Reflex.Dom.Xhr.Exception

77+import Reflex.Dom.Xhr.Foreign

73import Reflex.Dom.Xhr.ResponseType

78import Reflex.Dom.Xhr.ResponseType

74import Data.Typeable

79import Data.Typeable

@@ -145,7 +150,7 @@ newXMLHttpRequestWithError req cb = do

145 (fromMaybe "" $ _xhrRequestConfig_user c)

150 (fromMaybe "" $ _xhrRequestConfig_user c)

146 (fromMaybe "" $ _xhrRequestConfig_password c)

151 (fromMaybe "" $ _xhrRequestConfig_password c)

147 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

152 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

148− maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) rt

153+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . fromResponseType) rt

149 _ <- xmlHttpRequestOnreadystatechange xhr $ do

154 _ <- xmlHttpRequestOnreadystatechange xhr $ do

150 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

155 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

151 status <- liftIO $ xmlHttpRequestGetStatus xhr

156 status <- liftIO $ xmlHttpRequestGetStatus xhr

src/Reflex/Dom/Xhr/ResponseType.hs+9−2

@@ -3,12 +3,19 @@

3module Reflex.Dom.Xhr.ResponseType where

5import Data.Typeable

6+import Data.Text (Text)

7+import GHCJS.DOM.Blob (Blob)

8+import Data.ByteString (ByteString)

7data XhrResponseType = XhrResponseType_Default

10data XhrResponseType = XhrResponseType_Default

8 | XhrResponseType_ArrayBuffer

11 | XhrResponseType_ArrayBuffer

9 | XhrResponseType_Blob

12 | XhrResponseType_Blob

10− | XhrResponseType_Document

11− | XhrResponseType_JSON

12 | XhrResponseType_Text

13 | XhrResponseType_Text

13 deriving (Show, Read, Eq, Ord, Typeable)

14 deriving (Show, Read, Eq, Ord, Typeable)

16+data XhrResponseBody = XhrResponseBody_Default Text

17+ | XhrResponseBody_Text Text

18+ | XhrResponseBody_Blob Blob

19+ | XhrResponseBody_ArrayBuffer ByteString

20+ deriving (Eq)

21+