module Reflex.Dom.Xhr.Foreign where
import Control.Monad
import qualified Data.Text as T
import Data.Text (Text)
import System.Glib.FFI
import Graphics.UI.Gtk.WebKit.WebView
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
import Reflex.Dom.Xhr.ResponseType
import Reflex.Dom.Xhr.Exception
import Control.Concurrent.MVar
import Control.Exception.Base
import Graphics.UI.Gtk.WebKit.Types hiding (Text)
import Reflex.Dom.Internal.Foreign
import Text.RawString.QQ
data XMLHttpRequest
= XMLHttpRequest { xhrValue :: JSValueRef
, xhrContext :: JSContextRef
}
deriving (Eq, Ord)
stringToJSValue :: JSContextRef -> String -> IO JSValueRef
stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s
fromResponseType :: XhrResponseType -> String
fromResponseType XhrResponseType_Default = ""
fromResponseType XhrResponseType_ArrayBuffer = "arraybuffer"
fromResponseType XhrResponseType_Blob = "blob"
fromResponseType XhrResponseType_Text = "text"
toResponseType :: String -> Maybe XhrResponseType
toResponseType "" = Just XhrResponseType_Default
toResponseType "arraybuffer" = Just XhrResponseType_ArrayBuffer
toResponseType "blob" = Just XhrResponseType_Blob
toResponseType "text" = Just XhrResponseType_Text
toResponseType _ = Nothing
xmlHttpRequestNew :: WebView -> IO XMLHttpRequest
xmlHttpRequestNew wv = withWebViewContext wv $ \jsContext -> do
xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"
xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr
jsvalueprotect jsContext xhr'
return $ XMLHttpRequest xhr' jsContext
xmlHttpRequestOpen :: XMLHttpRequest -> String -> String -> Bool -> String -> String -> IO ()
xmlHttpRequestOpen xhr method url async user password = do
let c = xhrContext xhr
method' <- stringToJSValue c method
url' <- stringToJSValue c url
async' <- jsvaluemakeboolean (xhrContext xhr) async
user' <- stringToJSValue c user
password' <- stringToJSValue c password
o <- toJSObject c [xhrValue xhr, method', url', async', user', password']
script <- jsstringcreatewithutf8cstring "this[0].open(this[1], this[2], this[3], this[4], this[5])"
_ <- jsevaluatescript c script o nullPtr 1 nullPtr
return ()
xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO ()
xmlHttpRequestOnreadystatechange xhr userCallback = do
let c = xhrContext xhr
fp <- wrapper $ \_ _ _ _ _ _ -> do
userCallback
jsvaluemakeundefined c
cb <- jsobjectmakefunctionwithcallback c nullPtr fp
o <- toJSObject c [xhrValue xhr, cb]
script <- jsstringcreatewithutf8cstring "this[0].onreadystatechange=this[1]"
_ <- jsevaluatescript c script o nullPtr 1 nullPtr
return ()
xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word
xmlHttpRequestGetReadyState xhr = do
let c = xhrContext xhr
script <- jsstringcreatewithutf8cstring "this.readyState"
rs <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
d <- jsvaluetonumber c rs nullPtr
return $ truncate d
xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)
xmlHttpRequestGetResponseType xhr = do
script <- jsstringcreatewithutf8cstring "this.responseType"
rt <- jsevaluatescript (xhrContext xhr) script (xhrValue xhr) nullPtr 1 nullPtr
ms <- fromJSStringMaybe (xhrContext xhr) rt
return $ join $ fmap toResponseType ms
xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)
xmlHttpRequestGetResponse xhr = do
let c = xhrContext xhr
mrt <- xmlHttpRequestGetResponseType xhr
script <- jsstringcreatewithutf8cstring "this.response"
t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
isNull <- jsvalueisnull c t
case isNull of
True -> return Nothing
False -> case mrt of
Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t
Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t
Just XhrResponseType_Default -> fmap (XhrResponseBody_Default . T.pack) <$> fromJSStringMaybe c t
Just XhrResponseType_Text -> fmap (XhrResponseBody_Text . T.pack) <$> fromJSStringMaybe c t
_ -> return Nothing
xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)
xmlHttpRequestGetResponseText xhr = do
let c = xhrContext xhr
script <- jsstringcreatewithutf8cstring "this.responseText"
t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
fmap (fmap T.pack) $ fromJSStringMaybe c t
xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO ()
xmlHttpRequestSend xhr payload = do
let c = xhrContext xhr
result <- newEmptyMVar
let wrapper' x = wrapper $ \_ _ _ _ _ _ -> putMVar result x >> jsvaluemakeundefined c
bracket (wrapper' $ Just XhrException_Aborted) freeHaskellFunPtr $ \a -> do
onAbort <- jsobjectmakefunctionwithcallback c nullPtr a
bracket (wrapper' $ Just XhrException_Error) freeHaskellFunPtr $ \e -> do
onError <- jsobjectmakefunctionwithcallback c nullPtr e
bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do
onLoad <- jsobjectmakefunctionwithcallback c nullPtr l
(o,s) <- case payload of
Nothing -> do
d <- jsvaluemakeundefined c
o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]
s <- jsstringcreatewithutf8cstring send
return (o,s)
Just payload' -> do
d <- stringToJSValue c payload'
o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]
s <- jsstringcreatewithutf8cstring send
return (o,s)
_ <- jsevaluatescript c s o nullPtr 1 nullPtr
takeMVar result >>= mapM_ throwIO
where
send = [r|
(function (xhr, d, onError, onAbort, onLoad) {
var clear;
var error = function () {
clear(); onError();
};
var abort = function () {
clear(); onAbort();
};
var load = function () {
clear(); onLoad();
};
clear = function () {
xhr.removeEventListener('error', error);
xhr.removeEventListener('abort', abort);
xhr.removeEventListener('load', load);
}
xhr.addEventListener('error', error);
xhr.addEventListener('abort', abort);
xhr.addEventListener('load', load);
if(d) {
xhr.send(d);
} else {
xhr.send();
}
})(this[0], this[1], this[2], this[3], this[4])
|]
xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO ()
xmlHttpRequestSetRequestHeader xhr header value = do
let c = xhrContext xhr
header' <- stringToJSValue c header
value' <- stringToJSValue c value
o <- toJSObject c [xhrValue xhr, header', value']
script <- jsstringcreatewithutf8cstring "this[0].setRequestHeader(this[1], this[2])"
_ <- jsevaluatescript c script o nullPtr 1 nullPtr
return ()
xmlHttpRequestSetResponseType :: XMLHttpRequest -> String -> IO ()
xmlHttpRequestSetResponseType xhr t = do
let c = xhrContext xhr
t' <- stringToJSValue c t
o <- toJSObject c [xhrValue xhr, t']
script <- jsstringcreatewithutf8cstring "this[0].responseType = this[1]"
_ <- jsevaluatescript c script o nullPtr 1 nullPtr
return ()
xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word
xmlHttpRequestGetStatus xhr = do
let c = xhrContext xhr
script <- jsstringcreatewithutf8cstring "this.status"
s <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
d <- jsvaluetonumber c s nullPtr
return $ truncate d
xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text
xmlHttpRequestGetStatusText xhr = do
let c = xhrContext xhr
script <- jsstringcreatewithutf8cstring "this.statusText"
t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
j <- jsvaluetostringcopy c t nullPtr
l <- jsstringgetmaximumutf8cstringsize j
s <- allocaBytes (fromIntegral l) $ \ps -> do
_ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
peekCString ps
return $ T.pack s