git.iko.soy/reflex-dom
on develop help sign in
Make it possible to access non-text response types in Reflex.Dom.Xhr
9007683Ali Abrar
src-ghc/Reflex/Dom/Xhr/Foreign.hs+13−1
compare with develop
unifiedsplit
@@ -1,7 +1,6 @@
1{-# LANGUAGE ForeignFunctionInterface #-}
1{-# LANGUAGE ForeignFunctionInterface #-}
2module Reflex.Dom.Xhr.Foreign where
2module Reflex.Dom.Xhr.Foreign where
3
3
4−import Control.Lens.Indexed
5import qualified Data.Text as T
4import qualified Data.Text as T
6import Data.Text (Text)
5import Data.Text (Text)
7import System.Glib.FFI
6import System.Glib.FFI
@@ -20,6 +19,9 @@ data XMLHttpRequest
20 }
19 }
21 deriving (Eq, Ord)
20 deriving (Eq, Ord)
22
21
22+data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSValueRef }
23+ deriving (Eq)
24+
23responseTextToText :: Maybe String -> Maybe Text
25responseTextToText :: Maybe String -> Maybe Text
24responseTextToText = fmap T.pack
26responseTextToText = fmap T.pack
25
27
@@ -74,6 +76,16 @@ xmlHttpRequestGetReadyState xhr = do
74 d <- jsvaluetonumber c rs nullPtr
76 d <- jsvaluetonumber c rs nullPtr
75 return $ truncate d
77 return $ truncate d
76
78
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+
77xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)
89xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)
78xmlHttpRequestGetResponseText xhr = do
90xmlHttpRequestGetResponseText xhr = do
79 let c = xhrContext xhr
91 let c = xhrContext xhr
src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+37−2
@@ -7,9 +7,7 @@ import GHCJS.Foreign
7import GHCJS.Marshal
7import GHCJS.Marshal
8import qualified Data.Text as T
8import qualified Data.Text as T
9import Data.Text (Text)
9import Data.Text (Text)
10−import Data.Word
11import GHCJS.DOM.Types hiding (Text)
10import GHCJS.DOM.Types hiding (Text)
12−import Control.Applicative ((<$>))
13import GHCJS.DOM.EventM
11import GHCJS.DOM.EventM
14import GHCJS.DOM
12import GHCJS.DOM
15import Data.Function
13import Data.Function
@@ -62,6 +60,34 @@ foreign import javascript unsafe "window[\"XMLHttpRequest\"]" gTypeXMLHttpReques
62gTypeXMLHttpRequest :: GType
60gTypeXMLHttpRequest :: GType
63gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'
61gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'
64
62
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'
65
91
66newtype XMLHttpRequestUpload = XMLHttpRequestUpload { unXMLHttpRequestUpload :: JSRef XMLHttpRequestUpload }
92newtype XMLHttpRequestUpload = XMLHttpRequestUpload { unXMLHttpRequestUpload :: JSRef XMLHttpRequestUpload }
67
93
@@ -312,6 +338,15 @@ xmlHttpRequestGetUpload self
312 (ghcjs_dom_xml_http_request_get_upload
338 (ghcjs_dom_xml_http_request_get_upload
313 (unXMLHttpRequest (toXMLHttpRequest self)))
339 (unXMLHttpRequest (toXMLHttpRequest self)))
314
340
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+
315foreign import javascript unsafe "$1[\"responseText\"]"
350foreign import javascript unsafe "$1[\"responseText\"]"
316 ghcjs_dom_xml_http_request_get_response_text ::
351 ghcjs_dom_xml_http_request_get_response_text ::
317 JSRef XMLHttpRequest -> IO JSString
352 JSRef XMLHttpRequest -> IO JSString
src/Reflex/Dom/Xhr.hs+24−6
@@ -3,6 +3,7 @@
3module Reflex.Dom.Xhr
3module Reflex.Dom.Xhr
4 ( module Reflex.Dom.Xhr
4 ( module Reflex.Dom.Xhr
5 , XMLHttpRequest
5 , XMLHttpRequest
6+ , XhrResponseBody(..)
6 , responseTextToText
7 , responseTextToText
7 , xmlHttpRequestGetReadyState
8 , xmlHttpRequestGetReadyState
8 , xmlHttpRequestGetResponseText
9 , xmlHttpRequestGetResponseText
@@ -55,11 +56,20 @@ data XhrRequestConfig
55 deriving (Show, Read, Eq, Ord, Typeable)
56 deriving (Show, Read, Eq, Ord, Typeable)
56
57
57data XhrResponse
58data XhrResponse
58− = XhrResponse { _xhrResponse_body :: Maybe Text
59− , _xhrResponse_status :: Word
59+ = XhrResponse { _xhrResponse_status :: Word
60 , _xhrResponse_statusText :: Text
60 , _xhrResponse_statusText :: Text
61+ , _xhrResponse_response :: Maybe XhrResponseBody
62+ , _xhrResponse_responseText :: Maybe Text
61 }
63 }
62− deriving (Show, Read, Eq, Ord, Typeable)
64+ deriving (Eq, Typeable)
65+
66+{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}
67+_xhrResponse_body :: XhrResponse -> Maybe Text
68+_xhrResponse_body = _xhrResponse_responseText
69+
70+{-# DEPRECATED xhrResponse_body "Use xhrResponse_response or xhrResponse_responseText instead." #-}
71+xhrResponse_body :: Lens XhrResponse XhrResponse (Maybe Text) (Maybe Text)
72+xhrResponse_body = lens _xhrResponse_responseText (\r t -> r { _xhrResponse_responseText = t })
63
73
64instance Default XhrRequestConfig where
74instance Default XhrRequestConfig where
65 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty
75 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty
@@ -80,6 +90,7 @@ newXMLHttpRequest req cb = do
80 liftIO $ do
90 liftIO $ do
81 xhr <- xmlHttpRequestNew wv
91 xhr <- xmlHttpRequestNew wv
82 let c = _xhrRequest_config req
92 let c = _xhrRequest_config req
93+ responseType = _xhrRequestConfig_responseType c
83 xmlHttpRequestOpen
94 xmlHttpRequestOpen
84 xhr
95 xhr
85 (_xhrRequest_method req)
96 (_xhrRequest_method req)
@@ -95,8 +106,15 @@ newXMLHttpRequest req cb = do
95 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
106 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
96 if readyState == 4
107 if readyState == 4
97 then do
108 then do
109+ t <- if responseType == Just "text" || responseType == Nothing
98− r <- liftIO $ xmlHttpRequestGetResponseText xhr
110+ then liftIO $ xmlHttpRequestGetResponseText xhr
111+ else return Nothing
112+ r <- liftIO $ xmlHttpRequestGetResponse xhr
99− _ <- liftIO $ postGui $ cb $ XhrResponse (responseTextToText r) status (statusTextToText statusText)
113+ _ <- liftIO $ postGui $ cb $ XhrResponse { _xhrResponse_status = status
114+ , _xhrResponse_statusText = statusTextToText statusText
115+ , _xhrResponse_response = r
116+ , _xhrResponse_responseText = responseTextToText t
117+ }
100 return ()
118 return ()
101 else return ()
119 else return ()
102 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
120 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
@@ -143,5 +161,5 @@ decodeText = decode . BL.fromStrict . encodeUtf8
143
161
144-- | Convenience function to decode JSON-encoded responses.
162-- | Convenience function to decode JSON-encoded responses.
145decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
163decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
146−decodeXhrResponse = join . fmap decodeText . _xhrResponse_body
164+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
147
165