a355a52 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge pull request #80 from imalsogreg/xhrheaders

a355a52Ryan Trinkle10 years ago

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

compare with develop

unifiedsplit

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

205 return $ truncate d

206

207xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text

208−xmlHttpRequestGetStatusText xhr = do

208+xmlHttpRequestGetStatusText xhr =

209− let c = xhrContext xhr

209+ xmlAuxHttpRequestGetWithJS xhr "this.statusText"

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

218

210

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

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

220xmlHttpRequestSetWithCredentials xhr b = do

212xmlHttpRequestSetWithCredentials xhr b = do

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

225 _ <- jsevaluatescript c script o nullPtr 1 nullPtr

217 _ <- jsevaluatescript c script o nullPtr 1 nullPtr

226 return ()

218 return ()

227

219

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

11 , XhrRequestConfig (..)

12 , XhrResponse (..)

13 , XhrResponseBody (..)

14+ , XhrResponseHeaders (..)

14 , XhrResponseType (..)

15 , XhrResponseType (..)

15 , XhrException (..)

16 , XhrException (..)

16 , IsXhrPayload (..)

17 , IsXhrPayload (..)

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

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

74import Data.Map (Map)

77import Data.Map (Map)

75import qualified Data.Map as Map

78import qualified Data.Map as Map

76import Data.Maybe

79import Data.Maybe

80+import qualified Data.Set as Set

77import Data.Text (Text)

81import Data.Text (Text)

82+import qualified Data.Text as T

83+import qualified Data.List as L

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 (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+

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.

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

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 || isNothing rt

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 $ parseAllHeadersString <$>

188+ xmlHttpRequestGetAllResponseHeaders xhr

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

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

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−