5a6ad1a · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Add *WithError versions of XHR functions

5a6ad1aAli Abrar11 years ago

src-ghc/Reflex/Dom/Xhr/Foreign.hs+4−10

compare with develop

unifiedsplit

@@ -27,12 +27,6 @@ data XMLHttpRequest

28data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSValueRef }

30−responseTextToText :: Maybe String -> Maybe Text

31−responseTextToText = fmap T.pack

32−

33−statusTextToText :: String -> Text

34−statusTextToText = T.pack

35−

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

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

37stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

31stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

@@ -96,7 +90,7 @@ xmlHttpRequestGetResponse xhr = do

96 True -> return Nothing

90 True -> return Nothing

97 False -> return $ Just $ XhrResponseBody t

91 False -> return $ Just $ XhrResponseBody t

99−xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)

93+xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)

100xmlHttpRequestGetResponseText xhr = do

94xmlHttpRequestGetResponseText xhr = do

101 let c = xhrContext xhr

95 let c = xhrContext xhr

102 script <- jsstringcreatewithutf8cstring "this.responseText"

96 script <- jsstringcreatewithutf8cstring "this.responseText"

@@ -110,7 +104,7 @@ xmlHttpRequestGetResponseText xhr = do

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

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

111 _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

105 _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

112 peekCString ps

106 peekCString ps

113− return $ Just s

107+ return $ Just $ T.pack s

114

108

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

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

116xmlHttpRequestSend xhr payload = do

110xmlHttpRequestSend xhr payload = do

@@ -192,7 +186,7 @@ xmlHttpRequestGetStatus xhr = do

192 d <- jsvaluetonumber c s nullPtr

186 d <- jsvaluetonumber c s nullPtr

193 return $ truncate d

187 return $ truncate d

194

188

195−xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO String

189+xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text

196xmlHttpRequestGetStatusText xhr = do

190xmlHttpRequestGetStatusText xhr = do

197 let c = xhrContext xhr

191 let c = xhrContext xhr

198 script <- jsstringcreatewithutf8cstring "this.statusText"

192 script <- jsstringcreatewithutf8cstring "this.statusText"

@@ -202,4 +196,4 @@ xmlHttpRequestGetStatusText xhr = do

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

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

203 _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

197 _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

204 peekCString ps

198 peekCString ps

205− return s

199+ return $ T.pack s

src-ghcjs/Reflex/Dom/Xhr/Foreign.hs−5

@@ -108,9 +108,6 @@ xmlHttpRequestGetUpload = getUpload

108xmlHttpRequestGetResponseText :: FromJSString result => XMLHttpRequest -> IO (Maybe result)

109xmlHttpRequestGetResponseText = getResponseText

110

111−responseTextToText :: Maybe Text -> Maybe Text

112−responseTextToText = id

113−

114xmlHttpRequestGetResponseXML :: XMLHttpRequest -> IO (Maybe Document)

111xmlHttpRequestGetResponseXML :: XMLHttpRequest -> IO (Maybe Document)

115xmlHttpRequestGetResponseXML = getResponseXML

112xmlHttpRequestGetResponseXML = getResponseXML

116

113

@@ -142,5 +139,3 @@ xmlHttpRequestGetResponse xhr = do

142 mr <- getResponse xhr

139 mr <- getResponse xhr

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

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

144

141

145−statusTextToText :: Text -> Text

146−statusTextToText = id

src/Reflex/Dom/Xhr.hs+48−25

@@ -1,12 +1,27 @@

1{-# LANGUAGE DeriveDataTypeable #-}

3module Reflex.Dom.Xhr

4− ( module Reflex.Dom.Xhr

5− , XMLHttpRequest

4+ ( XMLHttpRequest

5+ , XhrRequest(..)

6+ , XhrRequestConfig(..)

7+ , XhrResponse(..)

6 , XhrResponseBody(..)

8 , XhrResponseBody(..)

7 , XhrResponseType(..)

9 , XhrResponseType(..)

8 , XhrException(..)

10 , XhrException(..)

9− , responseTextToText

11+ , _xhrResponse_body

12+ , xhrResponse_body

13+ , xhrRequest

14+ , newXMLHttpRequest

15+ , newXMLHttpRequestWithError

16+ , performRequestAsync

17+ , performRequestAsyncWithError

18+ , performRequestsAsync

19+ , performRequestsAsyncWithError

20+ , getAndDecode

21+ , postJson

22+ , getMay

23+ , decodeText

24+ , decodeXhrResponse

10 , xmlHttpRequestGetReadyState

25 , xmlHttpRequestGetReadyState

11 , xmlHttpRequestGetResponseText

26 , xmlHttpRequestGetResponseText

12 , xmlHttpRequestGetStatus

27 , xmlHttpRequestGetStatus

@@ -43,7 +58,6 @@ import Reflex.Dom.Xhr.Exception

43import Reflex.Dom.Xhr.Foreign

58import Reflex.Dom.Xhr.Foreign

44import Reflex.Dom.Xhr.ResponseType

59import Reflex.Dom.Xhr.ResponseType

45import Data.Typeable

60import Data.Typeable

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

48data XhrRequest

62data XhrRequest

49 = XhrRequest { _xhrRequest_method :: String

63 = XhrRequest { _xhrRequest_method :: String

@@ -93,7 +107,7 @@ xhrRequest = XhrRequest

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

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

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

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

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

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

96−newXMLHttpRequest

110+newXMLHttpRequestWithError

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

111 :: (HasWebView m, MonadIO m, HasPostGui t h m)

98 => XhrRequest

112 => XhrRequest

99 -- ^ The request to make.

113 -- ^ The request to make.

@@ -102,7 +116,7 @@ newXMLHttpRequest

102 -- case of error.

116 -- case of error.

103 -> m XMLHttpRequest

117 -> m XMLHttpRequest

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

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

105−newXMLHttpRequest req cb = do

119+newXMLHttpRequestWithError req cb = do

106 wv <- askWebView

120 wv <- askWebView

107 postGui <- askPostGui

121 postGui <- askPostGui

108 xhr <- liftIO $ xmlHttpRequestNew wv

122 xhr <- liftIO $ xmlHttpRequestNew wv

@@ -129,28 +143,35 @@ newXMLHttpRequest req cb = do

129 else return Nothing

143 else return Nothing

130 r <- liftIO $ xmlHttpRequestGetResponse xhr

144 r <- liftIO $ xmlHttpRequestGetResponse xhr

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

145 _ <- liftIO $ postGui $ cb $ Right $

132− XhrResponse { _xhrResponse_status = status

146+ XhrResponse { _xhrResponse_status = status

133− , _xhrResponse_statusText = statusTextToText statusText

147+ , _xhrResponse_statusText = statusText

134− , _xhrResponse_response = r

148+ , _xhrResponse_response = r

135− , _xhrResponse_responseText = responseTextToText t

149+ , _xhrResponse_responseText = t

136− }

150+ }

137 return ()

151 return ()

138 else return ()

152 else return ()

139 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

153 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

140 return ()

154 return ()

141 return xhr

155 return xhr

142

156

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

158+newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb

159+

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

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

144-- Returns Event of corresponding responses.

161-- Returns Event of corresponding responses.

145--

162--

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

163-- The request is processed asynchronously, therefore handling does

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

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

148−performRequestAsync

165+performRequestAsyncWithError

149− :: (MonadWidget t m)

166+ :: MonadWidget t m

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

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

168+performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError

169+

170+performRequestAsync :: MonadWidget t m => Event t XhrRequest -> m (Event t XhrResponse)

171+performRequestAsync = performRequestAsync' newXMLHttpRequest

172+

173+performRequestAsync' :: (MonadWidget t m, MonadIO h) => (XhrRequest -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t XhrRequest -> m (Event t a)

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

174+performRequestAsync' newXhr req = performEventAsync $ ffor req $ \r cb -> void $ newXhr r $ liftIO . cb

152− _ <- newXMLHttpRequest r $ liftIO . cb

153− return ()

154

175

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

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

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

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

@@ -161,13 +182,20 @@ performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do

161--

182--

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

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

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

184-- order of creation and the collection result is preserved.

164−performRequestsAsync

185+performRequestsAsyncWithError

165 :: (Traversable f, MonadWidget t m)

186 :: (Traversable f, MonadWidget t m)

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

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

188+performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError

189+

190+

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

192+performRequestsAsync = performRequestsAsync' newXMLHttpRequest

193+

194+performRequestsAsync' :: (MonadWidget t m, MonadIO h, Traversable f) => (XhrRequest -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t (f XhrRequest) -> m (Event t (f a))

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

195+performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \rs cb -> do

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

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

169 resp <- liftIO newEmptyMVar

197 resp <- liftIO newEmptyMVar

170− _ <- newXMLHttpRequest r $ liftIO . putMVar resp

198+ _ <- newXhr r $ liftIO . putMVar resp

171 return resp

199 return resp

172 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

200 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

173 return ()

201 return ()

@@ -176,12 +204,7 @@ performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do

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

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

177getAndDecode url = do

205getAndDecode url = do

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

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

179− return $

180− fmap (\r ->

181− case r of

182− Left{} -> Nothing

183− Right xhr -> decodeXhrResponse xhr)

207+ return $ fmap decodeXhrResponse r

184− r

185

208

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

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

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

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