9007683 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

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

commit9007683878db976be326b122fcbbe024aabbf785 authorAli Abrar <aliabrar@gmail.com> dateSat 9 Jan 2016, 23:32 (11 years ago) parent4ce94d0

3 files changed+74−9

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+24−6

src-ghc/Reflex/Dom/Xhr/Foreign.hs+13−1

@@ -1,7 +1,6 @@

11{-# LANGUAGE ForeignFunctionInterface #-}

22module Reflex.Dom.Xhr.Foreign where

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+24−6

@@ -3,6 +3,7 @@

33module Reflex.Dom.Xhr

44 ( module Reflex.Dom.Xhr

55 , XMLHttpRequest

6+ , XhrResponseBody(..)

67 , responseTextToText

78 , xmlHttpRequestGetReadyState

89 , xmlHttpRequestGetResponseText

@@ -55,11 +56,20 @@ data XhrRequestConfig

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 }

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 })

6373

6474instance Default XhrRequestConfig where

6575 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

@@ -80,6 +90,7 @@ newXMLHttpRequest req cb = do

8090 liftIO $ do

8191 xhr <- xmlHttpRequestNew wv

8292 let c = _xhrRequest_config req

93+ responseType = _xhrRequestConfig_responseType c

8394 xmlHttpRequestOpen

8495 xhr

8596 (_xhrRequest_method req)

@@ -95,8 +106,15 @@ newXMLHttpRequest req cb = do

95106 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

96107 if readyState == 4

97108 then do

98− r <- liftIO $ xmlHttpRequestGetResponseText xhr

99− _ <- liftIO $ postGui $ cb $ XhrResponse (responseTextToText r) status (statusTextToText statusText)

109+ t <- if responseType == Just "text" || responseType == Nothing

110+ then liftIO $ xmlHttpRequestGetResponseText xhr

111+ else return Nothing

112+ r <- liftIO $ xmlHttpRequestGetResponse xhr

113+ _ <- liftIO $ postGui $ cb $ XhrResponse { _xhrResponse_status = status

114+ , _xhrResponse_statusText = statusTextToText statusText

115+ , _xhrResponse_response = r

116+ , _xhrResponse_responseText = responseTextToText t

117+ }

100118 return ()

101119 else return ()

102120 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

@@ -143,5 +161,5 @@ decodeText = decode . BL.fromStrict . encodeUtf8

143161

144162-- | Convenience function to decode JSON-encoded responses.

145163decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

146−decodeXhrResponse = join . fmap decodeText . _xhrResponse_body

164+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

147165