@@ -5,6 +5,7 @@ module Reflex.Dom.Xhr
55 , XMLHttpRequest
66 , XhrResponseBody(..)
77 , XhrResponseType(..)
8+ , XhrException(..)
89 , responseTextToText
910 , xmlHttpRequestGetReadyState
1011 , xmlHttpRequestGetResponseText
@@ -20,6 +21,7 @@ module Reflex.Dom.Xhr
2021where
2122
2223import Control.Concurrent
24+import Control.Exception (catch)
2325import Control.Lens
2426import Control.Monad hiding (forM)
2527import Control.Monad.IO.Class
@@ -37,9 +39,11 @@ import Data.Text.Encoding
3739import Data.Traversable
3840import Reflex
3941import Reflex.Dom.Class
42+import Reflex.Dom.Xhr.Exception
4043import Reflex.Dom.Xhr.Foreign
4144import Reflex.Dom.Xhr.ResponseType
4245import Data.Typeable
46+-- import GHCJS.DOM.JSFFI.XMLHttpRequest (XHRError(..))
4347
4448data XhrRequest
4549 = XhrRequest { _xhrRequest_method :: String
@@ -85,12 +89,24 @@ instance Default XhrRequestConfig where
8589xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
8690xhrRequest = XhrRequest
8791
88−newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest
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
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.
89105newXMLHttpRequest req cb = do
90106 wv <- askWebView
91107 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
94110 let c = _xhrRequest_config req
95111 rt = _xhrRequestConfig_responseType c
96112 xmlHttpRequestOpen
@@ -112,24 +128,42 @@ newXMLHttpRequest req cb = do
112128 then liftIO $ xmlHttpRequestGetResponseText xhr
113129 else return Nothing
114130 r <- liftIO $ xmlHttpRequestGetResponse xhr
115− _ <- liftIO $ postGui $ cb $ XhrResponse { _xhrResponse_status = status
116− , _xhrResponse_statusText = statusTextToText statusText
117− , _xhrResponse_response = r
118− , _xhrResponse_responseText = responseTextToText t
119− }
131+ _ <- liftIO $ postGui $ cb $ Right $
132+ XhrResponse { _xhrResponse_status = status
133+ , _xhrResponse_statusText = statusTextToText statusText
134+ , _xhrResponse_response = r
135+ , _xhrResponse_responseText = responseTextToText t
136+ }
120137 return ()
121138 else return ()
122139 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
123− return xhr
124−
125−-- | Given Event of requests, issue them when the Event fires. Returns Event of corresponding responses.
126−performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)
140+ return ()
141+ return xhr
142+
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)
150+ => Event t XhrRequest -> m (Event t (Either XhrException XhrResponse))
127151performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
128152 _ <- newXMLHttpRequest r $ liftIO . cb
129153 return ()
130154
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.
132−performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))
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)
166+ => Event t (f XhrRequest) -> m (Event t (f (Either XhrException XhrResponse)))
133167performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
134168 resps <- forM rs $ \r -> do
135169 resp <- liftIO newEmptyMVar
@@ -142,11 +176,16 @@ performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
142176getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))
143177getAndDecode url = do
144178 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
145− return $ fmap decodeXhrResponse r
179+ return $
180+ fmap (\r ->
181+ case r of
182+ Left{} -> Nothing
183+ Right xhr -> decodeXhrResponse xhr)
184+ r
146185
147186-- | Create a "POST" request from an URL and thing with a JSON representation
148187postJson :: (ToJSON a) => String -> a -> XhrRequest
149−postJson url a =
188+postJson url a =
150189 XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc
151190 , _xhrRequestConfig_sendData = Just body
152191 }
@@ -164,4 +203,3 @@ decodeText = decode . BL.fromStrict . encodeUtf8
164203-- | Convenience function to decode JSON-encoded responses.
165204decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
166205decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
167−