@@ -3,6 +3,7 @@ module Reflex.Dom.Xhr.Foreign ( module Reflex.Dom.Xhr.Foreign
33 , XhrResponseType
44 ) where
55
6+import Control.Monad
67import qualified Data.Text as T
78import Data.Text (Text)
89import System.Glib.FFI
@@ -17,6 +18,7 @@ import Reflex.Dom.Xhr.ResponseType
1718import Reflex.Dom.Xhr.Exception
1819import Control.Concurrent.MVar
1920import Control.Exception.Base
21+import Graphics.UI.Gtk.WebKit.Types hiding (Text)
2022
2123import Reflex.Dom.Internal.Foreign
2224
@@ -28,23 +30,36 @@ data XMLHttpRequest
2830 }
2931 deriving (Eq, Ord)
3032
31−data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSValueRef }
33+class IsXhrPayload a where
34+ xmlHttpRequestSend :: XMLHttpRequest -> a -> IO ()
35+
36+instance IsXhrPayload () where
37+ xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr Nothing
38+
39+instance IsXhrPayload String where
40+ xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just
41+
42+instance IsXhrPayload File where
43+ xmlHttpRequestSend = error "xmlHttpRequestSend{File}: not implemented"
3244
3345stringToJSValue :: JSContextRef -> String -> IO JSValueRef
3446stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s
3547
36−toResponseType :: XhrResponseType -> String
37−toResponseType XhrResponseType_Default = ""
38−toResponseType XhrResponseType_ArrayBuffer = "arraybuffer"
39−toResponseType XhrResponseType_Blob = "blob"
40−toResponseType XhrResponseType_Document = "document"
41−toResponseType XhrResponseType_JSON = "json"
42−toResponseType XhrResponseType_Text = "text"
48+fromResponseType :: XhrResponseType -> String
49+fromResponseType XhrResponseType_Default = ""
50+fromResponseType XhrResponseType_ArrayBuffer = "arraybuffer"
51+fromResponseType XhrResponseType_Blob = "blob"
52+fromResponseType XhrResponseType_Text = "text"
53+
54+toResponseType :: String -> Maybe XhrResponseType
55+toResponseType "" = Just XhrResponseType_Default
56+toResponseType "arraybuffer" = Just XhrResponseType_ArrayBuffer
57+toResponseType "blob" = Just XhrResponseType_Blob
58+toResponseType "text" = Just XhrResponseType_Text
59+toResponseType _ = Nothing
4360
4461xmlHttpRequestNew :: WebView -> IO XMLHttpRequest
45−xmlHttpRequestNew wv = do
46− wf <- webViewGetMainFrame wv
47− jsContext <- webFrameGetGlobalContext wf
62+xmlHttpRequestNew wv = withWebViewContext wv $ \jsContext -> do
4863 xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"
4964 xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr
5065 jsvalueprotect jsContext xhr'
@@ -83,43 +98,35 @@ xmlHttpRequestGetReadyState xhr = do
8398 d <- jsvaluetonumber c rs nullPtr
8499 return $ truncate d
85100
101+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)
102+xmlHttpRequestGetResponseType xhr = do
103+ script <- jsstringcreatewithutf8cstring "this.responseType"
104+ rt <- jsevaluatescript (xhrContext xhr) script (xhrValue xhr) nullPtr 1 nullPtr
105+ ms <- fromJSStringMaybe (xhrContext xhr) rt
106+ return $ join $ fmap toResponseType ms
107+
86108xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)
87109xmlHttpRequestGetResponse xhr = do
88110 let c = xhrContext xhr
111+ mrt <- xmlHttpRequestGetResponseType xhr
89112 script <- jsstringcreatewithutf8cstring "this.response"
90113 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
91114 isNull <- jsvalueisnull c t
92115 case isNull of
93116 True -> return Nothing
94− False -> return $ Just $ XhrResponseBody t
117+ False -> case mrt of
118+ Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t
119+ Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t
120+ Just XhrResponseType_Default -> fmap (XhrResponseBody_Default . T.pack) <$> fromJSStringMaybe c t
121+ Just XhrResponseType_Text -> fmap (XhrResponseBody_Text . T.pack) <$> fromJSStringMaybe c t
122+ _ -> return Nothing
95123
96124xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)
97125xmlHttpRequestGetResponseText xhr = do
98126 let c = xhrContext xhr
99127 script <- jsstringcreatewithutf8cstring "this.responseText"
100128 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
101− isNull <- jsvalueisnull c t
102− case isNull of
103− True -> return Nothing
104− False -> do
105− j <- jsvaluetostringcopy c t nullPtr
106− l <- jsstringgetmaximumutf8cstringsize j
107− s <- allocaBytes (fromIntegral l) $ \ps -> do
108− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
109− peekCString ps
110− return $ Just $ T.pack s
111−
112−class IsXhrPayload a where
113− xmlHttpRequestSend :: XMLHttpRequest -> a -> IO ()
114−
115−instance IsXhrPayload () where
116− xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr Nothing
117−
118−instance IsXhrPayload String where
119− xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just
120−
121−instance IsXhrPayload File where
122− xmlHttpRequestSend = error "xmlHttpRequestSend{File}: not implemented"
129+ fmap (fmap T.pack) $ fromJSStringMaybe c t
123130
124131xmlHttpRequestSendPayload :: XMLHttpRequest -> Maybe String -> IO ()
125132xmlHttpRequestSendPayload xhr payload = do