6a1c2cf · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge branch 'newxmlhttprequest_async_handle_errors' of github.com:fpco/reflex-dom into ghcjs-improved-base-2

6a1c2cfAli Abrar11 years ago

default.nix+2−2

compare with develop

unifiedsplit

@@ -2,7 +2,7 @@

2, mtl, ref-tf, reflex, safe, text, these

3, transformers, data-default, semigroups, aeson

4, ghc, webkitgtk3-javascriptcore, exception-transformers

5−, dependent-sum-template, bifunctors

5+, dependent-sum-template, bifunctors, raw-strings-qq

6}:

8mkDerivation {

@@ -26,6 +26,6 @@ mkDerivation {

26 exception-transformers

27 dependent-sum-template

28 bifunctors

29− ] ++ (if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk3-javascriptcore ]);

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

30 license = null;

31}

reflex-dom.cabal+4−1

@@ -16,6 +16,7 @@ extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs

16 src-ghcjs/Reflex/Dom/Internal/Foreign.hs

17 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs

18 src/Reflex/Dom/Xhr/ResponseType.hs

19+ src/Reflex/Dom/Xhr/Exception.hs

20library

21library

21 hs-source-dirs: src

22 hs-source-dirs: src

@@ -53,7 +54,8 @@ library

53 glib == 0.13.*,

54 glib == 0.13.*,

54 gtk3 >= 0.13.0 && < 0.15,

55 gtk3 >= 0.13.0 && < 0.15,

55 webkitgtk3 == 0.14.*,

56 webkitgtk3 == 0.14.*,

56− webkitgtk3-javascriptcore == 0.13.*

57+ webkitgtk3-javascriptcore == 0.13.*,

58+ raw-strings-qq

57 if !os(windows)

59 if !os(windows)

58 build-depends: unix == 2.7.*

60 build-depends: unix == 2.7.*

@@ -75,6 +77,7 @@ library

75 Reflex.Dom.WebSocket.Foreign

77 Reflex.Dom.WebSocket.Foreign

76 Reflex.Dom.Xhr.Foreign

78 Reflex.Dom.Xhr.Foreign

77 Reflex.Dom.Xhr.ResponseType

79 Reflex.Dom.Xhr.ResponseType

80+ Reflex.Dom.Xhr.Exception

79 other-extensions: TemplateHaskell

82 other-extensions: TemplateHaskell

80 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

83 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

src-ghc/Reflex/Dom/Xhr/Foreign.hs+55−13

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

1−{-# LANGUAGE ForeignFunctionInterface #-}

1+{-# LANGUAGE QuasiQuotes, ForeignFunctionInterface #-}

2module Reflex.Dom.Xhr.Foreign where

4import qualified Data.Text as T

@@ -11,9 +11,14 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

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

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

13import Reflex.Dom.Xhr.ResponseType

14+import Reflex.Dom.Xhr.Exception

15+import Control.Concurrent.MVar

16+import Control.Exception.Base

15import Reflex.Dom.Internal.Foreign

18import Reflex.Dom.Internal.Foreign

20+import Text.RawString.QQ

21+

17data XMLHttpRequest

22data XMLHttpRequest

18 = XMLHttpRequest { xhrValue :: JSValueRef

23 = XMLHttpRequest { xhrValue :: JSValueRef

19 , xhrContext :: JSContextRef

24 , xhrContext :: JSContextRef

@@ -110,18 +115,55 @@ xmlHttpRequestGetResponseText xhr = do

110xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO ()

115xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO ()

111xmlHttpRequestSend xhr payload = do

116xmlHttpRequestSend xhr payload = do

112 let c = xhrContext xhr

117 let c = xhrContext xhr

118+ result <- newEmptyMVar

119+ let wrapper' x = wrapper $ \_ _ _ _ _ _ -> putMVar result x >> jsvaluemakeundefined c

120+ bracket (wrapper' $ Just XhrException_Aborted) freeHaskellFunPtr $ \a -> do

121+ onAbort <- jsobjectmakefunctionwithcallback c nullPtr a

122+ bracket (wrapper' $ Just XhrException_Error) freeHaskellFunPtr $ \e -> do

123+ onError <- jsobjectmakefunctionwithcallback c nullPtr e

124+ bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do

125+ onLoad <- jsobjectmakefunctionwithcallback c nullPtr l

113− (o,s) <- case payload of

126+ (o,s) <- case payload of

114− Nothing -> do

127+ Nothing -> do

128+ d <- jsvaluemakeundefined c

115− o <- toJSObject c [xhrValue xhr]

129+ o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]

116− s <- jsstringcreatewithutf8cstring "this[0].send();"

130+ s <- jsstringcreatewithutf8cstring send

117− return (o,s)

131+ return (o,s)

118− Just payload' -> do

132+ Just payload' -> do

119− d <- stringToJSValue c payload'

133+ d <- stringToJSValue c payload'

120− o <- toJSObject c [xhrValue xhr, d]

134+ o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]

121− s <- jsstringcreatewithutf8cstring "this[0].send(this[1])"

135+ s <- jsstringcreatewithutf8cstring send

122− return (o,s)

136+ return (o,s)

123− _ <- jsevaluatescript c s o nullPtr 1 nullPtr

137+ _ <- jsevaluatescript c s o nullPtr 1 nullPtr

124− return ()

138+ takeMVar result >>= mapM_ throwIO

139+ where

140+ send = [r|

141+ (function (xhr, d, onError, onAbort, onLoad) {

142+ var clear;

143+ var error = function () {

144+ clear(); onError();

145+ };

146+ var abort = function () {

147+ clear(); onAbort();

148+ };

149+ var load = function () {

150+ clear(); onLoad();

151+ };

152+ clear = function () {

153+ xhr.removeEventListener('error', error);

154+ xhr.removeEventListener('abort', abort);

155+ xhr.removeEventListener('load', load);

156+ }

157+ xhr.addEventListener('error', error);

158+ xhr.addEventListener('abort', abort);

159+ xhr.addEventListener('load', load);

160+ if(d) {

161+ xhr.send(d);

162+ } else {

163+ xhr.send();

164+ }

165+ })(this[0], this[1], this[2], this[3], this[4])

166+ |]

125

167

126xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO ()

168xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO ()

127xmlHttpRequestSetRequestHeader xhr header value = do

169xmlHttpRequestSetRequestHeader xhr header value = do

src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+9−1

@@ -15,8 +15,11 @@ import GHCJS.DOM.XMLHttpRequest

15import Data.Maybe (fromMaybe)

16import GHCJS.DOM.EventTarget (dispatchEvent)

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

18+import GHCJS.DOM.JSFFI.XMLHttpRequest (XHRError(..))

18import GHCJS.Types

19import GHCJS.Types

20+import Reflex.Dom.Xhr.Exception

19import Reflex.Dom.Xhr.ResponseType

21import Reflex.Dom.Xhr.ResponseType

22+import Control.Exception (catch, throwIO)

21data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSVal }

24data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSVal }

@@ -31,9 +34,14 @@ xmlHttpRequestOpen ::

31 XMLHttpRequest -> method -> url -> Bool -> user -> password -> IO ()

34 XMLHttpRequest -> method -> url -> Bool -> user -> password -> IO ()

32xmlHttpRequestOpen = open

35xmlHttpRequestOpen = open

37+convertException :: XHRError -> XhrException

38+convertException e = case e of

39+ XHRError -> XhrException_Error

40+ XHRAborted -> XhrException_Aborted

41+

34-- This used to be a non blocking call, but now it uses an interruptible ffi

42-- This used to be a non blocking call, but now it uses an interruptible ffi

35xmlHttpRequestSend :: ToJSString payload => XMLHttpRequest -> Maybe payload -> IO ()

43xmlHttpRequestSend :: ToJSString payload => XMLHttpRequest -> Maybe payload -> IO ()

36−xmlHttpRequestSend self = maybe (send self) (sendString self)

44+xmlHttpRequestSend self p = (maybe (send self) (sendString self) p) `catch` (throwIO . convertException)

38xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value)

46xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value)

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

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

src/Reflex/Dom/Xhr.hs+55−17

@@ -5,6 +5,7 @@ module Reflex.Dom.Xhr

5 , XMLHttpRequest

6 , XhrResponseBody(..)

7 , XhrResponseType(..)

8+ , XhrException(..)

8 , responseTextToText

9 , responseTextToText

9 , xmlHttpRequestGetReadyState

10 , xmlHttpRequestGetReadyState

10 , xmlHttpRequestGetResponseText

11 , xmlHttpRequestGetResponseText

@@ -20,6 +21,7 @@ module Reflex.Dom.Xhr

20where

21where

22import Control.Concurrent

23import Control.Concurrent

24+import Control.Exception (catch)

23import Control.Lens

25import Control.Lens

24import Control.Monad hiding (forM)

26import Control.Monad hiding (forM)

25import Control.Monad.IO.Class

27import Control.Monad.IO.Class

@@ -37,9 +39,11 @@ import Data.Text.Encoding

37import Data.Traversable

39import Data.Traversable

38import Reflex

40import Reflex

39import Reflex.Dom.Class

41import Reflex.Dom.Class

42+import Reflex.Dom.Xhr.Exception

40import Reflex.Dom.Xhr.Foreign

43import Reflex.Dom.Xhr.Foreign

41import Reflex.Dom.Xhr.ResponseType

44import Reflex.Dom.Xhr.ResponseType

42import Data.Typeable

45import Data.Typeable

46+-- import GHCJS.DOM.JSFFI.XMLHttpRequest (XHRError(..))

44data XhrRequest

48data XhrRequest

45 = XhrRequest { _xhrRequest_method :: String

49 = XhrRequest { _xhrRequest_method :: String

@@ -85,12 +89,24 @@ instance Default XhrRequestConfig where

85xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest

89xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest

86xhrRequest = XhrRequest

90xhrRequest = XhrRequest

92+-- | Make a new asyncronous XHR request. This does not block (it forks),

93+-- and returns an XHR object immediately (which you can use to abort

94+-- the XHR connection), and will pass an exception ('XhrException') to the

95+-- continuation if the connection cannot be made (or is aborted).

96+newXMLHttpRequest

88−newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest

97+ :: (HasWebView m, MonadIO m, HasPostGui t h m)

98+ => XhrRequest

99+ -- ^ The request to make.

100+ -> (Either XhrException XhrResponse -> h ())

101+ -- ^ A continuation to be called once a response comes back, or in

102+ -- case of error.

103+ -> m XMLHttpRequest

104+ -- ^ The XHR request, which could for example be aborted.

89newXMLHttpRequest req cb = do

105newXMLHttpRequest req cb = do

90 wv <- askWebView

106 wv <- askWebView

91 postGui <- askPostGui

107 postGui <- askPostGui

92− liftIO $ do

93− xhr <- xmlHttpRequestNew wv

108+ xhr <- liftIO $ xmlHttpRequestNew wv

109+ void $ liftIO $ forkIO $ flip catch (postGui . cb . Left) $ void $ do

94 let c = _xhrRequest_config req

110 let c = _xhrRequest_config req

95 rt = _xhrRequestConfig_responseType c

111 rt = _xhrRequestConfig_responseType c

96 xmlHttpRequestOpen

112 xmlHttpRequestOpen

@@ -112,24 +128,42 @@ newXMLHttpRequest req cb = do

112 then liftIO $ xmlHttpRequestGetResponseText xhr

128 then liftIO $ xmlHttpRequestGetResponseText xhr

113 else return Nothing

129 else return Nothing

114 r <- liftIO $ xmlHttpRequestGetResponse xhr

130 r <- liftIO $ xmlHttpRequestGetResponse xhr

131+ _ <- liftIO $ postGui $ cb $ Right $

115− _ <- liftIO $ postGui $ cb $ XhrResponse { _xhrResponse_status = status

132+ XhrResponse { _xhrResponse_status = status

116− , _xhrResponse_statusText = statusTextToText statusText

133+ , _xhrResponse_statusText = statusTextToText statusText

117− , _xhrResponse_response = r

134+ , _xhrResponse_response = r

118− , _xhrResponse_responseText = responseTextToText t

135+ , _xhrResponse_responseText = responseTextToText t

119− }

136+ }

120 return ()

137 return ()

121 else return ()

138 else return ()

122 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

139 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

123− return xhr

140+ return ()

124−

141+ return xhr

142+

125−-- | Given Event of requests, issue them when the Event fires. Returns Event of corresponding responses.

143+-- | Given Event of requests, issue them when the Event fires.

144+-- Returns Event of corresponding responses.

145+--

146+-- The request is processed asynchronously, therefore handling does

147+-- not block or cause a delay while creating the connection.

148+performRequestAsync

149+ :: (MonadWidget t m)

126−performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)

150+ => Event t XhrRequest -> m (Event t (Either XhrException XhrResponse))

127performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do

151performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do

128 _ <- newXMLHttpRequest r $ liftIO . cb

152 _ <- newXMLHttpRequest r $ liftIO . cb

129 return ()

153 return ()

130

154

131−-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.

155+-- | Issues a collection of requests when the supplied Event fires.

156+-- When ALL requests from a given firing complete, the results are

157+-- collected and returned via the return Event.

158+--

159+-- The requests are processed asynchronously, therefore handling does

160+-- not block or cause a delay while creating the connection.

161+--

162+-- Order of request execution and completion is not guaranteed, but

163+-- order of creation and the collection result is preserved.

164+performRequestsAsync

165+ :: (Traversable f, MonadWidget t m)

132−performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))

166+ => Event t (f XhrRequest) -> m (Event t (f (Either XhrException XhrResponse)))

133performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do

167performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do

134 resps <- forM rs $ \r -> do

168 resps <- forM rs $ \r -> do

135 resp <- liftIO newEmptyMVar

169 resp <- liftIO newEmptyMVar

@@ -142,11 +176,16 @@ performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do

142getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))

176getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))

143getAndDecode url = do

177getAndDecode url = do

144 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url

178 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url

179+ return $

180+ fmap (\r ->

181+ case r of

182+ Left{} -> Nothing

145− return $ fmap decodeXhrResponse r

183+ Right xhr -> decodeXhrResponse xhr)

184+ r

146

185

147-- | Create a "POST" request from an URL and thing with a JSON representation

186-- | Create a "POST" request from an URL and thing with a JSON representation

148postJson :: (ToJSON a) => String -> a -> XhrRequest

187postJson :: (ToJSON a) => String -> a -> XhrRequest

149−postJson url a =

188+postJson url a =

150 XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc

189 XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc

151 , _xhrRequestConfig_sendData = Just body

190 , _xhrRequestConfig_sendData = Just body

152 }

191 }

@@ -164,4 +203,3 @@ decodeText = decode . BL.fromStrict . encodeUtf8

164-- | Convenience function to decode JSON-encoded responses.

203-- | Convenience function to decode JSON-encoded responses.

165decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

204decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

166decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

205decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

167−

src/Reflex/Dom/Xhr/Exception.hsnew file+12

@@ -0,0 +1,12 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

3+module Reflex.Dom.Xhr.Exception where

5+import Data.Typeable

6+import Control.Exception (Exception(..))

8+data XhrException = XhrException_Error

9+ | XhrException_Aborted

10+ deriving (Show, Read, Eq, Ord, Typeable)

11+

12+instance Exception XhrException