git.iko.soy/reflex-dom
on develop help sign in
Merge pull request #42 from ryantrinkle/xhr-response-body

Make it possible to access non-text response types in Reflex.Dom.Xhr

commit89cd4fdfa1b777256392807657f907e3a116a2e4 authorRyan Trinkle <ryan.trinkle@gmail.com> dateSun 10 Jan 2016, 19:07 (11 years ago) parent4ce94d0a8fc836
3 files changed+92−10
compare with develop
unifiedsplit
src-ghc/Reflex/Dom/Xhr/Foreign.hs+13−1 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+37−2 src/Reflex/Dom/Xhr.hs+42−7
src-ghc/Reflex/Dom/Xhr/Foreign.hs+13−1
@@ -1,7 +1,6 @@
11{-# LANGUAGE ForeignFunctionInterface #-}
22module Reflex.Dom.Xhr.Foreign where
33
4−import Control.Lens.Indexed
54import qualified Data.Text as T
65import Data.Text (Text)
76import System.Glib.FFI
@@ -20,6 +19,9 @@ data XMLHttpRequest
2019 }
2120 deriving (Eq, Ord)
2221
22+data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSValueRef }
23+ deriving (Eq)
24+
2325responseTextToText :: Maybe String -> Maybe Text
2426responseTextToText = fmap T.pack
2527
@@ -74,6 +76,16 @@ xmlHttpRequestGetReadyState xhr = do
7476 d <- jsvaluetonumber c rs nullPtr
7577 return $ truncate d
7678
79+xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)
80+xmlHttpRequestGetResponse xhr = do
81+ let c = xhrContext xhr
82+ script <- jsstringcreatewithutf8cstring "this.response"
83+ t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
84+ isNull <- jsvalueisnull c t
85+ case isNull of
86+ True -> return Nothing
87+ False -> return $ Just $ XhrResponseBody t
88+
7789xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)
7890xmlHttpRequestGetResponseText xhr = do
7991 let c = xhrContext xhr
src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+37−2
@@ -7,9 +7,7 @@ import GHCJS.Foreign
77import GHCJS.Marshal
88import qualified Data.Text as T
99import Data.Text (Text)
10−import Data.Word
1110import GHCJS.DOM.Types hiding (Text)
12−import Control.Applicative ((<$>))
1311import GHCJS.DOM.EventM
1412import GHCJS.DOM
1513import Data.Function
@@ -62,6 +60,34 @@ foreign import javascript unsafe "window[\"XMLHttpRequest\"]" gTypeXMLHttpReques
6260gTypeXMLHttpRequest :: GType
6361gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'
6462
63+newtype XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSRef XhrResponseBody }
64+
65+instance Eq XhrResponseBody where
66+ (==) = eqRef `on` unXhrResponseBody
67+
68+instance ToJSRef XhrResponseBody where
69+ toJSRef = return . unXhrResponseBody
70+ {-# INLINE toJSRef #-}
71+
72+instance FromJSRef XhrResponseBody where
73+ fromJSRef = return . fmap XhrResponseBody . maybeJSNull
74+ {-# INLINE fromJSRef #-}
75+
76+class GObjectClass o => IsXhrResponseBody o
77+toXhrResponseBody :: IsXhrResponseBody o => o -> XhrResponseBody
78+toXhrResponseBody = unsafeCastGObject . toGObject
79+
80+instance IsXhrResponseBody XhrResponseBody
81+instance GObjectClass XhrResponseBody where
82+ toGObject = GObject . castRef . unXhrResponseBody
83+ unsafeCastGObject = XhrResponseBody . castRef . unGObject
84+
85+castToXhrResponseBody :: GObjectClass obj => obj -> XhrResponseBody
86+castToXhrResponseBody = castTo gTypeXhrResponseBody "XhrResponseBody"
87+
88+foreign import javascript unsafe "window[\"XhrResponseBody\"]" gTypeXhrResponseBody' :: JSRef GType
89+gTypeXhrResponseBody :: GType
90+gTypeXhrResponseBody = GType gTypeXhrResponseBody'
6591
6692newtype XMLHttpRequestUpload = XMLHttpRequestUpload { unXMLHttpRequestUpload :: JSRef XMLHttpRequestUpload }
6793
@@ -312,6 +338,15 @@ xmlHttpRequestGetUpload self
312338 (ghcjs_dom_xml_http_request_get_upload
313339 (unXMLHttpRequest (toXMLHttpRequest self)))
314340
341+foreign import javascript unsafe "$1[\"response\"]"
342+ ghcjs_dom_xml_http_request_get_response ::
343+ JSRef XMLHttpRequest -> IO (JSRef XhrResponseBody)
344+
345+xmlHttpRequestGetResponse :: IsXMLHttpRequest self => self -> IO (Maybe XhrResponseBody)
346+xmlHttpRequestGetResponse self = fmap XhrResponseBody . maybeJSNull <$>
347+ (ghcjs_dom_xml_http_request_get_response
348+ (unXMLHttpRequest (toXMLHttpRequest self)))
349+
315350foreign import javascript unsafe "$1[\"responseText\"]"
316351 ghcjs_dom_xml_http_request_get_response_text ::
317352 JSRef XMLHttpRequest -> IO JSString
src/Reflex/Dom/Xhr.hs+42−7
@@ -3,6 +3,7 @@
33module Reflex.Dom.Xhr
44 ( module Reflex.Dom.Xhr
55 , XMLHttpRequest
6+ , XhrResponseBody(..)
67 , responseTextToText
78 , xmlHttpRequestGetReadyState
89 , xmlHttpRequestGetResponseText
@@ -49,18 +50,44 @@ data XhrRequestConfig
4950 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String
5051 , _xhrRequestConfig_user :: Maybe String
5152 , _xhrRequestConfig_password :: Maybe String
52− , _xhrRequestConfig_responseType :: Maybe String
53+ , _xhrRequestConfig_responseType :: Maybe XhrResponseType
5354 , _xhrRequestConfig_sendData :: Maybe String
5455 }
5556 deriving (Show, Read, Eq, Ord, Typeable)
5657
5758data XhrResponse
58− = XhrResponse { _xhrResponse_body :: Maybe Text
59− , _xhrResponse_status :: Word
59+ = XhrResponse { _xhrResponse_status :: Word
6060 , _xhrResponse_statusText :: Text
61+ , _xhrResponse_response :: Maybe XhrResponseBody
62+ , _xhrResponse_responseText :: Maybe Text
6163 }
64+ deriving (Eq, Typeable)
65+
66+data XhrResponseType = XhrResponseType_ArrayBuffer
67+ | XhrResponseType_Blob
68+ | XhrResponseType_Document
69+ | XhrResponseType_JSON
70+ | XhrResponseType_Text
71+ | XhrResponseType_Other String
6272 deriving (Show, Read, Eq, Ord, Typeable)
6373
74+responseTypeString :: XhrResponseType -> String
75+responseTypeString rt = case rt of
76+ XhrResponseType_ArrayBuffer -> "arraybuffer"
77+ XhrResponseType_Blob -> "blob"
78+ XhrResponseType_Document -> "document"
79+ XhrResponseType_JSON -> "json"
80+ XhrResponseType_Text -> "text"
81+ XhrResponseType_Other r -> r
82+
83+{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}
84+_xhrResponse_body :: XhrResponse -> Maybe Text
85+_xhrResponse_body = _xhrResponse_responseText
86+
87+{-# DEPRECATED xhrResponse_body "Use xhrResponse_response or xhrResponse_responseText instead." #-}
88+xhrResponse_body :: Lens XhrResponse XhrResponse (Maybe Text) (Maybe Text)
89+xhrResponse_body = lens _xhrResponse_responseText (\r t -> r { _xhrResponse_responseText = t })
90+
6491instance Default XhrRequestConfig where
6592 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty
6693 , _xhrRequestConfig_user = Nothing
@@ -80,6 +107,7 @@ newXMLHttpRequest req cb = do
80107 liftIO $ do
81108 xhr <- xmlHttpRequestNew wv
82109 let c = _xhrRequest_config req
110+ rt = _xhrRequestConfig_responseType c
83111 xmlHttpRequestOpen
84112 xhr
85113 (_xhrRequest_method req)
@@ -88,15 +116,22 @@ newXMLHttpRequest req cb = do
88116 (fromMaybe "" $ _xhrRequestConfig_user c)
89117 (fromMaybe "" $ _xhrRequestConfig_password c)
90118 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
91− maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)
119+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType . responseTypeString) rt
92120 _ <- xmlHttpRequestOnreadystatechange xhr $ do
93121 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
94122 status <- liftIO $ xmlHttpRequestGetStatus xhr
95123 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
96124 if readyState == 4
97125 then do
98− r <- liftIO $ xmlHttpRequestGetResponseText xhr
99− _ <- liftIO $ postGui $ cb $ XhrResponse (responseTextToText r) status (statusTextToText statusText)
126+ t <- if rt == Just XhrResponseType_Text || rt == Nothing
127+ then liftIO $ xmlHttpRequestGetResponseText xhr
128+ else return Nothing
129+ r <- liftIO $ xmlHttpRequestGetResponse xhr
130+ _ <- liftIO $ postGui $ cb $ XhrResponse { _xhrResponse_status = status
131+ , _xhrResponse_statusText = statusTextToText statusText
132+ , _xhrResponse_response = r
133+ , _xhrResponse_responseText = responseTextToText t
134+ }
100135 return ()
101136 else return ()
102137 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
@@ -143,5 +178,5 @@ decodeText = decode . BL.fromStrict . encodeUtf8
143178
144179-- | Convenience function to decode JSON-encoded responses.
145180decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
146−decodeXhrResponse = join . fmap decodeText . _xhrResponse_body
181+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
147182