@@ -1,6 +1,8 @@
11{-# LANGUAGE QuasiQuotes, ForeignFunctionInterface #-}
2+
23module Reflex.Dom.Xhr.Foreign where
34
5+import Control.Monad
46import qualified Data.Text as T
57import Data.Text (Text)
68import System.Glib.FFI
@@ -9,11 +11,11 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
911import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
1012import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
1113import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
12−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
1314import Reflex.Dom.Xhr.ResponseType
1415import Reflex.Dom.Xhr.Exception
1516import Control.Concurrent.MVar
1617import Control.Exception.Base
18+import Graphics.UI.Gtk.WebKit.Types hiding (Text)
1719
1820import Reflex.Dom.Internal.Foreign
1921
@@ -25,23 +27,24 @@ data XMLHttpRequest
2527 }
2628 deriving (Eq, Ord)
2729
28−data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSValueRef }
29−
3030stringToJSValue :: JSContextRef -> String -> IO JSValueRef
3131stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s
3232
33−toResponseType :: XhrResponseType -> String
34−toResponseType XhrResponseType_Default = ""
35−toResponseType XhrResponseType_ArrayBuffer = "arraybuffer"
36−toResponseType XhrResponseType_Blob = "blob"
37−toResponseType XhrResponseType_Document = "document"
38−toResponseType XhrResponseType_JSON = "json"
39−toResponseType XhrResponseType_Text = "text"
33+fromResponseType :: XhrResponseType -> String
34+fromResponseType XhrResponseType_Default = ""
35+fromResponseType XhrResponseType_ArrayBuffer = "arraybuffer"
36+fromResponseType XhrResponseType_Blob = "blob"
37+fromResponseType XhrResponseType_Text = "text"
38+
39+toResponseType :: String -> Maybe XhrResponseType
40+toResponseType "" = Just XhrResponseType_Default
41+toResponseType "arraybuffer" = Just XhrResponseType_ArrayBuffer
42+toResponseType "blob" = Just XhrResponseType_Blob
43+toResponseType "text" = Just XhrResponseType_Text
44+toResponseType _ = Nothing
4045
4146xmlHttpRequestNew :: WebView -> IO XMLHttpRequest
42−xmlHttpRequestNew wv = do
43− wf <- webViewGetMainFrame wv
44− jsContext <- webFrameGetGlobalContext wf
47+xmlHttpRequestNew wv = withWebViewContext wv $ \jsContext -> do
4548 xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"
4649 xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr
4750 jsvalueprotect jsContext xhr'
@@ -80,31 +83,35 @@ xmlHttpRequestGetReadyState xhr = do
8083 d <- jsvaluetonumber c rs nullPtr
8184 return $ truncate d
8285
86+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)
87+xmlHttpRequestGetResponseType xhr = do
88+ script <- jsstringcreatewithutf8cstring "this.responseType"
89+ rt <- jsevaluatescript (xhrContext xhr) script (xhrValue xhr) nullPtr 1 nullPtr
90+ ms <- fromJSStringMaybe (xhrContext xhr) rt
91+ return $ join $ fmap toResponseType ms
92+
8393xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)
8494xmlHttpRequestGetResponse xhr = do
8595 let c = xhrContext xhr
96+ mrt <- xmlHttpRequestGetResponseType xhr
8697 script <- jsstringcreatewithutf8cstring "this.response"
8798 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
8899 isNull <- jsvalueisnull c t
89100 case isNull of
90101 True -> return Nothing
91− False -> return $ Just $ XhrResponseBody t
102+ False -> case mrt of
103+ Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t
104+ Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t
105+ Just XhrResponseType_Default -> fmap (XhrResponseBody_Default . T.pack) <$> fromJSStringMaybe c t
106+ Just XhrResponseType_Text -> fmap (XhrResponseBody_Text . T.pack) <$> fromJSStringMaybe c t
107+ _ -> return Nothing
92108
93109xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)
94110xmlHttpRequestGetResponseText xhr = do
95111 let c = xhrContext xhr
96112 script <- jsstringcreatewithutf8cstring "this.responseText"
97113 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
98− isNull <- jsvalueisnull c t
99− case isNull of
100− True -> return Nothing
101− False -> do
102− j <- jsvaluetostringcopy c t nullPtr
103− l <- jsstringgetmaximumutf8cstringsize j
104− s <- allocaBytes (fromIntegral l) $ \ps -> do
105− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
106− peekCString ps
107− return $ Just $ T.pack s
114+ fmap (fmap T.pack) $ fromJSStringMaybe c t
108115
109116xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO ()
110117xmlHttpRequestSend xhr payload = do