[Mldonkey-users] [PATCH] http: better error reporting

[ygrek]

Show some textual description of error

---
 src/daemon/common/commonWeb.ml           |    6 +++---
 src/networks/bittorrent/bTClients.ml     |    4 ++--
 src/networks/bittorrent/bTInteractive.ml |    4 ++--
 src/networks/bittorrent/bT_DHT.ml        |    2 +-
 src/networks/fileTP/fileTPHTTP.ml        |    7 +------
 src/utils/net/http_client.ml             |   21 ++++++++++++++-------
 src/utils/net/http_client.mli            |   21 +++++++++------------
 src/utils/net/ip.ml                      |    4 ++--
 src/utils/net/ip.mli                     |    4 ++--
 9 files changed, 36 insertions(+), 37 deletions(-)

diff --git a/src/daemon/common/commonWeb.ml b/src/daemon/common/commonWeb.ml
index 858160c..17fe1a1 100755
--- a/src/daemon/common/commonWeb.ml
+++ b/src/daemon/common/commonWeb.ml
@@ -150,8 +150,8 @@ let mldonkey_wget_url w f =
          end
       )
       (fun c ->
-       match c with
-          | x when x > 0 && (x < 200 || x > 299) -> begin
+          match c with
+          | `HTTP x when (x < 200 || x > 299) -> begin
             (* use local version if wget fail and file exists *)
             let file = Filename.concat "web_infos" (Filename.basename 
r.H.req_url.Url.short_file) in
             (* mark this job downloaded *)
@@ -185,7 +185,7 @@ let mldonkey_wget_url w f =
               lprintf_nl (_b "local file %s not found, HTTP request failed 
(error %d)") file x;
               w.state <- None
             end
-         | _ -> ()
+          | _ -> ()
       )
     with e -> 
       w.state <- None;
diff --git a/src/networks/bittorrent/bTClients.ml 
b/src/networks/bittorrent/bTClients.ml
index 929a95c..26061c1 100644
--- a/src/networks/bittorrent/bTClients.ml
+++ b/src/networks/bittorrent/bTClients.ml
@@ -202,9 +202,9 @@ let talk_to_udp_tracker host port args file t need_sources =
     Ip.async_ip host (fun ip ->
 (*       lprintf_nl "udpt resolved %s to ip %s" host (Ip.to_string ip); *)
       try interact ip with exn -> lprintf_nl "udpt interact exn %s" 
(Printexc2.to_string exn))
-      (fun n -> 
+      (fun () -> 
         if !verbose_msg_servers then
-          lprintf_nl "udpt failed to resolve %s (%d)" host n)
+          lprintf_nl "udpt failed to resolve %s" host)
   with
   exn -> 
     lprintf_nl "udpt start exn %s" (Printexc2.to_string exn)
diff --git a/src/networks/bittorrent/bTInteractive.ml 
b/src/networks/bittorrent/bTInteractive.ml
index 1f74cbf..45273b9 100644
--- a/src/networks/bittorrent/bTInteractive.ml
+++ b/src/networks/bittorrent/bTInteractive.ml
@@ -106,8 +106,8 @@ let perform_porttests tests =
     } in
     H.wget_string r 
       (fun s -> porttest_result := PorttestResult (last_time (), interpret s))
-      ~ferr:(fun code -> 
-        porttest_result := PorttestResult (last_time (), Printf.sprintf 
"Remote service error (%d)" code);
+      ~ferr:(fun e ->
+        porttest_result := PorttestResult (last_time (), Printf.sprintf "Error 
: %s" (H.show_error e));
         loop other)
       (fun _ _ -> ())
   in
diff --git a/src/networks/bittorrent/bT_DHT.ml 
b/src/networks/bittorrent/bT_DHT.ml
index b554e4c..6b77b0b 100644
--- a/src/networks/bittorrent/bT_DHT.ml
+++ b/src/networks/bittorrent/bT_DHT.ml
@@ -640,7 +640,7 @@ let bootstrap dht host addr k =
 let bootstrap dht (host,port) k =
   Ip.async_ip host
     (fun ip -> bootstrap dht host (ip,port) k)
-    (fun n -> if !verb then lprintf_nl "boostrap node %s cannot be resolved 
(%d)" host n; k false)
+    (fun () -> if !verb then lprintf_nl "boostrap node %s cannot be resolved" 
host; k false)
 
 let bootstrap ?(routers=[]) dht =
   lookup_node dht dht.M.rt.self begin fun l ->
diff --git a/src/networks/fileTP/fileTPHTTP.ml 
b/src/networks/fileTP/fileTPHTTP.ml
index 3df5a5f..33c9790 100644
--- a/src/networks/fileTP/fileTPHTTP.ml
+++ b/src/networks/fileTP/fileTPHTTP.ml
@@ -384,12 +384,7 @@ let http_check_size file url start_download_file =
         None -> failwith "Unable to start download (HEAD failed)"
     | Some result_size -> start_download_file result_size);
   )
-  (fun c ->
-    match c with 
-     x when x < 200 || x > 299 -> 
-       pause_for_cause file (string_of_int x) (CommonUserDb.admin_user ());
-    | _ -> ()
-  )
+  (fun e -> pause_for_cause file (H.show_error e) (CommonUserDb.admin_user ()))
 
 (*************************************************************************)
 (*                                                                       *)
diff --git a/src/utils/net/http_client.ml b/src/utils/net/http_client.ml
index f143098..22a4f2c 100644
--- a/src/utils/net/http_client.ml
+++ b/src/utils/net/http_client.ml
@@ -38,6 +38,13 @@ type http_request =
 | DELETE
 | TRACE
 
+type error = [ `HTTP of int | `RST of BasicSocket.close_reason | `DNS ]
+
+let show_error = function
+| `HTTP code -> Printf.sprintf "HTTP error code %d" code
+| `RST reason -> Printf.sprintf "Connection closed : %s" 
(BasicSocket.string_of_reason reason)
+| `DNS -> Printf.sprintf "DNS resolution failed"
+
 let verbose = ref false
 
 type request = {
@@ -218,13 +225,13 @@ let http_reply_handler nr headers_handler sock nread =
   read_header (parse_header headers_handler) sock nread
   
 
-let def_ferr = (fun c -> ())
+let def_ferr = (fun _ -> ())
 
 let rec get_page r content_handler f ferr =
   let ok = ref false in
   let ferr =
     let err_done = ref false in (* call not more than once *)
-    fun n -> if not !err_done then begin err_done := true; ferr n; end 
+    fun c -> if not !err_done then begin err_done := true; ferr c; end 
   in
   let rec get_url level r =
   try
@@ -246,7 +253,7 @@ let rec get_page r content_handler f ferr =
 (*             if !verbose then lprintf_nl "Event %s" (string_of_event e); *)
             match e with (* FIXME content-length check *)
             | BASIC_EVENT (CLOSED (Closed_by_user | Closed_by_peer)) when !ok 
-> f ()
-            | BASIC_EVENT (CLOSED _) -> ferr 0
+            | BASIC_EVENT (CLOSED reason) -> ferr (`RST reason)
             | BASIC_EVENT LTIMEOUT -> close sock Closed_for_lifetime
             | _ -> ())
         in
@@ -260,7 +267,7 @@ let rec get_page r content_handler f ferr =
         set_rtimeout sock 5.;
         set_lifetime sock r.req_max_total_time;
     )
-    ferr;
+    (fun () -> ferr `DNS);
   with e -> 
     lprintf_nl "error in get_url"; 
     raise Not_found
@@ -345,7 +352,7 @@ let rec get_page r content_handler f ferr =
     | 404 ->
         lprintf_nl "404: Not found for: %s" (Url.to_string_no_args r.req_url);
         close sock (Closed_for_error "bad reply");
-        ferr ans_code;
+        ferr (`HTTP ans_code);
         raise Not_found
 
     | 502 | 503 | 504 ->
@@ -363,7 +370,7 @@ let rec get_page r content_handler f ferr =
     end
         else begin
           lprintf_nl "more than %d retries, aborting." r.req_max_retry;
-          ferr ans_code;
+          ferr (`HTTP ans_code);
           raise Not_found
         end
           
@@ -371,7 +378,7 @@ let rec get_page r content_handler f ferr =
         lprintf_nl "%d: bad reply for: %s"
           ans_code (Url.to_string_no_args r.req_url);
         close sock (Closed_for_error "bad reply");
-        ferr ans_code;
+        ferr (`HTTP ans_code);
         raise Not_found
   in
   get_url 0 r
diff --git a/src/utils/net/http_client.mli b/src/utils/net/http_client.mli
index 0c3c868..2f484f5 100644
--- a/src/utils/net/http_client.mli
+++ b/src/utils/net/http_client.mli
@@ -53,22 +53,19 @@ type content_handler =
   int64 -> (string * string) list -> TcpBufferedSocket.t -> int -> unit
 
 val basic_request : request
-  
-val get_page : request -> content_handler -> (unit -> unit) -> (int -> unit) 
-> unit
+
+(** either HTTP error code or low-level network error or DNS *)
+type error = [ `HTTP of int | `RST of BasicSocket.close_reason | `DNS ]
+val show_error : error -> string
+
+val get_page : request -> content_handler -> (unit -> unit) -> (error -> unit) 
-> unit
 val wget : request -> (string -> unit) -> unit
 val whead : request -> ( (string * string) list -> unit) -> unit
-val whead2 : request -> ( (string * string) list -> unit) -> (int -> unit) -> 
unit
+val whead2 : request -> ( (string * string) list -> unit) -> (error -> unit) 
-> unit
 
-val wget_string : request -> (string -> unit) -> ?ferr:(int -> unit) ->
+val wget_string : request -> (string -> unit) -> ?ferr:(error -> unit) ->
   (int -> int64 -> unit) -> unit
 
-  
-  
-  (*
-val default_headers_handler : (int -> TcpBufferedSocket.t -> int -> unit) ->
-  headers_handler
-*)
-  
 val split_header : string -> string list
 val cut_headers : string list -> (string * (string * string)) list
-  
+
diff --git a/src/utils/net/ip.ml b/src/utils/net/ip.ml
index 8fe725a..ed37e30 100644
--- a/src/utils/net/ip.ml
+++ b/src/utils/net/ip.ml
@@ -288,7 +288,7 @@ type job = {
     mutable entries : Unix.inet_addr array;
     mutable error : bool;
     handler : (t -> unit);
-    err_handler : (int -> unit);
+    err_handler : (unit -> unit);
   }
 
 let exn_log name f x = 
@@ -361,7 +361,7 @@ let _ =
               job.handler ip
             end else begin
               lprintf_nl (_b "[DNS] could not resolve %s, check URL") job.name;
-              job.err_handler 0;
+              job.err_handler ();
               raise Not_found
             end
           end else raise Exit
diff --git a/src/utils/net/ip.mli b/src/utils/net/ip.mli
index b1d0fc7..a1ba25b 100644
--- a/src/utils/net/ip.mli
+++ b/src/utils/net/ip.mli
@@ -66,13 +66,13 @@ val equal : t -> t -> bool
 val value_to_ip : Options.option_value -> t
 val ip_to_value : t -> Options.option_value
   
-val async_ip : string -> (t -> unit) -> (int -> unit) -> unit
+val async_ip : string -> (t -> unit) -> (unit -> unit) -> unit
   
 type addr =
   AddrIp of t | AddrName of string
   
 val ip_of_addr : addr -> t
-val async_ip_of_addr : addr -> (t -> unit) -> (int -> unit) -> unit
+val async_ip_of_addr : addr -> (t -> unit) -> (unit -> unit) -> unit
 val string_of_addr : addr -> string
 val addr_of_ip : t -> addr
 val addr_of_string : string -> addr
-- 
1.7.2.5