a355a52 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Merge pull request #80 from imalsogreg/xhrheaders

Add support for selectable XHR headers

commita355a52697c9a8f0d3d71c04823902a40168e845 authorRyan Trinkle <ryan.trinkle@gmail.com> dateSun 28 Aug 2016, 20:28 (10 years ago) parent77e0c27 3442db5

2 files changed+67−19

compare with develop

unifiedsplit

src-ghc/Reflex/Dom/Xhr/Foreign.hs+31−10 src/Reflex/Dom/Xhr.hs+36−9

src-ghc/Reflex/Dom/Xhr/Foreign.hs+31−10

@@ -205,16 +205,8 @@ xmlHttpRequestGetStatus xhr = do

205205 return $ truncate d

206206

207207xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text

208−xmlHttpRequestGetStatusText xhr = do

209− let c = xhrContext xhr

210− script <- jsstringcreatewithutf8cstring "this.statusText"

211− t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

212− j <- jsvaluetostringcopy c t nullPtr

213− l <- jsstringgetmaximumutf8cstringsize j

214− s <- allocaBytes (fromIntegral l) $ \ps -> do

215− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

216− peekCString ps

217− return $ T.pack s

208+xmlHttpRequestGetStatusText xhr =

209+ xmlAuxHttpRequestGetWithJS xhr "this.statusText"

218210

219211xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO ()

220212xmlHttpRequestSetWithCredentials xhr b = do

@@ -225,3 +217,32 @@ xmlHttpRequestSetWithCredentials xhr b = do

225217 _ <- jsevaluatescript c script o nullPtr 1 nullPtr

226218 return ()

227219

220+xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text

221+xmlHttpRequestGetAllResponseHeaders xhr =

222+ xmlAuxHttpRequestGetWithJS xhr "this.getAllResponseHeaders()"

223+

224+xmlHttpRequestGetResponseHeader :: XMLHttpRequest -> Text -> IO Text

225+xmlHttpRequestGetResponseHeader xhr hdr = do

226+ let c = xhrContext xhr

227+ t' <- stringToJSValue c hdr

228+ o <- toJSObject c [xhrValue xhr, t']

229+ script <- jsstringcreatewithutf8cstring "this[0].getResponseHeader(this[1])"

230+ t <- jsevaluatescript c script o nullPtr 1 nullPtr

231+ xmlAuxJsGetString c t

232+

233+xmlAuxHttpRequestGetWithJS :: XMLHttpRequest -> String -> IO Text

234+xmlAuxHttpRequestGetWithJS xhr jsScript = do

235+ let c = xhrContext xhr

236+ script <- jsstringcreatewithutf8cstring jsScript

237+ t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

238+ xmlAuxJsGetString c t

239+

240+xmlAuxJsGetString :: JSContextRef -> JSValueRef -> IO Text

241+xmlAuxJsGetString c t = do

242+ j <- jsvaluetostringcopy c t nullPtr

243+ l <- jsstringgetmaximumutf8cstringsize j

244+ s <- allocaBytes (fromIntegral l) $ \ps -> do

245+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

246+ peekCString ps

247+ return $ T.pack s

248+

src/Reflex/Dom/Xhr.hs+36−9

@@ -11,6 +11,7 @@ module Reflex.Dom.Xhr

1111 , XhrRequestConfig (..)

1212 , XhrResponse (..)

1313 , XhrResponseBody (..)

14+ , XhrResponseHeaders (..)

1415 , XhrResponseType (..)

1516 , XhrException (..)

1617 , IsXhrPayload (..)

@@ -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

@@ -74,7 +77,10 @@ import Data.Default

7477import Data.Map (Map)

7578import qualified Data.Map as Map

7679import Data.Maybe

80+import qualified Data.Set as Set

7781import Data.Text (Text)

82+import qualified Data.Text as T

83+import qualified Data.List as L

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 (Set.Set 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 mempty

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.

@@ -163,20 +180,31 @@ newXMLHttpRequestWithError req cb = do

163180 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

164181 when (readyState == 4) $ do

165182 t <- if rt == Just XhrResponseType_Text || isNothing rt

166− then liftIO $ xmlHttpRequestGetResponseText xhr

167− else return 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 $ parseAllHeadersString <$>

188+ xmlHttpRequestGetAllResponseHeaders xhr

189+ OnlyHeaders xs -> liftIO $ traverse (xmlHttpRequestGetResponseHeader xhr)

190+ (Map.fromSet id 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+ L.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−