git.iko.soy/reflex-dom
on develop help sign in
Merge pull request #42 from ryantrinkle/xhr-response-body
89cd4fdRyan Trinkle
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+42−7
@@ -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
@@ -49,18 +50,44 @@ data XhrRequestConfig
49 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String
50 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String
50 , _xhrRequestConfig_user :: Maybe String
51 , _xhrRequestConfig_user :: Maybe String
51 , _xhrRequestConfig_password :: Maybe String
52 , _xhrRequestConfig_password :: Maybe String
52− , _xhrRequestConfig_responseType :: Maybe String
53+ , _xhrRequestConfig_responseType :: Maybe XhrResponseType
53 , _xhrRequestConfig_sendData :: Maybe String
54 , _xhrRequestConfig_sendData :: Maybe String
54 }
55 }
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 }
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
62 deriving (Show, Read, Eq, Ord, Typeable)
72 deriving (Show, Read, Eq, Ord, Typeable)
63
73
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+
64instance Default XhrRequestConfig where
91instance Default XhrRequestConfig where
65 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty
92 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty
66 , _xhrRequestConfig_user = Nothing
93 , _xhrRequestConfig_user = Nothing
@@ -80,6 +107,7 @@ newXMLHttpRequest req cb = do
80 liftIO $ do
107 liftIO $ do
81 xhr <- xmlHttpRequestNew wv
108 xhr <- xmlHttpRequestNew wv
82 let c = _xhrRequest_config req
109 let c = _xhrRequest_config req
110+ rt = _xhrRequestConfig_responseType c
83 xmlHttpRequestOpen
111 xmlHttpRequestOpen
84 xhr
112 xhr
85 (_xhrRequest_method req)
113 (_xhrRequest_method req)
@@ -88,15 +116,22 @@ newXMLHttpRequest req cb = do
88 (fromMaybe "" $ _xhrRequestConfig_user c)
116 (fromMaybe "" $ _xhrRequestConfig_user c)
89 (fromMaybe "" $ _xhrRequestConfig_password c)
117 (fromMaybe "" $ _xhrRequestConfig_password c)
90 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
118 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
91− maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)
119+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType . responseTypeString) rt
92 _ <- xmlHttpRequestOnreadystatechange xhr $ do
120 _ <- xmlHttpRequestOnreadystatechange xhr $ do
93 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
121 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
94 status <- liftIO $ xmlHttpRequestGetStatus xhr
122 status <- liftIO $ xmlHttpRequestGetStatus xhr
95 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
123 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
96 if readyState == 4
124 if readyState == 4
97 then do
125 then do
126+ t <- if rt == Just XhrResponseType_Text || rt == Nothing
98− r <- liftIO $ xmlHttpRequestGetResponseText xhr
127+ then liftIO $ xmlHttpRequestGetResponseText xhr
128+ else return Nothing
129+ r <- liftIO $ xmlHttpRequestGetResponse xhr
99− _ <- liftIO $ postGui $ cb $ XhrResponse (responseTextToText r) status (statusTextToText statusText)
130+ _ <- liftIO $ postGui $ cb $ XhrResponse { _xhrResponse_status = status
131+ , _xhrResponse_statusText = statusTextToText statusText
132+ , _xhrResponse_response = r
133+ , _xhrResponse_responseText = responseTextToText t
134+ }
100 return ()
135 return ()
101 else return ()
136 else return ()
102 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
137 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
@@ -143,5 +178,5 @@ decodeText = decode . BL.fromStrict . encodeUtf8
143
178
144-- | Convenience function to decode JSON-encoded responses.
179-- | Convenience function to decode JSON-encoded responses.
145decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
180decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
146−decodeXhrResponse = join . fmap decodeText . _xhrResponse_body
181+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
147
182