diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Tobias Dammers (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tobias Dammers nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# GHCJS-XHR + +XmlHttpRequest object for GHCJS. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghcjs-xhr.cabal b/ghcjs-xhr.cabal new file mode 100644 --- /dev/null +++ b/ghcjs-xhr.cabal @@ -0,0 +1,23 @@ +name: ghcjs-xhr +version: 0.1.0.0 +synopsis: XmlHttpRequest ("AJAX") bindings for GHCJS +description: Please see README.md +homepage: https://github.com/tdammers/ghcjs-xhr +license: BSD3 +license-file: LICENSE +author: Tobias Dammers +maintainer: tdammers@gmail.com +copyright: 2017 Tobias Dammers +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: JavaScript.XHR + build-depends: base >= 4.8 && <5 + , ghcjs-base >= 0.2 && <1 + , text >= 1.2.2.1 && <2 + js-sources: src/impl.js + default-language: Haskell2010 diff --git a/src/JavaScript/XHR.hs b/src/JavaScript/XHR.hs new file mode 100644 --- /dev/null +++ b/src/JavaScript/XHR.hs @@ -0,0 +1,65 @@ +{-#LANGUAGE JavaScriptFFI #-} +{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE LambdaCase #-} + +module JavaScript.XHR +( Method (..) +, XHR +, xhr +, getStatus +, getBody +, ajax +, get +) +where + +import Data.JSString +import Data.JSString.Text (textToJSString, textFromJSString) +import GHCJS.Types +import GHCJS.Marshal (ToJSVal(..), FromJSVal(..)) +import Data.Text (Text) +import Data.Maybe (fromMaybe) + +newtype XHR = XHR { unXHR :: JSVal } + +data Method = GET + | POST + deriving (Show, Eq, Enum, Ord) + +methodJSString :: Method -> JSString +methodJSString GET = "GET" +methodJSString POST = "POST" + +foreign import javascript interruptible + "ghcjs_xhr$ajax($1, $2, $3, $4, $c);" + js_ajax :: JSString -> JSString -> JSString -> JSString -> IO JSVal + +foreign import javascript + "ghcjs_xhr$xhrGetStatus($1)" + js_xhrGetStatus :: JSVal -> IO JSVal + +foreign import javascript + "ghcjs_xhr$xhrGetBody($1) || ''" + js_xhrGetBody :: JSVal -> IO JSString + +xhr :: Method -> Text -> Text -> Text -> IO XHR +xhr method url contentType body = do + let js_method = methodJSString method + js_url = textToJSString url + js_contentType = textToJSString contentType + js_body = textToJSString body + XHR <$> js_ajax js_method js_url js_contentType js_body + +getStatus :: XHR -> IO Int +getStatus xhr = fmap (fromMaybe 500) $ fromJSVal =<< js_xhrGetStatus (unXHR xhr) + +getBody :: XHR -> IO Text +getBody xhr = fmap textFromJSString $ js_xhrGetBody (unXHR xhr) + +ajax :: Method -> Text -> Text -> Text -> IO (Int, Text) +ajax method url contentType body = do + req <- xhr method url contentType body + (,) <$> getStatus req <*> getBody req + +get :: Text -> IO (Int, Text) +get url = ajax GET url "application/x-www-form-encoded" "" diff --git a/src/impl.js b/src/impl.js new file mode 100644 --- /dev/null +++ b/src/impl.js @@ -0,0 +1,49 @@ +function ghcjs_xhr$ajax(method, url, contentType, body, cont) { + xhr = ghcjs_xhr$createXMLHTTPObject(); + if (!xhr) { + cont({status: 500, response: "No XMLHttpRequest implementation found"}); + return; + } + xhr.open(method, url, true); + xhr.setRequestHeader('Content-type', contentType); + xhr.onreadystatechange = function() { + if (xhr.readyState === 4) { + cont(xhr); + } + } + if (body) { + xhr.send(body); + } + else { + xhr.send(); + } +} + +function ghcjs_xhr$xhrGetStatus(xhr) { + return xhr.status; +} + +function ghcjs_xhr$xhrGetBody(xhr) { + return xhr.response; +} + +var ghcjs_xhr$XMLHttpFactories = [ + function () { return new XMLHttpRequest(); }, + function () { return new ActiveXObject("Msxml2.XMLHTTP"); }, + function () { return new ActiveXObject("Msxml3.XMLHTTP"); }, + function () { return new ActiveXObject("Microsoft.XMLHTTP"); } +]; + +function ghcjs_xhr$createXMLHTTPObject() { + var xmlhttp = false; + for (var i=0; i