@@ -1,12 +1,27 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22
33module Reflex.Dom.Xhr
4− ( module Reflex.Dom.Xhr
5− , XMLHttpRequest
4+ ( XMLHttpRequest
5+ , XhrRequest(..)
6+ , XhrRequestConfig(..)
7+ , XhrResponse(..)
68 , XhrResponseBody(..)
79 , XhrResponseType(..)
810 , 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
1025 , xmlHttpRequestGetReadyState
1126 , xmlHttpRequestGetResponseText
1227 , xmlHttpRequestGetStatus
@@ -43,7 +58,6 @@ import Reflex.Dom.Xhr.Exception
4358import Reflex.Dom.Xhr.Foreign
4459import Reflex.Dom.Xhr.ResponseType
4560import Data.Typeable
46−-- import GHCJS.DOM.JSFFI.XMLHttpRequest (XHRError(..))
4761
4862data XhrRequest
4963 = XhrRequest { _xhrRequest_method :: String
@@ -93,7 +107,7 @@ xhrRequest = XhrRequest
93107-- and returns an XHR object immediately (which you can use to abort
94108-- the XHR connection), and will pass an exception ('XhrException') to the
95109-- continuation if the connection cannot be made (or is aborted).
96−newXMLHttpRequest
110+newXMLHttpRequestWithError
97111 :: (HasWebView m, MonadIO m, HasPostGui t h m)
98112 => XhrRequest
99113 -- ^ The request to make.
@@ -102,7 +116,7 @@ newXMLHttpRequest
102116 -- case of error.
103117 -> m XMLHttpRequest
104118 -- ^ The XHR request, which could for example be aborted.
105−newXMLHttpRequest req cb = do
119+newXMLHttpRequestWithError req cb = do
106120 wv <- askWebView
107121 postGui <- askPostGui
108122 xhr <- liftIO $ xmlHttpRequestNew wv
@@ -129,28 +143,35 @@ newXMLHttpRequest req cb = do
129143 else return Nothing
130144 r <- liftIO $ xmlHttpRequestGetResponse xhr
131145 _ <- liftIO $ postGui $ cb $ Right $
132− XhrResponse { _xhrResponse_status = status
133− , _xhrResponse_statusText = statusTextToText statusText
134− , _xhrResponse_response = r
135− , _xhrResponse_responseText = responseTextToText t
136− }
146+ XhrResponse { _xhrResponse_status = status
147+ , _xhrResponse_statusText = statusText
148+ , _xhrResponse_response = r
149+ , _xhrResponse_responseText = t
150+ }
137151 return ()
138152 else return ()
139153 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
140154 return ()
141155 return xhr
142156
157+newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest
158+newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
159+
143160-- | Given Event of requests, issue them when the Event fires.
144161-- Returns Event of corresponding responses.
145162--
146163-- The request is processed asynchronously, therefore handling does
147164-- not block or cause a delay while creating the connection.
148−performRequestAsync
149− :: (MonadWidget t m)
165+performRequestAsyncWithError
166+ :: MonadWidget t m
150167 => Event t XhrRequest -> m (Event t (Either XhrException XhrResponse))
151−performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
152− _ <- newXMLHttpRequest r $ liftIO . cb
153− return ()
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)
174+performRequestAsync' newXhr req = performEventAsync $ ffor req $ \r cb -> void $ newXhr r $ liftIO . cb
154175
155176-- | Issues a collection of requests when the supplied Event fires.
156177-- When ALL requests from a given firing complete, the results are
@@ -161,13 +182,20 @@ performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
161182--
162183-- Order of request execution and completion is not guaranteed, but
163184-- order of creation and the collection result is preserved.
164−performRequestsAsync
185+performRequestsAsyncWithError
165186 :: (Traversable f, MonadWidget t m)
166187 => Event t (f XhrRequest) -> m (Event t (f (Either XhrException XhrResponse)))
167−performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
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))
195+performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \rs cb -> do
168196 resps <- forM rs $ \r -> do
169197 resp <- liftIO newEmptyMVar
170− _ <- newXMLHttpRequest r $ liftIO . putMVar resp
198+ _ <- newXhr r $ liftIO . putMVar resp
171199 return resp
172200 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
173201 return ()
@@ -176,12 +204,7 @@ performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
176204getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))
177205getAndDecode url = do
178206 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)
184− r
207+ return $ fmap decodeXhrResponse r
185208
186209-- | Create a "POST" request from an URL and thing with a JSON representation
187210postJson :: (ToJSON a) => String -> a -> XhrRequest