ghcjs-xhr (empty) → 0.1.0.0

raw patch · 6 files changed

+172/−0 lines, 6 filesdep +basedep +ghcjs-basedep +textsetup-changed

Dependencies added: base, ghcjs-base, text

Files

• LICENSE +30/−0
• README.md +3/−0
• Setup.hs +2/−0
• ghcjs-xhr.cabal +23/−0
• src/JavaScript/XHR.hs +65/−0
• src/impl.js +49/−0

@@ -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.

@@ -0,0 +1,3 @@+# GHCJS-XHR++XmlHttpRequest object for GHCJS.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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

@@ -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" ""

@@ -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<ghcjs_xhr$XMLHttpFactories.length; i++) {+        try {+            xmlhttp = ghcjs_xhr$XMLHttpFactories[i]();+        }+        catch (e) {+            continue;+        }+        break;+    }+    return xmlhttp;+}