@@ -19,6 +19,7 @@ module Reflex.Dom.Xhr
21import Control.Concurrent
21import Control.Concurrent
22+import Control.Exception (catch)
22import Control.Lens
23import Control.Lens
23import Control.Monad hiding (forM)
24import Control.Monad hiding (forM)
24import Control.Monad.IO.Class
25import Control.Monad.IO.Class
@@ -37,6 +38,7 @@ import Data.Traversable
37import Reflex
38import Reflex
38import Reflex.Dom.Class
39import Reflex.Dom.Class
39import Reflex.Dom.Xhr.Foreign
40import Reflex.Dom.Xhr.Foreign
41+import GHCJS.DOM.JSFFI.XMLHttpRequest (XHRError(..))
40import Data.Typeable
42import Data.Typeable
42data XhrRequest
44data XhrRequest
@@ -100,12 +102,24 @@ instance Default XhrRequestConfig where
100xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
102xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
101xhrRequest = XhrRequest
103xhrRequest = XhrRequest
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).
103−newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest
110+ :: (HasWebView m, MonadIO m, HasPostGui t h m)
112+ -- ^ The request to make.
113+ -> (Either XHRError XhrResponse -> h ())
114+ -- ^ A continuation to be called once a response comes back, or in
117+ -- ^ The XHR request, which could for example be aborted.
104newXMLHttpRequest req cb = do
118newXMLHttpRequest req cb = do
105 wv <- askWebView
119 wv <- askWebView
106 postGui <- askPostGui
120 postGui <- askPostGui
108− xhr <- xmlHttpRequestNew wv
121+ xhr <- liftIO $ xmlHttpRequestNew wv
122+ void $ liftIO $ forkIO $ flip catch (postGui . cb . Left) $ void $ do
109 let c = _xhrRequest_config req
123 let c = _xhrRequest_config req
110 rt = _xhrRequestConfig_responseType c
124 rt = _xhrRequestConfig_responseType c
111 xmlHttpRequestOpen
125 xmlHttpRequestOpen
@@ -127,24 +141,42 @@ newXMLHttpRequest req cb = do
127 then liftIO $ xmlHttpRequestGetResponseText xhr
141 then liftIO $ xmlHttpRequestGetResponseText xhr
128 else return Nothing
142 else return Nothing
129 r <- liftIO $ xmlHttpRequestGetResponse xhr
143 r <- liftIO $ xmlHttpRequestGetResponse xhr
144+ _ <- liftIO $ postGui $ cb $ Right $
130− _ <- liftIO $ postGui $ cb $ XhrResponse { _xhrResponse_status = status
145+ XhrResponse { _xhrResponse_status = status
131− , _xhrResponse_statusText = statusTextToText statusText
146+ , _xhrResponse_statusText = statusTextToText statusText
132− , _xhrResponse_response = r
147+ , _xhrResponse_response = r
133− , _xhrResponse_responseText = responseTextToText t
148+ , _xhrResponse_responseText = responseTextToText t
135 return ()
150 return ()
136 else return ()
151 else return ()
137 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
152 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
138− return xhr
153+ return ()
140−-- | Given Event of requests, issue them when the Event fires. Returns Event of corresponding responses.
156+-- | Given Event of requests, issue them when the Event fires.
157+-- Returns Event of corresponding responses.
159+-- The request is processed asynchronously, therefore handling does
160+-- not block or cause a delay while creating the connection.
162+ :: (MonadWidget t m)
141−performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)
163+ => Event t XhrRequest -> m (Event t (Either XHRError XhrResponse))
142performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
164performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
143 _ <- newXMLHttpRequest r $ liftIO . cb
165 _ <- newXMLHttpRequest r $ liftIO . cb
144 return ()
166 return ()
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.
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.
172+-- The requests are processed asynchronously, therefore handling does
173+-- not block or cause a delay while creating the connection.
175+-- Order of request execution and completion is not guaranteed, but
176+-- order of creation and the collection result is preserved.
178+ :: (Traversable f, MonadWidget t m)
147−performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))
179+ => Event t (f XhrRequest) -> m (Event t (f (Either XHRError XhrResponse)))
148performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
180performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
149 resps <- forM rs $ \r -> do
181 resps <- forM rs $ \r -> do
150 resp <- liftIO newEmptyMVar
182 resp <- liftIO newEmptyMVar
@@ -157,11 +189,16 @@ performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
157getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))
189getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a))
158getAndDecode url = do
190getAndDecode url = do
159 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
191 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
160− return $ fmap decodeXhrResponse r
196+ Right xhr -> decodeXhrResponse xhr)
162-- | Create a "POST" request from an URL and thing with a JSON representation
199-- | Create a "POST" request from an URL and thing with a JSON representation
163postJson :: (ToJSON a) => String -> a -> XhrRequest
200postJson :: (ToJSON a) => String -> a -> XhrRequest
164−postJson url a =
201+postJson url a =
165 XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc
202 XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc
166 , _xhrRequestConfig_sendData = Just body
203 , _xhrRequestConfig_sendData = Just body
@@ -179,4 +216,3 @@ decodeText = decode . BL.fromStrict . encodeUtf8
179-- | Convenience function to decode JSON-encoded responses.
216-- | Convenience function to decode JSON-encoded responses.
180decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
217decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
181decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
218decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText