@@ -5,6 +5,7 @@
55{-# LANGUAGE MultiParamTypeClasses #-}
66{-# LANGUAGE OverloadedStrings #-}
77{-# LANGUAGE TemplateHaskell #-}
8+{-# LANGUAGE TupleSections #-}
89module Reflex.Dom.Xhr
910 ( XMLHttpRequest
1011 , XhrRequest (..)
@@ -35,6 +36,7 @@ module Reflex.Dom.Xhr
3536 , xhrRequestConfig_sendData
3637 , xhrRequestConfig_user
3738 , xhrRequestConfig_withCredentials
39+ , xhrRequestConfig_responseHeaders
3840 , xhrRequest_config
3941 , xhrRequest_method
4042 , xhrRequest_url
@@ -43,6 +45,7 @@ module Reflex.Dom.Xhr
4345 , xhrResponse_responseText
4446 , xhrResponse_status
4547 , xhrResponse_statusText
48+ , xhrResponse_headers
4649 , xmlHttpRequestGetReadyState
4750 , xmlHttpRequestGetResponseText
4851 , xmlHttpRequestGetStatus
@@ -75,6 +78,9 @@ import Data.Map (Map)
7578import qualified Data.Map as Map
7679import Data.Maybe
7780import Data.Text (Text)
81+import qualified Data.Text as T
82+-- import GHCJS.DOM.XMLHttpRequest (getAllResponseHeaders)
83+import Data.List
7884import Data.Text.Encoding
7985import qualified Data.Text.Lazy as LT
8086import qualified Data.Text.Lazy.Builder as B
@@ -95,6 +101,7 @@ data XhrRequestConfig a
95101 , _xhrRequestConfig_responseType :: Maybe XhrResponseType
96102 , _xhrRequestConfig_sendData :: a
97103 , _xhrRequestConfig_withCredentials :: Bool
104+ , _xhrRequestConfig_responseHeaders :: XhrResponseHeaders
98105 }
99106 deriving (Show, Read, Eq, Ord, Typeable, Functor)
100107
@@ -103,9 +110,18 @@ data XhrResponse
103110 , _xhrResponse_statusText :: Text
104111 , _xhrResponse_response :: Maybe XhrResponseBody
105112 , _xhrResponse_responseText :: Maybe Text
113+ , _xhrResponse_headers :: Map Text Text
106114 }
107115 deriving (Typeable)
108116
117+data XhrResponseHeaders =
118+ OnlyHeaders [Text] -- ^ Parse a subset of headers from the XHR Response
119+ | AllHeaders -- ^ Parse all headers from the XHR Response
120+ deriving (Show, Read, Eq, Ord, Typeable)
121+
122+instance Default XhrResponseHeaders where
123+ def = OnlyHeaders []
124+
109125{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}
110126_xhrResponse_body :: XhrResponse -> Maybe Text
111127_xhrResponse_body = _xhrResponse_responseText
@@ -121,6 +137,7 @@ instance a ~ () => Default (XhrRequestConfig a) where
121137 , _xhrRequestConfig_responseType = Nothing
122138 , _xhrRequestConfig_sendData = ()
123139 , _xhrRequestConfig_withCredentials = False
140+ , _xhrRequestConfig_responseHeaders = def
124141 }
125142
126143-- | Construct a request object from method, URL, and config record.
@@ -162,21 +179,32 @@ newXMLHttpRequestWithError req cb = do
162179 status <- liftIO $ xmlHttpRequestGetStatus xhr
163180 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
164181 when (readyState == 4) $ do
165− t <- if rt == Just XhrResponseType_Text || isNothing rt
166− then liftIO $ xmlHttpRequestGetResponseText xhr
167− else return Nothing
182+ t <- if rt == Just XhrResponseType_Text || rt == Nothing
183+ then liftIO $ xmlHttpRequestGetResponseText xhr
184+ else return Nothing
168185 r <- liftIO $ xmlHttpRequestGetResponse xhr
169− _ <- liftIO $ cb $ Right $ XhrResponse
170− { _xhrResponse_status = status
171− , _xhrResponse_statusText = statusText
172− , _xhrResponse_response = r
173− , _xhrResponse_responseText = t
174− }
186+ h <- case _xhrRequestConfig_responseHeaders c of
187+ AllHeaders -> liftIO $ fmap parseAllHeadersString $
188+ xmlHttpRequestGetAllResponseHeaders xhr
189+ OnlyHeaders xs -> liftIO $ fmap Map.fromList $ traverse
190+ (\x -> (x,) <$> xmlHttpRequestGetResponseHeader xhr x) xs
191+ _ <- liftIO $ cb $ Right $
192+ XhrResponse { _xhrResponse_status = status
193+ , _xhrResponse_statusText = statusText
194+ , _xhrResponse_response = r
195+ , _xhrResponse_responseText = t
196+ , _xhrResponse_headers = h
197+ }
175198 return ()
176199 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
177200 return ()
178201 return xhr
179202
203+parseAllHeadersString :: Text -> Map Text Text
204+parseAllHeadersString s = Map.fromList $ fmap (stripBoth . (T.span (/=':'))) $
205+ dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s
206+ where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)
207+
180208newXMLHttpRequest :: (HasWebView m, MonadIO m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> IO ()) -> m XMLHttpRequest
181209newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
182210
@@ -269,4 +297,3 @@ concat <$> mapM makeLenses
269297 , ''XhrRequestConfig
270298 , ''XhrResponse
271299 ]
272−