reimplemented http GET/POST functions grabbing functions from

zack's Http_client_smart module

diff --git a/helm/hbugs/common/hbugs_misc.ml b/helm/hbugs/common/hbugs_misc.ml
index 85f926fc7dbe8dfc29fe9345ab0d0de2b4deebc4..b826318e0a05f924eb35f7c61b8570708f1b5d40 100644 (file)
--- a/helm/hbugs/common/hbugs_misc.ml
+++ b/helm/hbugs/common/hbugs_misc.ml
@@ -28,24 +28,38 @@
 
 open Printf;;
 
+let rec hashtbl_remove_all tbl key =
+  if Hashtbl.mem tbl key then begin
+    Hashtbl.remove tbl key;
+    hashtbl_remove_all tbl key
+  end else
+    ()
+
+  (** follows cut and paste from zack's Http_client_smart module *)
+
+exception Malformed_URL of string;;
+exception Malformed_HTTP_response of string;;
+
+let bufsiz = 16384;;
+let tcp_bufsiz = 4096;;
+
 let body_sep_RE = Pcre.regexp "\r\n\r\n";;
-let url_scheme_RE = Pcre.regexp ~flags:[`CASELESS] "http://";;
+let http_scheme_RE = Pcre.regexp ~flags:[`CASELESS] "^http://";;
 let url_RE = Pcre.regexp "^([\\w.]+)(:(\\d+))?(/.*)?$";;
 let parse_url url =
   try
-    let subs = Pcre.extract ~rex:url_RE (Pcre.replace ~rex:url_scheme_RE url) in
+    let subs =
+      Pcre.extract ~rex:url_RE (Pcre.replace ~rex:http_scheme_RE url)
+    in
     (subs.(1),
     (if subs.(2) = "" then 80 else int_of_string subs.(3)),
     (if subs.(4) = "" then "/" else subs.(4)))
-  with exc ->
-    failwith
-      (sprintf "Can't parse url: %s (exception: %s)"
-        url (Printexc.to_string exc))
+  with exc -> raise (Malformed_URL url)
 ;;
 let get_body answer =
   match Pcre.split ~rex:body_sep_RE answer with
   | [_; body] -> body
-  | _ -> failwith "Invalid response received: can't parse response's body"
+  | _ -> raise (Malformed_HTTP_response answer)
 ;;
 
 let init_socket addr port =
@@ -62,15 +76,31 @@ let rec retrieve inchan buf =
   retrieve inchan buf
 ;;
 
-let http_get url =
+let http_get_iter_buf ~callback url =
   let (address, port, path) = parse_url url in
+  let buf = String.create tcp_bufsiz in
   let (inchan, outchan) = init_socket address port in
-  output_string outchan (sprintf "GET %s HTTP/1.0\r\n\r\n" path);
+  output_string outchan (sprintf "GET %s\r\n" path);
   flush outchan;
-  let buf = Buffer.create 1023 in
-  try
-    retrieve inchan buf
-  with End_of_file -> get_body (Buffer.contents buf)
+  (try
+    while true do
+      match input inchan buf 0 tcp_bufsiz with
+      | 0 -> raise End_of_file
+      | bytes when bytes = tcp_bufsiz ->  (* buffer full, no need to slice it *)
+          callback buf
+      | bytes when bytes < tcp_bufsiz ->  (* buffer not full, slice it *)
+          callback (String.sub buf 0 bytes)
+      | _ -> (* ( bytes < 0 ) || ( bytes > tcp_bufsiz ) *)
+          assert false
+    done
+  with End_of_file -> ());
+  close_in inchan (* close also outchan, same fd *)
+;;
+
+let http_get url =
+  let buf = Buffer.create (tcp_bufsiz * 10) in
+  http_get_iter_buf (fun data -> Buffer.add_string buf data) url;
+  get_body (Buffer.contents buf)
 ;;
 
 let http_post ?(body = "") url =
@@ -81,17 +111,10 @@ let http_post ?(body = "") url =
   output_string outchan "\r\n";
   output_string outchan body;
   flush outchan;
-  let buf = Buffer.create 1023 in
-  try
+  let buf = Buffer.create bufsiz in
+  (try
     retrieve inchan buf
-  with End_of_file -> get_body (Buffer.contents buf)
-;;
-
-let rec hashtbl_remove_all tbl key =
-  if Hashtbl.mem tbl key then begin
-    Hashtbl.remove tbl key;
-    hashtbl_remove_all tbl key
-  end else
-    ()
+  with End_of_file -> close_in inchan); (* close also outchan, same fd *)
+  get_body (Buffer.contents buf)
 ;;
 

diff --git a/helm/hbugs/common/hbugs_misc.mli b/helm/hbugs/common/hbugs_misc.mli
index 015c7b82b78165c602d6625dd174de1e02ff8377..b0ef59719aba92610b1c9862ac31a54aec19235d 100644 (file)
--- a/helm/hbugs/common/hbugs_misc.mli
+++ b/helm/hbugs/common/hbugs_misc.mli
@@ -26,11 +26,25 @@
  *  http://helm.cs.unibo.it/
  *)
 
- (* HTTP GET request for a given url, return http response's body *)
+  (** helpers *)
+
+  (** remove all bindings of a given key from an hash table *)
+val hashtbl_remove_all: ('a, 'b) Hashtbl.t -> 'a -> unit
+
+  (** follows cut and paste from zack's Http_client_smart module *)
+
+  (** can't parse an HTTP url *)
+exception Malformed_URL of string
+  (** can't parse an HTTP response *)
+exception Malformed_HTTP_response of string
+ 
+  (** HTTP GET request for a given url, return http response's body *)
 val http_get: string -> string
- (* HTTP POST request for a given url, return http response's body, body
- argument, if specified, is sent as body along with request *)
+  (** HTTP POST request for a given url, return http response's body,
+ body argument, if specified, is sent as body along with request *)
 val http_post: ?body:string -> string -> string
 
-val hashtbl_remove_all: ('a, 'b) Hashtbl.t -> 'a -> unit
+  (** perform an HTTP GET request and apply a given function on each
+  'slice' of HTTP response read from server *)
+val http_get_iter_buf: callback:(string -> unit) -> string -> unit