git.iko.soy/reflex-dom
on develop help sign in
Get user-defined subset of XHR response headers
a1aedebGreg Hale
src-ghc/Reflex/Dom/Xhr/Foreign.hs+25
compare with develop
unifiedsplit
@@ -222,3 +222,28 @@ xmlHttpRequestSetWithCredentials xhr b = do
222 _ <- jsevaluatescript c script o nullPtr 1 nullPtr
222 _ <- jsevaluatescript c script o nullPtr 1 nullPtr
223 return ()
223 return ()
224
224
225+xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text
226+xmlHttpRequestGetAllResponseHeaders xhr = do
227+ let c = xhrContext xhr
228+ script <- jsstringcreatewithutf8cstring "this.getAllResponseHeaders()"
229+ t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
230+ j <- jsvaluetostringcopy c t nullPtr
231+ l <- jsstringgetmaximumutf8cstringsize j
232+ s <- allocaBytes (fromIntegral l) $ \ps -> do
233+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
234+ peekCString ps
235+ return $ T.pack s
236+
237+xmlHttpRequestGetResponseHeader :: XMLHttpRequest -> Text -> IO Text
238+xmlHttpRequestGetResponseHeader xhr hdr = do
239+ let c = xhrContext xhr
240+ t' <- stringToJSValue c hdr
241+ o <- toJSObject c [xhrValue xhr, t']
242+ script <- jsstringcreatewithutf8cstring "this[0].getResponseHeader(this[1])"
243+ t <- jsevaluatescript c script o nullPtr 1 nullPtr
244+ j <- jsvaluetostringcopy c t nullPtr
245+ l <- jsstringgetmaximumutf8cstringsize j
246+ s <- allocaBytes (fromIntegral l) $ \ps -> do
247+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
248+ peekCString ps
249+ return $ T.pack s
src/Reflex/Dom/Xhr.hs+37−10
@@ -5,6 +5,7 @@
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE TemplateHaskell #-}
7{-# LANGUAGE TemplateHaskell #-}
8+{-# LANGUAGE TupleSections #-}
8module Reflex.Dom.Xhr
9module Reflex.Dom.Xhr
9 ( XMLHttpRequest
10 ( XMLHttpRequest
10 , XhrRequest (..)
11 , XhrRequest (..)
@@ -35,6 +36,7 @@ module Reflex.Dom.Xhr
35 , xhrRequestConfig_sendData
36 , xhrRequestConfig_sendData
36 , xhrRequestConfig_user
37 , xhrRequestConfig_user
37 , xhrRequestConfig_withCredentials
38 , xhrRequestConfig_withCredentials
39+ , xhrRequestConfig_responseHeaders
38 , xhrRequest_config
40 , xhrRequest_config
39 , xhrRequest_method
41 , xhrRequest_method
40 , xhrRequest_url
42 , xhrRequest_url
@@ -43,6 +45,7 @@ module Reflex.Dom.Xhr
43 , xhrResponse_responseText
45 , xhrResponse_responseText
44 , xhrResponse_status
46 , xhrResponse_status
45 , xhrResponse_statusText
47 , xhrResponse_statusText
48+ , xhrResponse_headers
46 , xmlHttpRequestGetReadyState
49 , xmlHttpRequestGetReadyState
47 , xmlHttpRequestGetResponseText
50 , xmlHttpRequestGetResponseText
48 , xmlHttpRequestGetStatus
51 , xmlHttpRequestGetStatus
@@ -75,6 +78,9 @@ import Data.Map (Map)
75import qualified Data.Map as Map
78import qualified Data.Map as Map
76import Data.Maybe
79import Data.Maybe
77import Data.Text (Text)
80import Data.Text (Text)
81+import qualified Data.Text as T
82+-- import GHCJS.DOM.XMLHttpRequest (getAllResponseHeaders)
83+import Data.List
78import Data.Text.Encoding
84import Data.Text.Encoding
79import qualified Data.Text.Lazy as LT
85import qualified Data.Text.Lazy as LT
80import qualified Data.Text.Lazy.Builder as B
86import qualified Data.Text.Lazy.Builder as B
@@ -95,6 +101,7 @@ data XhrRequestConfig a
95 , _xhrRequestConfig_responseType :: Maybe XhrResponseType
101 , _xhrRequestConfig_responseType :: Maybe XhrResponseType
96 , _xhrRequestConfig_sendData :: a
102 , _xhrRequestConfig_sendData :: a
97 , _xhrRequestConfig_withCredentials :: Bool
103 , _xhrRequestConfig_withCredentials :: Bool
104+ , _xhrRequestConfig_responseHeaders :: XhrResponseHeaders
98 }
105 }
99 deriving (Show, Read, Eq, Ord, Typeable, Functor)
106 deriving (Show, Read, Eq, Ord, Typeable, Functor)
100
107
@@ -103,9 +110,18 @@ data XhrResponse
103 , _xhrResponse_statusText :: Text
110 , _xhrResponse_statusText :: Text
104 , _xhrResponse_response :: Maybe XhrResponseBody
111 , _xhrResponse_response :: Maybe XhrResponseBody
105 , _xhrResponse_responseText :: Maybe Text
112 , _xhrResponse_responseText :: Maybe Text
113+ , _xhrResponse_headers :: Map Text Text
106 }
114 }
107 deriving (Typeable)
115 deriving (Typeable)
108
116
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+
109{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}
125{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}
110_xhrResponse_body :: XhrResponse -> Maybe Text
126_xhrResponse_body :: XhrResponse -> Maybe Text
111_xhrResponse_body = _xhrResponse_responseText
127_xhrResponse_body = _xhrResponse_responseText
@@ -121,6 +137,7 @@ instance a ~ () => Default (XhrRequestConfig a) where
121 , _xhrRequestConfig_responseType = Nothing
137 , _xhrRequestConfig_responseType = Nothing
122 , _xhrRequestConfig_sendData = ()
138 , _xhrRequestConfig_sendData = ()
123 , _xhrRequestConfig_withCredentials = False
139 , _xhrRequestConfig_withCredentials = False
140+ , _xhrRequestConfig_responseHeaders = def
124 }
141 }
125
142
126-- | Construct a request object from method, URL, and config record.
143-- | Construct a request object from method, URL, and config record.
@@ -162,21 +179,32 @@ newXMLHttpRequestWithError req cb = do
162 status <- liftIO $ xmlHttpRequestGetStatus xhr
179 status <- liftIO $ xmlHttpRequestGetStatus xhr
163 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
180 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
164 when (readyState == 4) $ do
181 when (readyState == 4) $ do
165− t <- if rt == Just XhrResponseType_Text || isNothing rt
182+ t <- if rt == Just XhrResponseType_Text || rt == Nothing
166− then liftIO $ xmlHttpRequestGetResponseText xhr
183+ then liftIO $ xmlHttpRequestGetResponseText xhr
167− else return Nothing
184+ else return Nothing
168 r <- liftIO $ xmlHttpRequestGetResponse xhr
185 r <- liftIO $ xmlHttpRequestGetResponse xhr
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
169− _ <- liftIO $ cb $ Right $ XhrResponse
191+ _ <- liftIO $ cb $ Right $
170− { _xhrResponse_status = status
192+ XhrResponse { _xhrResponse_status = status
171− , _xhrResponse_statusText = statusText
193+ , _xhrResponse_statusText = statusText
172− , _xhrResponse_response = r
194+ , _xhrResponse_response = r
173− , _xhrResponse_responseText = t
195+ , _xhrResponse_responseText = t
196+ , _xhrResponse_headers = h
174− }
197+ }
175 return ()
198 return ()
176 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
199 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
177 return ()
200 return ()
178 return xhr
201 return xhr
179
202
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+
180newXMLHttpRequest :: (HasWebView m, MonadIO m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> IO ()) -> m XMLHttpRequest
208newXMLHttpRequest :: (HasWebView m, MonadIO m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> IO ()) -> m XMLHttpRequest
181newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
209newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
182
210
@@ -269,4 +297,3 @@ concat <$> mapM makeLenses
269 , ''XhrRequestConfig
297 , ''XhrRequestConfig
270 , ''XhrResponse
298 , ''XhrResponse
271 ]
299 ]
272−