ajaxExamples.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import           Control.Concurrent
import qualified Control.Exception as E
import           Control.Monad

import           Data.Monoid
import qualified Data.Text.Lazy    as TL
import qualified Data.Text.Lazy.IO as TL

import           System.IO

import           XHRDemo

main = demo1 >> demo2 >> demo3 >> demo4

-- | get a lazy result from the server, print it line by line while its coming in
demo1 =
  mapM_ (TL.putStrLn . ("- "<>)) . TL.lines =<< xhrGetLazyText "http://localhost:4321"

-- | wait for the request to complete while printing progress messages
demo2 = do
  print =<< xhrText GET "http://localhost:4321" [] Nothing Nothing Nothing
             (Just $ \k n _ -> putStrLn ("received " ++ show n ++
                                         " bytes out of " ++ maybe "<unknown>" show k))

-- | abort a request with an exception, connection is closed
demo3 = do
  hSetBuffering stdout NoBuffering
  let doXhr c = xhrText GET "http://localhost:4321" []
                   Nothing Nothing Nothing (Just $ \_ _ _ -> putStr c)
  t1 <- forkIO (void $ doXhr "o")
  threadDelay 5000000
  throwTo t1 E.ThreadKilled
  putStrLn "\nstarting new request"
  print =<< doXhr "x"

-- | consume part of the lazy result. connections are closed early automatically
demo4 = do
  TL.putStrLn . TL.take 200 =<< xhrGetLazyText "http://localhost:4321"
  threadDelay 5000000
  TL.putStrLn . TL.take 400 =<< xhrGetLazyText "http://localhost:4321"
  threadDelay 5000000

testSrv.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Blaze.ByteString.Builder.Char8

import Control.Concurrent hiding (yield)
import Control.Exception (bracket)
import Control.Monad
import Control.Monad.IO.Class

import Data.Conduit
import Data.IORef

import Network.HTTP.Types

import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Internal

import System.IO

{- |
  a test server that listens on port 4321, returns a 1000
  byte response for every request, slowly, with 10 bytes at a time.
-}

main = do
  hSetBuffering stdout LineBuffering
  cid <- newIORef 1
  run 4321 $ \_ -> return $
    ResponseSource status200 [("Content-Length", "1000")
                             ,("Content-Type", "application/octet-stream")] $
      \f -> bracket
              (atomicModifyIORef cid (\x -> (x+1, x)) >>=
                \c -> putStrLn ("connection " ++ show c ++ " opened") >> return c)
              (\c -> putStrLn $ "connection " ++ show c ++ " closed")
              (\c -> f $ forM_ [1..100] $ \n -> do
                        let n'    = show n
                        liftIO (putStrLn $ "connection " ++ show c ++ " - " ++ n')
                        yield (Chunk . fromString $ replicate (9-length n') '0' ++ n' ++ "\n")
                        yield Flush
                        liftIO (threadDelay 200000)
              )

xhr.js

// include this file to test with node.js

// Generated by CoffeeScript 1.7.1
var XMLHttpRequestEventTarget;

XMLHttpRequestEventTarget = (function() {
  function XMLHttpRequestEventTarget() {
    this.onloadstart = null;
    this.onprogress = null;
    this.onabort = null;
    this.onerror = null;
    this.onload = null;
    this.ontimeout = null;
    this.onloadend = null;
    this._listeners = {};
  }

  XMLHttpRequestEventTarget.prototype.onloadstart = null;

  XMLHttpRequestEventTarget.prototype.onprogress = null;

  XMLHttpRequestEventTarget.prototype.onabort = null;

  XMLHttpRequestEventTarget.prototype.onerror = null;

  XMLHttpRequestEventTarget.prototype.onload = null;

  XMLHttpRequestEventTarget.prototype.ontimeout = null;

  XMLHttpRequestEventTarget.prototype.onloadend = null;

  XMLHttpRequestEventTarget.prototype.addEventListener = function(eventType, listener) {
    var _base;
    eventType = eventType.toLowerCase();
    (_base = this._listeners)[eventType] || (_base[eventType] = []);
    this._listeners[eventType].push(listener);
    return void 0;
  };

  XMLHttpRequestEventTarget.prototype.removeEventListener = function(eventType, listener) {
    var index;
    eventType = eventType.toLowerCase();
    if (this._listeners[eventType]) {
      index = this._listeners[eventType].indexOf(listener);
      if (index !== -1) {
        this._listeners.splice(index, 1);
      }
    }
    return void 0;
  };

  XMLHttpRequestEventTarget.prototype.dispatchEvent = function(event) {
    var eventType, listener, listeners, _i, _len;
    eventType = event.type;
    if (listeners = this._listeners[eventType]) {
      for (_i = 0, _len = listeners.length; _i < _len; _i++) {
        listener = listeners[_i];
        listener(event);
      }
    }
    if (listener = this["on" + eventType]) {
      listener(event);
    }
    return void 0;
  };

  return XMLHttpRequestEventTarget;

})();
// Generated by CoffeeScript 1.7.1
var XMLHttpRequest, http, https, os, url,
  __hasProp = {}.hasOwnProperty,
  __extends = function(child, parent) { for (var key in parent) { if (__hasProp.call(parent, key)) child[key] = parent[key]; } function ctor() { this.constructor = child; } ctor.prototype = parent.prototype; child.prototype = new ctor(); child.__super__ = parent.prototype; return child; };

http = require('http');

https = require('https');

os = require('os');

url = require('url');

XMLHttpRequest = (function(_super) {
  __extends(XMLHttpRequest, _super);

  function XMLHttpRequest(options) {
    XMLHttpRequest.__super__.constructor.call(this);
    this.onreadystatechange = null;
    this._anonymous = options && options.anon;
    this.readyState = XMLHttpRequest.UNSENT;
    this.response = null;
    this.responseText = '';
    this.responseType = '';
    this.status = 0;
    this.statusText = '';
    this.timeout = 0;
    this.upload = new XMLHttpRequestUpload(this);
    this._method = null;
    this._url = null;
    this._sync = false;
    this._headers = null;
    this._loweredHeaders = null;
    this._mimeOverride = null;
    this._request = null;
    this._response = null;
    this._responseParts = null;
    this._responseHeaders = null;
    this._aborting = null;
    this._error = null;
    this._loadedBytes = 0;
    this._totalBytes = 0;
    this._lengthComputable = false;
  }

  XMLHttpRequest.prototype.onreadystatechange = null;

  XMLHttpRequest.prototype.readyState = null;

  XMLHttpRequest.prototype.response = null;

  XMLHttpRequest.prototype.responseText = null;

  XMLHttpRequest.prototype.responseType = null;

  XMLHttpRequest.prototype.status = null;

  XMLHttpRequest.prototype.timeout = null;

  XMLHttpRequest.prototype.upload = null;

  XMLHttpRequest.prototype.open = function(method, url, async, user, password) {
    var xhrUrl;
    method = method.toUpperCase();
    if (method in this._restrictedMethods) {
      throw new SecurityError("HTTP method " + method + " is not allowed in XHR");
    }
    xhrUrl = this._parseUrl(url);
    if (async === void 0) {
      async = true;
    }
    switch (this.readyState) {
      case XMLHttpRequest.UNSENT:
      case XMLHttpRequest.OPENED:
      case XMLHttpRequest.DONE:
        null;
        break;
      case XMLHttpRequest.HEADERS_RECEIVED:
      case XMLHttpRequest.LOADING:
        null;
    }
    this._method = method;
    this._url = xhrUrl;
    this._sync = !async;
    this._headers = {};
    this._loweredHeaders = {};
    this._mimeOverride = null;
    this._setReadyState(XMLHttpRequest.OPENED);
    this._request = null;
    this._response = null;
    this.status = 0;
    this.statusText = '';
    this._responseParts = [];
    this._responseHeaders = null;
    this._loadedBytes = 0;
    this._totalBytes = 0;
    this._lengthComputable = false;
    return void 0;
  };

  XMLHttpRequest.prototype.setRequestHeader = function(name, value) {
    var loweredName;
    if (this.readyState !== XMLHttpRequest.OPENED) {
      throw new InvalidStateError("XHR readyState must be OPENED");
    }
    loweredName = name.toLowerCase();
    if (this._restrictedHeaders[loweredName] || /^sec\-/.test(loweredName) || /^proxy-/.test(loweredName)) {
      console.warn("Refused to set unsafe header \"" + name + "\"");
      return void 0;
    }
    value = value.toString();
    if (loweredName in this._loweredHeaders) {
      name = this._loweredHeaders[loweredName];
      this._headers[name] = this._headers[name] + ', ' + value;
    } else {
      this._loweredHeaders[loweredName] = name;
      this._headers[name] = value;
    }
    return void 0;
  };

  XMLHttpRequest.prototype.send = function(data) {
    if (this.readyState !== XMLHttpRequest.OPENED) {
      throw new InvalidStateError("XHR readyState must be OPENED");
    }
    if (this._request) {
      throw new InvalidStateError("send() already called");
    }
    switch (this._url.protocol) {
      case 'file:':
        this._sendFile(data);
        break;
      case 'http:':
      case 'https:':
        this._sendHttp(data);
        break;
      default:
        throw new NetworkError("Unsupported protocol " + this._url.protocol);
    }
    return void 0;
  };

  XMLHttpRequest.prototype.abort = function() {
    if (!this._request) {
      return;
    }
    this._request.abort();
    this._setError();
    this._dispatchProgress('abort');
    this._dispatchProgress('loadend');
    return void 0;
  };

  XMLHttpRequest.prototype.getResponseHeader = function(name) {
    var loweredName;
    if (!this._responseHeaders) {
      return null;
    }
    loweredName = name.toLowerCase();
    if (loweredName in this._responseHeaders) {
      return this._responseHeaders[loweredName];
    } else {
      return null;
    }
  };

  XMLHttpRequest.prototype.getAllResponseHeaders = function() {
    var lines, name, value;
    if (!this._responseHeaders) {
      return '';
    }
    lines = (function() {
      var _ref, _results;
      _ref = this._responseHeaders;
      _results = [];
      for (name in _ref) {
        value = _ref[name];
        _results.push("" + name + ": " + value);
      }
      return _results;
    }).call(this);
    return lines.join("\r\n");
  };

  XMLHttpRequest.prototype.overrideMimeType = function(newMimeType) {
    if (this.readyState === XMLHttpRequest.LOADING || this.readyState === XMLHttpRequest.DONE) {
      throw new InvalidStateError("overrideMimeType() not allowed in LOADING or DONE");
    }
    this._mimeOverride = newMimeType.toLowerCase();
    return void 0;
  };

  XMLHttpRequest.prototype.nodejsSet = function(options) {
    if ('httpAgent' in options) {
      this.nodejsHttpAgent = options.httpAgent;
    }
    if ('httpsAgent' in options) {
      this.nodejsHttpsAgent = options.httpsAgent;
    }
    return void 0;
  };

  XMLHttpRequest.nodejsSet = function(options) {
    XMLHttpRequest.prototype.nodejsSet(options);
    return void 0;
  };

  XMLHttpRequest.prototype.UNSENT = 0;

  XMLHttpRequest.UNSENT = 0;

  XMLHttpRequest.prototype.OPENED = 1;

  XMLHttpRequest.OPENED = 1;

  XMLHttpRequest.prototype.HEADERS_RECEIVED = 2;

  XMLHttpRequest.HEADERS_RECEIVED = 2;

  XMLHttpRequest.prototype.LOADING = 3;

  XMLHttpRequest.LOADING = 3;

  XMLHttpRequest.prototype.DONE = 4;

  XMLHttpRequest.DONE = 4;

  XMLHttpRequest.prototype.nodejsHttpAgent = http.globalAgent;

  XMLHttpRequest.prototype.nodejsHttpsAgent = https.globalAgent;

  XMLHttpRequest.prototype._restrictedMethods = {
    CONNECT: true,
    TRACE: true,
    TRACK: true
  };

  XMLHttpRequest.prototype._restrictedHeaders = {
    'accept-charset': true,
    'accept-encoding': true,
    'access-control-request-headers': true,
    'access-control-request-method': true,
    connection: true,
    'content-length': true,
    cookie: true,
    cookie2: true,
    date: true,
    dnt: true,
    expect: true,
    host: true,
    'keep-alive': true,
    origin: true,
    referer: true,
    te: true,
    trailer: true,
    'transfer-encoding': true,
    upgrade: true,
    'user-agent': true,
    via: true
  };

  XMLHttpRequest.prototype._privateHeaders = {
    'set-cookie': true,
    'set-cookie2': true
  };

  XMLHttpRequest.prototype._userAgent = ("Mozilla/5.0 (" + (os.type()) + " " + (os.arch()) + ") ") + ("node.js/" + process.versions.node + " v8/" + process.versions.v8);

  XMLHttpRequest.prototype._setReadyState = function(newReadyState) {
    var event;
    this.readyState = newReadyState;
    event = new XMLHttpRequestProgressEvent('readystatechange', this);
    this.dispatchEvent(event);
    return void 0;
  };

  XMLHttpRequest.prototype._sendFile = function() {
    if (this._url.method !== 'GET') {
      throw new NetworkError('The file protocol only supports GET');
    }
    throw new Error("Protocol file: not implemented");
  };

  XMLHttpRequest.prototype._sendHttp = function(data) {
    if (this._sync) {
      throw new Error("Synchronous XHR processing not implemented");
    }
    if ((data != null) && (this._method === 'GET' || this._method === 'HEAD')) {
      console.warn("Discarding entity body for " + this._method + " requests");
      data = null;
    } else {
      data || (data = '');
    }
    this.upload._setData(data);
    this._finalizeHeaders();
    this._sendHxxpRequest();
    return void 0;
  };

  XMLHttpRequest.prototype._sendHxxpRequest = function() {
    var agent, hxxp, request;
    if (this._url.protocol === 'http:') {
      hxxp = http;
      agent = this.nodejsHttpAgent;
    } else {
      hxxp = https;
      agent = this.nodejsHttpsAgent;
    }
    request = hxxp.request({
      hostname: this._url.hostname,
      port: this._url.port,
      path: this._url.path,
      auth: this._url.auth,
      method: this._method,
      headers: this._headers,
      agent: agent
    });
    this._request = request;
    if (this.timeout) {
      request.setTimeout(this.timeout, (function(_this) {
        return function() {
          return _this._onHttpTimeout(request);
        };
      })(this));
    }
    request.on('response', (function(_this) {
      return function(response) {
        return _this._onHttpResponse(request, response);
      };
    })(this));
    request.on('error', (function(_this) {
      return function(error) {
        return _this._onHttpRequestError(request, error);
      };
    })(this));
    this.upload._startUpload(request);
    if (this._request === request) {
      this._dispatchProgress('loadstart');
    }
    return void 0;
  };

  XMLHttpRequest.prototype._finalizeHeaders = function() {
    this._headers['Connection'] = 'keep-alive';
    this._headers['Host'] = this._url.host;
    if (this._anonymous) {
      this._headers['Referer'] = 'about:blank';
    }
    this._headers['User-Agent'] = this._userAgent;
    this.upload._finalizeHeaders(this._headers, this._loweredHeaders);
    return void 0;
  };

  XMLHttpRequest.prototype._onHttpResponse = function(request, response) {
    var lengthString;
    if (this._request !== request) {
      return;
    }
    switch (response.statusCode) {
      case 301:
      case 302:
      case 303:
      case 307:
      case 308:
        this._url = this._parseUrl(response.headers['location']);
        this._method = 'GET';
        if ('content-type' in this._loweredHeaders) {
          delete this._headers[this._loweredHeaders['content-type']];
          delete this._loweredHeaders['content-type'];
        }
        if ('Content-Type' in this._headers) {
          delete this._headers['Content-Type'];
        }
        delete this._headers['Content-Length'];
        this.upload._reset();
        this._finalizeHeaders();
        this._sendHxxpRequest();
        return;
    }
    this._response = response;
    this._response.on('data', (function(_this) {
      return function(data) {
        return _this._onHttpResponseData(response, data);
      };
    })(this));
    this._response.on('end', (function(_this) {
      return function() {
        return _this._onHttpResponseEnd(response);
      };
    })(this));
    this._response.on('close', (function(_this) {
      return function() {
        return _this._onHttpResponseClose(response);
      };
    })(this));
    this.status = this._response.statusCode;
    this.statusText = http.STATUS_CODES[this.status];
    this._parseResponseHeaders(response);
    if (lengthString = this._responseHeaders['content-length']) {
      this._totalBytes = parseInt(lengthString);
      this._lengthComputable = true;
    } else {
      this._lengthComputable = false;
    }
    return this._setReadyState(XMLHttpRequest.HEADERS_RECEIVED);
  };

  XMLHttpRequest.prototype._onHttpResponseData = function(response, data) {
    if (this._response !== response) {
      return;
    }
    this._responseParts.push(data);
    if (Buffer.concat) {
      this._parseTextResponse(Buffer.concat(this._responseParts));
    } else {
      this._parseTextResponse(this._concatBuffers(this._responseParts));
    }
    this._loadedBytes += data.length;
    if (this.readyState !== XMLHttpRequest.LOADING) {
      this._setReadyState(XMLHttpRequest.LOADING);
    }
    return this._dispatchProgress('progress');
  };

  XMLHttpRequest.prototype._onHttpResponseEnd = function(response) {
    if (this._response !== response) {
      return;
    }
    this._parseResponse();
    this._request = null;
    this._response = null;
    this._setReadyState(XMLHttpRequest.DONE);
    this._dispatchProgress('load');
    return this._dispatchProgress('loadend');
  };

  XMLHttpRequest.prototype._onHttpResponseClose = function(response) {
    var request;
    if (this._response !== response) {
      return;
    }
    request = this._request;
    this._setError();
    request.abort();
    this._setReadyState(XMLHttpRequest.DONE);
    this._dispatchProgress('error');
    return this._dispatchProgress('loadend');
  };

  XMLHttpRequest.prototype._onHttpTimeout = function(request) {
    if (this._request !== request) {
      return;
    }
    this._setError();
    request.abort();
    this._setReadyState(XMLHttpRequest.DONE);
    this._dispatchProgress('timeout');
    return this._dispatchProgress('loadend');
  };

  XMLHttpRequest.prototype._onHttpRequestError = function(request, error) {
    if (this._request !== request) {
      return;
    }
    this._setError();
    request.abort();
    this._setReadyState(XMLHttpRequest.DONE);
    this._dispatchProgress('error');
    return this._dispatchProgress('loadend');
  };

  XMLHttpRequest.prototype._dispatchProgress = function(eventType) {
    var event;
    event = new XMLHttpRequestProgressEvent(eventType, this);
    event.lengthComputable = this._lengthComputable;
    event.loaded = this._loadedBytes;
    event.total = this._totalBytes;
    this.dispatchEvent(event);
    return void 0;
  };

  XMLHttpRequest.prototype._setError = function() {
    this._request = null;
    this._response = null;
    this._responseHeaders = null;
    this._responseParts = null;
    return void 0;
  };

  XMLHttpRequest.prototype._parseUrl = function(urlString) {
    var index, password, user, xhrUrl;
    xhrUrl = url.parse(urlString, false, true);
    xhrUrl.hash = null;
    if (xhrUrl.auth && ((typeof user !== "undefined" && user !== null) || (typeof password !== "undefined" && password !== null))) {
      index = xhrUrl.auth.indexOf(':');
      if (index === -1) {
        if (!user) {
          user = xhrUrl.auth;
        }
      } else {
        if (!user) {
          user = xhrUrl.substring(0, index);
        }
        if (!password) {
          password = xhrUrl.substring(index + 1);
        }
      }
    }
    if (user || password) {
      xhrUrl.auth = "" + user + ":" + password;
    }
    return xhrUrl;
  };

  XMLHttpRequest.prototype._parseResponseHeaders = function(response) {
    var loweredName, name, value, _ref;
    this._responseHeaders = {};
    _ref = response.headers;
    for (name in _ref) {
      value = _ref[name];
      loweredName = name.toLowerCase();
      if (this._privateHeaders[loweredName]) {
        continue;
      }
      if (this._mimeOverride !== null && loweredName === 'content-type') {
        value = this._mimeOverride;
      }
      this._responseHeaders[loweredName] = value;
    }
    if (this._mimeOverride !== null && !('content-type' in this._responseHeaders)) {
      this._responseHeaders['content-type'] = this._mimeOverride;
    }
    return void 0;
  };

  XMLHttpRequest.prototype._parseResponse = function() {
    var arrayBuffer, buffer, i, jsonError, view, _i, _ref;
    if (Buffer.concat) {
      buffer = Buffer.concat(this._responseParts);
    } else {
      buffer = this._concatBuffers(this._responseParts);
    }
    this._responseParts = null;
    switch (this.responseType) {
      case 'text':
        this._parseTextResponse(buffer);
        break;
      case 'json':
        this.responseText = null;
        try {
          this.response = JSON.parse(buffer.toString('utf-8'));
        } catch (_error) {
          jsonError = _error;
          this.response = null;
        }
        break;
      case 'buffer':
        this.responseText = null;
        this.response = buffer;
        break;
      case 'arraybuffer':
        this.responseText = null;
        arrayBuffer = new ArrayBuffer(buffer.length);
        view = new Uint8Array(arrayBuffer);
        for (i = _i = 0, _ref = buffer.length; 0 <= _ref ? _i < _ref : _i > _ref; i = 0 <= _ref ? ++_i : --_i) {
          view[i] = buffer[i];
        }
        this.response = arrayBuffer;
        break;
      default:
        this._parseTextResponse(buffer);
    }
    return void 0;
  };

  XMLHttpRequest.prototype._parseTextResponse = function(buffer) {
    var e;
    try {
      this.responseText = buffer.toString(this._parseResponseEncoding());
    } catch (_error) {
      e = _error;
      this.responseText = buffer.toString('binary');
    }
    this.response = this.responseText;
    return void 0;
  };

  XMLHttpRequest.prototype._parseResponseEncoding = function() {
    var contentType, encoding, match;
    encoding = null;
    if (contentType = this._responseHeaders['content-type']) {
      if (match = /\;\s*charset\=(.*)$/.exec(contentType)) {
        return match[1];
      }
    }
    return 'utf-8';
  };

  XMLHttpRequest.prototype._concatBuffers = function(buffers) {
    var buffer, length, target, _i, _j, _len, _len1;
    if (buffers.length === 0) {
      return new Buffer(0);
    }
    if (buffers.length === 1) {
      return buffers[0];
    }
    length = 0;
    for (_i = 0, _len = buffers.length; _i < _len; _i++) {
      buffer = buffers[_i];
      length += buffer.length;
    }
    target = new Buffer(length);
    length = 0;
    for (_j = 0, _len1 = buffers.length; _j < _len1; _j++) {
      buffer = buffers[_j];
      buffer.copy(target, length);
      length += buffer.length;
    }
    return target;
  };

  return XMLHttpRequest;

})(XMLHttpRequestEventTarget);

module.exports = XMLHttpRequest;

XMLHttpRequest.XMLHttpRequest = XMLHttpRequest;
// Generated by CoffeeScript 1.7.1
var InvalidStateError, NetworkError, SecurityError,
  __hasProp = {}.hasOwnProperty,
  __extends = function(child, parent) { for (var key in parent) { if (__hasProp.call(parent, key)) child[key] = parent[key]; } function ctor() { this.constructor = child; } ctor.prototype = parent.prototype; child.prototype = new ctor(); child.__super__ = parent.prototype; return child; };

SecurityError = (function(_super) {
  __extends(SecurityError, _super);

  function SecurityError() {
    SecurityError.__super__.constructor.apply(this, arguments);
  }

  return SecurityError;

})(Error);

XMLHttpRequest.SecurityError = SecurityError;

InvalidStateError = (function(_super) {
  __extends(InvalidStateError, _super);

  function InvalidStateError() {
    InvalidStateError.__super__.constructor.apply(this, arguments);
  }

  return InvalidStateError;

})(Error);

InvalidStateError = (function(_super) {
  __extends(InvalidStateError, _super);

  function InvalidStateError() {
    return InvalidStateError.__super__.constructor.apply(this, arguments);
  }

  return InvalidStateError;

})(Error);

XMLHttpRequest.InvalidStateError = InvalidStateError;

NetworkError = (function(_super) {
  __extends(NetworkError, _super);

  function NetworkError() {
    NetworkError.__super__.constructor.apply(this, arguments);
  }

  return NetworkError;

})(Error);

XMLHttpRequest.NetworkError = NetworkError;
// Generated by CoffeeScript 1.7.1
var XMLHttpRequestProgressEvent;

XMLHttpRequestProgressEvent = (function() {
  function XMLHttpRequestProgressEvent(type, target) {
    this.type = type;
    this.target = target;
    this.currentTarget = this.target;
    this.lengthComputable = false;
    this.loaded = 0;
    this.total = 0;
  }

  XMLHttpRequestProgressEvent.prototype.bubbles = false;

  XMLHttpRequestProgressEvent.prototype.cancelable = false;

  XMLHttpRequestProgressEvent.prototype.target = null;

  XMLHttpRequestProgressEvent.prototype.loaded = null;

  XMLHttpRequestProgressEvent.prototype.lengthComputable = null;

  XMLHttpRequestProgressEvent.prototype.total = null;

  return XMLHttpRequestProgressEvent;

})();

XMLHttpRequest.XMLHttpRequestProgressEvent = XMLHttpRequestProgressEvent;
// Generated by CoffeeScript 1.7.1
var XMLHttpRequestUpload,
  __hasProp = {}.hasOwnProperty,
  __extends = function(child, parent) { for (var key in parent) { if (__hasProp.call(parent, key)) child[key] = parent[key]; } function ctor() { this.constructor = child; } ctor.prototype = parent.prototype; child.prototype = new ctor(); child.__super__ = parent.prototype; return child; };

XMLHttpRequestUpload = (function(_super) {
  __extends(XMLHttpRequestUpload, _super);

  function XMLHttpRequestUpload(request) {
    XMLHttpRequestUpload.__super__.constructor.call(this);
    this._request = request;
    this._reset();
  }

  XMLHttpRequestUpload.prototype._reset = function() {
    this._contentType = null;
    this._body = null;
    return void 0;
  };

  XMLHttpRequestUpload.prototype._setData = function(data) {
    var body, i, offset, view, _i, _j, _ref, _ref1;
    if (typeof data === 'undefined' || data === null) {
      return;
    }
    if (typeof data === 'string') {
      if (data.length !== 0) {
        this._contentType = 'text/plain;charset=UTF-8';
      }
      this._body = new Buffer(data, 'utf8');
    } else if (Buffer.isBuffer(data)) {
      this._body = data;
    } else if (data instanceof ArrayBuffer) {
      body = new Buffer(data.byteLength);
      view = new Uint8Array(data);
      for (i = _i = 0, _ref = data.byteLength; 0 <= _ref ? _i < _ref : _i > _ref; i = 0 <= _ref ? ++_i : --_i) {
        body[i] = view[i];
      }
      this._body = body;
    } else if (data.buffer && data.buffer instanceof ArrayBuffer) {
      body = new Buffer(data.byteLength);
      offset = data.byteOffset;
      view = new Uint8Array(data.buffer);
      for (i = _j = 0, _ref1 = data.byteLength; 0 <= _ref1 ? _j < _ref1 : _j > _ref1; i = 0 <= _ref1 ? ++_j : --_j) {
        body[i] = view[i + offset];
      }
      this._body = body;
    } else {
      throw new Error("Unsupported send() data " + data);
    }
    return void 0;
  };

  XMLHttpRequestUpload.prototype._finalizeHeaders = function(headers, loweredHeaders) {
    if (this._contentType) {
      if (!('content-type' in loweredHeaders)) {
        headers['Content-Type'] = this._contentType;
      }
    }
    if (this._body) {
      headers['Content-Length'] = this._body.length.toString();
    }
    return void 0;
  };

  XMLHttpRequestUpload.prototype._startUpload = function(request) {
    if (this._body) {
      request.write(this._body);
    }
    request.end();
    return void 0;
  };

  return XMLHttpRequestUpload;

})(XMLHttpRequestEventTarget);

XMLHttpRequest.XMLHttpRequestUpload = XMLHttpRequestUpload;

XHRDemo.hs

{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, InterruptibleFFI, EmptyDataDecls, LambdaCase, ScopedTypeVariables, DeriveDataTypeable, BangPatterns #-}

{-|
  XMLHttpRequest bindings using lightweight threads and GHCJS

  These bindings are incomplete and serve as an illustration for
  implementing asynchronous IO on GHCJS.

  author: Luite Stegeman
 -}

module XHRDemo ( XHRMethod(..)
               , XHRException(..)
               , XHRResult(..)
               , XHRHeader
               , XHRProgress
               , xhrGetLazyText
               , xhrText
               ) where

import           Control.Applicative
import           Control.Concurrent
import           Control.Concurrent.MVar
import qualified Control.Exception as E
import           Control.Monad

import           Data.Maybe
import           Data.Monoid
import           Data.Text (Text)
import qualified Data.Text         as T
import qualified Data.Text.IO      as T
import qualified Data.Text.Lazy    as TL
import qualified Data.Text.Lazy.IO as TL
import           Data.Typeable hiding (typeOf)

import           System.IO
import           System.IO.Unsafe
import           System.Mem.Weak

import           GHCJS.Foreign
import           GHCJS.Marshal
import           GHCJS.Types

data XHR

data XHRMethod = GET | POST | PUT | DELETE deriving (Eq, Ord, Enum)

data XHRException = XHRTimeout
                  | XHRError String
  deriving (Eq, Show, Typeable)

instance E.Exception XHRException

data XHRResult = XHRResult { xhrStatus  :: Int
                           , xhrBody    :: Maybe Text
                           }
  deriving (Eq, Ord, Show)

type XHRHeader = (String, String)

type XHRProgress = Maybe Int   -- ^ total size in bytes, if known
                -> Int         -- ^ received number of bytes
                -> IO XHRChunk -- ^ action to get the next chunk, throws an exception if there's a problem
                -> IO ()

{- | Do a GET request with lazy text response from the server

     Closes the connection early if there are no more references
     to the unconsumed part of the text.

     The usual lazy IO caveats apply:
      - evaluating the result can lead to an exception
 -}

xhrGetLazyText :: String     -- ^ the URL
               -> IO TL.Text -- ^ the response, as a lazy text
xhrGetLazyText url = do
  mv  <- newEmptyMVar
  let consumeResult :: MVar () -> IO [Text]
      consumeResult x =
        takeMVar mv >>= \case
          Right EndOfStream   -> tryTakeMVar x >> return []
          Right ChunkNoData   -> consumeResult x
          Right (ChunkData t) -> unsafeInterleaveIO (fmap (t:) (consumeResult x))
          Left excep          -> E.throwIO excep
  mv2 <- newEmptyMVar
  forkIO . void $ do
    tid <- myThreadId
    let kill = throwTo tid E.ThreadKilled
    mvw <- mkWeakMVar mv2 kill
    xhrText GET url [] Nothing Nothing Nothing . Just $
      \_ _ getChunk -> do
         deRefWeak mvw >>=
           maybe kill (\_ -> putMVar mv =<< (Right <$> getChunk) `E.catch`
                                 (\(e :: XHRException) -> return (Left e)))
    deRefWeak mvw >>= maybe kill (\_ -> putMVar mv (Right EndOfStream))
  unsafeInterleaveIO (TL.fromChunks <$> consumeResult mv2)

{- | Send an AJAX request with Text result

     Throws 'XHRException' on error
 -}
xhrText :: XHRMethod              -- ^ request method
        -> String                 -- ^ url
        -> [XHRHeader]            -- ^ extra headers
        -> Maybe (String, String) -- ^ username/password
        -> Maybe String           -- ^ override mime type
        -> Maybe Int              -- ^ timeout in ms
        -> Maybe XHRProgress      -- ^ callback for progress messages
        -> IO XHRResult
xhrText method url headers userPass overrideMime timeout progress = do
  headers' <- castRef <$> toArray (concatMap (\(h,v) -> [toJSString h, toJSString v]) headers)
  xhr      <- js_newXhr
  let mbStr          = maybe jsNull (castRef . toJSString)
      numberProp p o = fmap (fromMaybe 0) . fromJSRef =<< unsafeGetProp p o
      (user, pass)   = maybe (Nothing, Nothing) (\(x,y) -> (Just x, Just y)) userPass
      doReq          = js_xhrText xhr (fromEnum method) (toJSString url) headers' (mbStr user) (mbStr pass) (mbStr overrideMime) (fromMaybe (-1) timeout)
      abortReq       = js_xhrAbort xhr
  case progress of
    Nothing -> doReq `E.onException` abortReq
    Just progress' -> do
      progressThread <- forkIO . forever $ do
        progressMsg <- js_xhrAwaitProgress xhr
        total  <- numberProp "total"  progressMsg
        loaded <- numberProp "loaded" progressMsg
        progress' (if total < 0 then Nothing else Just total) loaded (xhrGetNextChunk xhr)
      let killProgressThread = throwTo progressThread E.ThreadKilled
      result <- doReq `E.onException` (abortReq >> killProgressThread)
      killProgressThread
  err <- unsafeGetProp "err" xhr
  when (not $ isNull err) (xhrThrowException err)
  xhrGetResult xhr

{- | Gets the next chunk of data from the XMLHttpRequest. This function does not block,
     but may throw an exception if the request was aborted with an error. Returns
     Nothing to indicate that the whole stream has been consumed.
 -}
data XHRChunk = ChunkData Text
              | ChunkNoData
              | EndOfStream
  deriving (Eq, Ord)

xhrGetNextChunk :: JSRef XHR -> IO XHRChunk
xhrGetNextChunk xhr = do
  r <- js_xhrGetIncremental xhr
  if isNull r
    then return ChunkNoData
    else
      unsafeGetPropMaybe "err" r >>=
        maybe (ChunkData . fromJSString <$> unsafeGetProp "chunk" r) xhrThrowException

{- | If the XMLHttpRequest encounters an error, we set the .err property to:
       - a String for a general error
       - somthing other than null for a timeout

     This throws the correct Haskell exception for the error
 -}
xhrThrowException :: JSRef a -> IO b
xhrThrowException o =
  typeOf o >>= \case
                 4 -> E.throwIO (XHRError $ fromJSString (castRef o))
                 _ -> E.throwIO XHRTimeout

xhrGetResult :: JSRef XHR -> IO XHRResult
xhrGetResult xhr = do
  status <- fromMaybe 0 <$> (fromJSRef =<< getProp "status" xhr)
  body   <- maybe (return Nothing) fromJSRef =<< getPropMaybe "responseText" xhr
  return (XHRResult status body)

{- |
  Implementation details:

  the code below expects that the XHR is used only for one request and that
  only one awaitProgress call is made at a time.
-}

foreign import javascript unsafe
  "$r = new XMLHttpRequest();\
  \$r.latestProgressMessage = null;\
  \$r.awaitingProgress = null;\
  \$r.incrementalPos = 0;\
  \$r.err = null;\
  \ "
  js_newXhr :: IO (JSRef XHR)

foreign import javascript unsafe
  "try { $1.abort(); } catch(e) { var unused; };"
  js_xhrAbort :: JSRef XHR -> IO ()

foreign import javascript interruptible
  "if($1.latestProgressMessage) {\
  \  $c($1.latestProgressMessage);\
  \  $1.latestProgressMessage = null;\
  \} else {\
  \  $1.awaitingProgress = $c;\
  \}\
  \ "
  js_xhrAwaitProgress :: JSRef XHR -> IO (JSRef ())

foreign import javascript unsafe
  "var t = $1.responseText;\
  \if($1.err) {\
  \  $r = { err: $1.err };\
  \} else if(t && t.length) {\
  \  var lastCh = t.charCodeAt($1.incrementalPos-1);\
  \  var upTo   = t.length - ((0xD800 <= lastCh && lastCh <= 0xDBFF) ? 1 : 0);\
  \  if($1.incrementalPos === upTo) {\
  \    $r = null;\
  \  } else {\
  \    $r = { chunk: t.substring($1.incrementalPos, upTo) };\
  \    $1.incrementalPos = upTo;\
  \  }\
  \} else {\
  \  $r = null;\
  \}\
  \ "
  js_xhrGetIncremental :: JSRef XHR -> IO (JSRef ())

foreign import javascript interruptible
  "$1.overrideMime = $7;\
  \var method = ['GET', 'POST', 'PUT', 'DELETE'][$2];\
  \for(var i=0;i<$4.length;i+=2) $1.setRequestHeader($4[i], $4[i+1]);\
  \$1.addEventListener('load', function(evt) { $c(); }, false);\
  \$1.addEventListener('error', function(evt) { $1.err = evt.toString(); $c(); }, false);\
  \$1.addEventListener('timeout', function(evt) { $1.err = -1; $c(); }, false);\
  \$1.addEventListener('progress', function(evt) {\
  \  var progressMessage = { total:  evt.lengthComputable ? (evt.total|0) : -1\
  \                        , loaded: evt.loaded|0\
  \                        };\
  \  if($1.awaitingProgress) {\
  \    $1.awaitingProgress(progressMessage);\
  \    $1.awaitingProgress = null;\
  \  } else {\
  \    $1.latestProgressMessage = progressMessage;\
  \  }\
  \}, false);\
  \$1.open(method, $3, true, $5 || '', $6 || '');\
  \if($8 !== -1) $1.timeout = $8;\
  \$1.send();\
  \ "
  js_xhrText :: JSRef XHR        -- ^ $1 XMLHttpRequest object
             -> Int              -- ^ $2 method: 0: GET, 1: POST, 2: PUT, 3: DELETE
             -> JSString         -- ^ $3 url
             -> JSArray JSString -- ^ $4 request headers
             -> JSRef ()         -- ^ $5 user (null for no user)
             -> JSRef ()         -- ^ $6 password (null for no password)
             -> JSRef ()         -- ^ $7 override mime (null for no override)
             -> Int              -- ^ $8 timeout in ms (-1 to use default value)
             -> IO ()            -- ^ result object