@@ -19,6 +19,7 @@ module Reflex.Dom.Xhr
1919where
2020
2121import Control.Concurrent
22+import Control.Exception (catch)
2223import Control.Lens
2324import Control.Monad hiding (forM)
2425import Control.Monad.IO.Class
@@ -37,6 +38,7 @@ import Data.Traversable
3738import Reflex
3839import Reflex.Dom.Class
3940import Reflex.Dom.Xhr.Foreign
41+import GHCJS.DOM.JSFFI.XMLHttpRequest (XHRError(..))
4042import Data.Typeable
4143
4244data XhrRequest
@@ -100,12 +102,24 @@ instance Default XhrRequestConfig where
100102xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
101103xhrRequest = XhrRequest
102104
103−newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest
105+-- | Make a new asyncronous XHR request. This does not block (it forks),
106+-- and returns an XHR object immediately (which you can use to abort
107+-- the XHR connection), and will pass an exception ('XHRError') to the
108+-- continuation if the connection cannot be made (or is aborted).
109+newXMLHttpRequest
110+ :: (HasWebView m, MonadIO m, HasPostGui t h m)
111+ => XhrRequest
112+ -- ^ The request to make.
113+ -> (Either XHRError XhrResponse -> h ())
114+ -- ^ A continuation to be called once a response comes back, or in
115+ -- case of error.
116+ -> m XMLHttpRequest
117+ -- ^ The XHR request, which could for example be aborted.
104118newXMLHttpRequest req cb = do
105119 wv <- askWebView
106120 postGui <- askPostGui
107− liftIO $ do
108− xhr <- xmlHttpRequestNew wv
121+ xhr <- liftIO $ xmlHttpRequestNew wv
122+ void $ liftIO $ forkIO $ flip catch (postGui . cb . Left) $ void $ do
109123 let c = _xhrRequest_config req
110124 rt = _xhrRequestConfig_responseType c
111125 xmlHttpRequestOpen
@@ -127,24 +141,42 @@ newXMLHttpRequest req cb = do
127141 then liftIO $ xmlHttpRequestGetResponseText xhr
128142 else return Nothing
129143 r <- liftIO $ xmlHttpRequestGetResponse xhr
130− _ <- liftIO $ postGui $ cb $ XhrResponse { _xhrResponse_status = status
131− , _xhrResponse_statusText = statusTextToText statusText
132− , _xhrResponse_response = r
133− , _xhrResponse_responseText = responseTextToText t
134− }
144+ _ <- liftIO $ postGui $ cb $ Right $
145+ XhrResponse { _xhrResponse_status = status
146+ , _xhrResponse_statusText = statusTextToText statusText
147+ , _xhrResponse_response = r
148+ , _xhrResponse_responseText = responseTextToText t
149+ }
135150 return ()
136151 else return ()
137152 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
138− return xhr
139−
140−-- | Given Event of requests, issue them when the Event fires. Returns Event of corresponding responses.
141−performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)
153+ return ()
154+ return xhr
155+
156+-- | Given Event of requests, issue them when the Event fires.
157+-- Returns Event of corresponding responses.
158+--
159+-- The request is processed asynchronously, therefore handling does
160+-- not block or cause a delay while creating the connection.
161+performRequestAsync
162+ :: (MonadWidget t m)
163+ => Event t XhrRequest -> m (Event t (Either XHRError XhrResponse))
142164performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
143165 _ <- newXMLHttpRequest r $ liftIO . cb
144166 return ()
145167
146−-- | 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.
147−performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))
168+-- | Issues a collection of requests when the supplied Event fires.
169+-- When ALL requests from a given firing complete, the results are
170+-- collected and returned via the return Event.
171+--
172+-- The requests are processed asynchronously, therefore handling does
173+-- not block or cause a delay while creating the connection.
174+--
175+-- Order of request execution and completion is not guaranteed, but
176+-- order of creation and the collection result is preserved.
177+performRequestsAsync
178+ :: (Traversable f, MonadWidget t m)
179+ => Event t (f XhrRequest) -> m (Event t (f (Either XHRError XhrResponse)))
148180performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
149181 resps <- forM rs $ \r -> do
150182 resp <- liftIO newEmptyMVar
@@ -157,11 +189,16 @@ performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
157189getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))
158190getAndDecode url = do
159191 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
160− return $ fmap decodeXhrResponse r
192+ return $
193+ fmap (\r ->
194+ case r of
195+ Left{} -> Nothing
196+ Right xhr -> decodeXhrResponse xhr)
197+ r
161198
162199-- | Create a "POST" request from an URL and thing with a JSON representation
163200postJson :: (ToJSON a) => String -> a -> XhrRequest
164−postJson url a =
201+postJson url a =
165202 XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc
166203 , _xhrRequestConfig_sendData = Just body
167204 }
@@ -179,4 +216,3 @@ decodeText = decode . BL.fromStrict . encodeUtf8
179216-- | Convenience function to decode JSON-encoded responses.
180217decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
181218decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
182−