Javascript XMLHttpRequest Client implementation

_oasis

@@ -28,6 +28,10 @@ Flag async
   Description: build the Core/Async library
   Default:     false
 
+Flag js
+  Description: build the Javascript XHR client library
+  Default:     false
+
 Flag nettests
   Description: run the internet-using tests
   Default:     false
@@ -52,6 +56,16 @@ Library cohttp_lwt_unix
   XMETARequires: cohttp.lwt-core, unix, lwt.unix, lwt.ssl, conduit.lwt
   Modules:       Cohttp_lwt_unix_io, Cohttp_lwt_unix, Cohttp_lwt_unix_net
 
+Library cohttp_lwt_xhr
+  Build$:        flag(lwt) && flag(js)
+  Install$:      flag(lwt) && flag(js)
+  Path:          js
+  Findlibname:   js
+  FindlibParent: cohttp
+  BuildDepends:  cohttp.lwt-core, js_of_ocaml, js_of_ocaml.syntax
+  XMETARequires: cohttp.lwt-core, js_of_ocaml
+  Modules:       Cohttp_lwt_xhr
+
 Library cohttp_async
   Build$:        flag(async)
   Install$:      flag(async)

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: bf32f3d69d75950b1ffda558b49ccb53)
+# DO NOT EDIT (digest: 313e637245f1f50cb65af4a61de329ce)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -60,6 +60,22 @@
 <lwt/*.ml{,i}>: pkg_uri.services
 <lwt/*.ml{,i}>: use_cohttp
 <lwt/*.ml{,i}>: use_cohttp_lwt
+# Library cohttp_lwt_xhr
+"js/cohttp_lwt_xhr.cmxs": use_cohttp_lwt_xhr
+<js/*.ml{,i}>: pkg_fieldslib
+<js/*.ml{,i}>: pkg_fieldslib.syntax
+<js/*.ml{,i}>: pkg_js_of_ocaml
+<js/*.ml{,i}>: pkg_js_of_ocaml.syntax
+<js/*.ml{,i}>: pkg_lwt
+<js/*.ml{,i}>: pkg_lwt.syntax
+<js/*.ml{,i}>: pkg_re.emacs
+<js/*.ml{,i}>: pkg_sexplib
+<js/*.ml{,i}>: pkg_sexplib.syntax
+<js/*.ml{,i}>: pkg_stringext
+<js/*.ml{,i}>: pkg_uri
+<js/*.ml{,i}>: pkg_uri.services
+<js/*.ml{,i}>: use_cohttp
+<js/*.ml{,i}>: use_cohttp_lwt
 # Library cohttp_async
 "async/cohttp_async.cmxs": use_cohttp_async
 <async/*.ml{,i}>: pkg_async

cohttp/META

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: eee80b05ce0be3b4bcecf7d96fff6df8)
+# DO NOT EDIT (digest: 7ad1a9f80af587793deb1ae42f35e61d)
 version = "0.12.0"
 description = "HTTP library for Lwt, Async and Mirage"
 requires = "re.emacs stringext uri uri.services fieldslib sexplib"
@@ -30,6 +30,17 @@ package "lwt" (
  exists_if = "cohttp_lwt_unix.cma"
 )
 
+package "js" (
+ version = "0.12.0"
+ description = "HTTP library for Lwt, Async and Mirage"
+ requires = "cohttp.lwt-core js_of_ocaml"
+ archive(byte) = "cohttp_lwt_xhr.cma"
+ archive(byte, plugin) = "cohttp_lwt_xhr.cma"
+ archive(native) = "cohttp_lwt_xhr.cmxa"
+ archive(native, plugin) = "cohttp_lwt_xhr.cmxs"
+ exists_if = "cohttp_lwt_xhr.cma"
+)
+
 package "async" (
  version = "0.12.0"
  description = "HTTP library for Lwt, Async and Mirage"

js/cohttp_lwt_xhr.ml

@@ -0,0 +1,178 @@
+(* input channel type - a string with a (file) position and length *)
+type ic' = 
+  {
+    str : string;
+    mutable pos : int;
+    len : int;
+  }
+
+module String_io = struct
+    type 'a t = 'a Lwt.t
+    let return = Lwt.return
+    let (>>=) = Lwt.bind
+
+    let rec iter = Lwt_list.iter_s
+
+    type ic = ic'
+
+    (* output channels are just buffers *)
+    type oc = Buffer.t
+
+    (* the following read/write logic has only been lightly tested... *)
+    let read_rest x = 
+      let s = String.sub x.str x.pos (x.len-x.pos) in
+      x.pos <- x.len;
+      s
+
+    let read_line' x = 
+      if x.pos < x.len then
+        let start = x.pos in
+        try
+          while x.str.[x.pos] != '\n' do
+            x.pos <- x.pos + 1
+          done;
+          let s = String.sub x.str start (x.pos-start) in
+          x.pos <- x.pos + 1;
+          Some s
+        with _ ->
+          Some (read_rest x)
+      else
+        None
+
+    let read_line x = return (read_line' x)
+
+    let read_exactly' x n = 
+      if x.len-x.pos < n then None
+      else begin
+        let s = String.sub x.str x.pos n in
+        x.pos <- x.pos + n;
+        Some s
+      end
+
+    let read_exactly x n = return (read_exactly' x n)
+
+    let read x n =
+      match read_exactly' x n with
+      | None when x.pos >= x.len -> Lwt.fail End_of_file
+      | None -> return (read_rest x)
+      | Some(x) -> return x
+
+    let rec write x s = Buffer.add_string x s; return ()
+
+    let flush x = return ()
+
+end
+
+module C = Cohttp
+module CLB = Cohttp_lwt_body
+
+module Response = Cohttp_lwt.Make_response(String_io)
+module Request = Cohttp_lwt.Make_request(String_io)
+
+module Client = struct
+
+    module IO = String_io
+    module Response = Response
+    module Request = Request
+
+    module Header_io = Cohttp.Header_io.Make(String_io)
+
+    (* XXX remove me *)
+    let log_active = ref true
+    let log fmt =
+      Printf.ksprintf (fun s ->
+        match !log_active with
+        | false -> ()
+        | true  -> prerr_endline (">>> GitHub: " ^ s)) fmt
+
+    let call ?headers ?body ?chunked meth uri = 
+      let xml = XmlHttpRequest.create () in
+      let () = xml##_open(Js.string (C.Code.string_of_method meth),
+                          Js.string (Uri.to_string uri),
+                          Js._false) (* For simplicity, do a sync call.  We should
+                                        really make this async. See js_of_ocaml apis
+                                        for an example *)
+      in
+      (* set request headers *)
+      let () = 
+          match headers with
+          | None -> ()
+          | Some(headers) ->
+            C.Header.iter 
+              (fun k v -> List.iter 
+                (* some headers lead to errors in the javascript console, should
+                   we filter then out here? *)
+                (fun v -> 
+                  log "[req header] %s: %s" k v;
+                  xml##setRequestHeader(Js.string k, Js.string v)) v) 
+              headers 
+      in
+      (* perform call *)
+      lwt () = 
+        match body with
+        | None -> Lwt.return (xml##send(Js.null))
+        | Some(body) -> 
+          lwt body = CLB.to_string body in
+          Lwt.return (xml##send(Js.Opt.return (Js.string body)))
+      in
+
+      let () = log "[resp status] %s" (Js.to_string xml##statusText) in
+
+      (* construct body *)
+      let body_str = Js.to_string xml##responseText in
+      let body = CLB.of_string body_str in
+
+      (* (re-)construct the response *)
+      lwt resp_headers = 
+        let resp_headers = Js.to_string (xml##getAllResponseHeaders()) in
+        lwt resp_headers = Header_io.parse 
+          String_io.({ str=resp_headers; pos=0; len=String.length resp_headers }) in
+        C.Header.iter 
+          (fun k v -> List.iter (fun v -> log "[resp header] %s: %s" k v) v) 
+          resp_headers;
+        Lwt.return resp_headers
+      in
+
+      let response = Response.make 
+        ~version:`HTTP_1_1
+        ~status:(Cohttp.Code.status_of_code xml##status)
+        ~flush:false
+        ~encoding:(Cohttp.Transfer.Fixed (String.length body_str))
+        ~headers:resp_headers 
+        ()
+      in
+
+      (* log the response *)
+      lwt () = 
+        let b = Buffer.create 100 in
+        lwt () = Response.write_header response b in
+        let () = log "response:\n%s" (Buffer.contents b) in
+        Lwt.return ()
+      in
+
+      Lwt.return (response,body)
+
+    (* The HEAD should not have a response body *)
+    let head ?headers uri =
+      let open Lwt in
+      call ?headers ~chunked:false `HEAD uri
+      >|= fst
+
+    let get ?headers uri = call ?headers ~chunked:false `GET uri
+    let delete ?headers uri = call ?headers ~chunked:false `DELETE uri
+    let post ?body ?chunked ?headers uri = call ?headers ?body ?chunked `POST uri
+    let put ?body ?chunked ?headers uri = call ?headers ?body ?chunked `PUT uri
+    let patch ?body ?chunked ?headers uri = call ?headers ?body ?chunked `PATCH uri
+
+    let post_form ?headers ~params uri =
+      let headers = C.Header.add_opt headers "content-type" "application/x-www-form-urlencoded" in
+      let q = List.map (fun (k,v) -> k, [v]) (C.Header.to_list params) in
+      let body = Cohttp_lwt_body.of_string (Uri.encoded_of_query q) in
+      post ~chunked:false ~headers ~body uri
+
+    (* No implementation (can it be done?).  What should the failure exception be? *)
+    exception Cohttp_lwt_xhr_not_implemented
+    let callv ?(ssl=false) host port reqs = Lwt.fail Cohttp_lwt_xhr_not_implemented (* ??? *)
+
+end
+

js/cohttp_lwt_xhr.mldylib

@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: 8c40f6224969cac084c43da913957e60)
+Cohttp_lwt_xhr
+# OASIS_STOP

js/cohttp_lwt_xhr.mli

@@ -0,0 +1,41 @@
+(*
+ * Copyright (c) 2012-2013 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+(** Prototype HTTP client for javascript using XMLHttpRequest. *)
+
+type ic' = 
+  {
+    str : string;
+    mutable pos : int;
+    len : int;
+  }
+
+(** IO is implemented with strings *)
+module String_io : Cohttp.S.IO
+ with type 'a t = 'a Lwt.t
+ and type ic = ic'
+ and type oc = Buffer.t
+
+(** The [Request] module holds the information about a HTTP request *)
+module Request : Cohttp_lwt.Request with module IO = String_io
+
+(** The [Response] module holds the information about a HTTP response *)
+module Response : Cohttp_lwt.Response with module IO = String_io
+
+(** The [Client] module implements an HTTP client interface. *)
+module Client : Cohttp_lwt.Client with module IO = String_io
+

js/cohttp_lwt_xhr.mllib

@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: 8c40f6224969cac084c43da913957e60)
+Cohttp_lwt_xhr
+# OASIS_STOP

myocamlbuild.ml

@@ -1,5 +1,5 @@
 (* OASIS_START *)
-(* DO NOT EDIT (digest: bcb5bed918c5d1e532d353d9d6b0139d) *)
+(* DO NOT EDIT (digest: c7224e6b924b2c3c091ce2d5f6b9c4d0) *)
 module OASISGettext = struct
 (* # 22 "src/oasis/OASISGettext.ml" *)
 
@@ -600,6 +600,7 @@ let package_default =
           ("cohttp", ["cohttp"], []);
           ("cohttp_lwt", ["lwt"], []);
           ("cohttp_lwt_unix", ["lwt"], []);
+          ("cohttp_lwt_xhr", ["js"], []);
           ("cohttp_async", ["async"], [])
        ];
      lib_c = [];
@@ -608,6 +609,7 @@ let package_default =
        [
           ("lwt", ["cohttp"]);
           ("lib_test", ["async"; "cohttp"; "lwt"]);
+          ("js", ["lwt"]);
           ("examples/async", ["async"; "cohttp"]);
           ("bin", ["async"; "cohttp"; "lwt"]);
           ("async", ["cohttp"])
@@ -617,6 +619,6 @@ let package_default =
 
 let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
 
-# 621 "myocamlbuild.ml"
+# 623 "myocamlbuild.ml"
 (* OASIS_STOP *)
 Ocamlbuild_plugin.dispatch dispatch_default;;