X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fhbugs%2Fcommon%2Fhbugs_misc.ml;h=b826318e0a05f924eb35f7c61b8570708f1b5d40;hb=30cbad3167cf714a8edc2dbc05c1fe8908e2542b;hp=30f46081553d85cd29112b8c2fa5986e4099d055;hpb=3c1a6c534877f7b7266809e4d92de02c7f1ee9d4;p=helm.git

diff --git a/helm/hbugs/common/hbugs_misc.ml b/helm/hbugs/common/hbugs_misc.ml
index 30f460815..b826318e0 100644
--- a/helm/hbugs/common/hbugs_misc.ml
+++ b/helm/hbugs/common/hbugs_misc.ml
@@ -1,5 +1,7 @@
 (*
- *  Copyright (C) 2003, HELM Team.
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
  *
  *  This file is part of HELM, an Hypertextual, Electronic
  *  Library of Mathematics, developed at the Computer Science
@@ -21,29 +23,43 @@
  *  MA  02111-1307, USA.
  *
  *  For details, see the HELM World-Wide-Web page,
- *  http://cs.unibo.it/helm/.
+ *  http://helm.cs.unibo.it/
  *)
 
 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 =
@@ -60,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 =
@@ -79,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)
 ;;