[Mldonkey-commits] mldonkey distrib/ChangeLog src/networks/bittorr...

[mldonkey-commits]

CVSROOT:        /sources/mldonkey
Module name:    mldonkey
Changes by:     spiralvoice <spiralvoice>       10/07/28 16:25:45

Modified files:
        distrib        : ChangeLog 
        src/networks/bittorrent: bTInteractive.ml 
        src/utils/net  : basicSocket.ml basicSocket.mli http_client.ml 
                         http_client.mli tcpBufferedSocket.ml 
                         tcpBufferedSocket.mli 

Log message:
        patch #7262

CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/mldonkey/distrib/ChangeLog?cvsroot=mldonkey&r1=1.1451&r2=1.1452
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTInteractive.ml?cvsroot=mldonkey&r1=1.158&r2=1.159
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/net/basicSocket.ml?cvsroot=mldonkey&r1=1.33&r2=1.34
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/net/basicSocket.mli?cvsroot=mldonkey&r1=1.16&r2=1.17
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/net/http_client.ml?cvsroot=mldonkey&r1=1.40&r2=1.41
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/net/http_client.mli?cvsroot=mldonkey&r1=1.9&r2=1.10
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/net/tcpBufferedSocket.ml?cvsroot=mldonkey&r1=1.48&r2=1.49
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/net/tcpBufferedSocket.mli?cvsroot=mldonkey&r1=1.18&r2=1.19

Patches:
Index: distrib/ChangeLog
===================================================================
RCS file: /sources/mldonkey/mldonkey/distrib/ChangeLog,v
retrieving revision 1.1451
retrieving revision 1.1452
diff -u -b -r1.1451 -r1.1452
--- distrib/ChangeLog   28 Jul 2010 16:24:13 -0000      1.1451
+++ distrib/ChangeLog   28 Jul 2010 16:25:43 -0000      1.1452
@@ -15,6 +15,7 @@
 =========
 
 2010/07/28
+7262: BT: improve porttest (ygrek)
 7254: BT/bandwidth controllers: accept incoming connections while downloading
 - should improve upload when downlink is saturated (ygrek)
 

Index: src/networks/bittorrent/bTInteractive.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/bittorrent/bTInteractive.ml,v
retrieving revision 1.158
retrieving revision 1.159
diff -u -b -r1.158 -r1.159
--- src/networks/bittorrent/bTInteractive.ml    18 Jul 2010 14:49:59 -0000      
1.158
+++ src/networks/bittorrent/bTInteractive.ml    28 Jul 2010 16:25:44 -0000      
1.159
@@ -81,6 +81,38 @@
   with _ ->
     failure_message "%s" "broken bencoded value"
 
+let interpret_utorrent_porttest s =
+  if String2.contains s "<div class=\"status-image\">OK!</div>" then
+    "Port test OK!"
+  else
+    "Port is not accessible"
+
+let perform_porttests tests =
+  match tests with
+  | [] -> porttest_result := PorttestResult (last_time(), "No tests available")
+  | _ ->
+  let module H = Http_client in
+  porttest_result := PorttestInProgress (last_time ());
+  let rec loop = function
+  | [] -> ()
+  | (url,interpret)::other ->
+    let r = {
+      H.basic_request with
+      H.req_url = Url.of_string url;
+      H.req_user_agent = get_user_agent ();
+      (* no sense in using proxy anyway *)
+(*       H.req_proxy = !CommonOptions.http_proxy; *)
+      H.req_max_total_time = 45.;
+    } 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);
+        loop other)
+      (fun _ _ -> ())
+  in
+  loop tests
+
 let op_file_all_sources file =
   let list = ref [] in
   Hashtbl.iter (fun _ c ->
@@ -1385,22 +1417,13 @@
     ]);
   network.op_network_porttest_result <- (fun _ -> !porttest_result);
   network.op_network_porttest_start <- (fun _ -> 
-      let module H = Http_client in
       azureus_porttest_random := (Random.int 100000);
-      porttest_result := PorttestInProgress (last_time ());
-      let r = {
-          H.basic_request with
-          H.req_url =
-            Url.of_string (Printf.sprintf
-              
"http://azureus.aelitis.com/natcheck.php?port=%d&check=azureus_rand_%d";
-                !!client_port !azureus_porttest_random);
-          H.req_proxy = !CommonOptions.http_proxy;
-          H.req_user_agent = get_user_agent ();
-        } in
-      H.wget r (fun file ->
-        let result = interpret_azureus_porttest (File.to_string file) in
-        porttest_result := PorttestResult (last_time (), result)
-      )
+      let tests = [
+        Printf.sprintf "http://www.utorrent.com/testport?port=%d"; 
!!client_port, interpret_utorrent_porttest;
+        Printf.sprintf 
"http://azureus.aelitis.com/natcheck.php?port=%d&check=azureus_rand_%d";
+          !!client_port !azureus_porttest_random, interpret_azureus_porttest;
+      ] in
+      perform_porttests tests
   );
   network.op_network_check_upload_slots <- (fun _ -> check_bt_uploaders ());
   client_ops.op_client_info <- op_client_info;

Index: src/utils/net/basicSocket.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/net/basicSocket.ml,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -b -r1.33 -r1.34
--- src/utils/net/basicSocket.ml        22 Oct 2009 19:54:49 -0000      1.33
+++ src/utils/net/basicSocket.ml        28 Jul 2010 16:25:44 -0000      1.34
@@ -194,6 +194,13 @@
   | Closed_for_exception e -> Printf.sprintf "exception %s"
         (Printexc2.to_string e)
 
+let string_of_basic_event = function
+| CLOSED s -> Printf.sprintf "CLOSED %s" (string_of_reason s)
+| RTIMEOUT -> "RTIMEOUT"
+| LTIMEOUT -> "LTIMEOUT"
+| WTIMEOUT -> "WTIMEOUT"
+| CAN_READ -> "CAN_READ"
+| CAN_WRITE -> "CAN_WRITE"
 
 (*************************************************************************)
 (*                                                                       *)

Index: src/utils/net/basicSocket.mli
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/net/basicSocket.mli,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -b -r1.16 -r1.17
--- src/utils/net/basicSocket.mli       21 Nov 2006 22:34:34 -0000      1.16
+++ src/utils/net/basicSocket.mli       28 Jul 2010 16:25:44 -0000      1.17
@@ -111,6 +111,7 @@
 val current_time : unit -> float
   
 val string_of_reason : close_reason -> string
+val string_of_basic_event : event -> string
   
 val loop_delay : float ref
 

Index: src/utils/net/http_client.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/net/http_client.ml,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -b -r1.40 -r1.41
--- src/utils/net/http_client.ml        8 May 2007 16:33:32 -0000       1.40
+++ src/utils/net/http_client.ml        28 Jul 2010 16:25:45 -0000      1.41
@@ -52,6 +52,7 @@
     req_retry : int;
     req_max_retry : int;
     req_save : bool;
+    req_max_total_time : float;
   }
 
 type content_handler = 
@@ -74,6 +75,7 @@
     req_retry = 0;
     req_max_retry = 0;
     req_save = false;
+    req_max_total_time = infinite_timeout;
   }
       
 let make_full_request r =
@@ -210,6 +212,11 @@
 let def_ferr = (fun c -> ())
 
 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 
+  in
   let rec get_url level r =
   try
     let url = r.req_url in
@@ -227,26 +234,12 @@
         let sock = TcpBufferedSocket.connect token "http client connecting"
         (try Ip.to_inet_addr ip with e -> raise Not_found) port
         (fun sock e -> 
-              () 
-(*              if !verbose then
-                  lprintf "Event %s\n"
-                    (match e with
-                      CONNECTED -> "CONNECTED"
-                    | WRITE_DONE -> "WRITE_DONE"
-                    | CAN_REFILL -> "CAN_REFILL"
-                    | BUFFER_OVERFLOW -> "BUFFER_OVERFLOW"
-                    | READ_DONE n -> Printf.sprintf "READ_DONE %d" n
-                    | BASIC_EVENT e ->
-                        match e with
-                          (CLOSED s) -> Printf.sprintf "CLOSED %s" 
(string_of_reason s)
-                        | RTIMEOUT -> "RTIMEOUT"
-                        | LTIMEOUT -> "LTIMEOUT"
-                        | WTIMEOUT -> "WTIMEOUT"
-                        | CAN_READ -> "CAN_READ"
-                        | CAN_WRITE -> "CAN_WRITE"
-                    )
- *)
-          )
+(*             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 LTIMEOUT -> close sock Closed_for_lifetime
+            | _ -> ())
         in
 
         let nread = ref false in
@@ -256,6 +249,7 @@
         TcpBufferedSocket.set_reader sock (http_reply_handler nread
             (default_headers_handler url level));
         set_rtimeout sock 5.;
+        set_lifetime sock r.req_max_total_time;
     )
     ferr;
   with e -> 
@@ -270,13 +264,8 @@
     in
     if !verbose then print_headers ();
     match ans_code with
-      200 ->
-        TcpBufferedSocket.set_closer sock
-            (fun _ _ -> 
-              (* lprintf "default_headers_handler closer\n"; *)
-              f ()
-            );
-
+    | 200 ->
+        ok := true;
         let content_length = ref (-1L) in
         List.iter (fun (name, content) ->
             if String.lowercase name = "content-length" then
@@ -445,7 +434,7 @@
 
 let whead r f = whead2 r f def_ferr
 
-let wget_string r f progress =
+let wget_string r f ?(ferr=def_ferr) progress =
     
   let file_buf = Buffer.create 1000 in
   let file_size = ref 0L in
@@ -469,7 +458,7 @@
         end)
   (fun _ ->  
       f (Buffer.contents file_buf)
-  ) def_ferr
+  ) ferr
 
 
 let split_header header =

Index: src/utils/net/http_client.mli
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/net/http_client.mli,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -b -r1.9 -r1.10
--- src/utils/net/http_client.mli       8 May 2007 16:33:32 -0000       1.9
+++ src/utils/net/http_client.mli       28 Jul 2010 16:25:45 -0000      1.10
@@ -44,6 +44,8 @@
     req_retry : int;
     req_max_retry : int;
     req_save : bool;
+    (** maximum time whole request processing is allowed to take, in seconds *)
+    req_max_total_time : float;
   }
 
 type content_handler = 
@@ -56,7 +58,7 @@
 val whead : request -> ( (string * string) list -> unit) -> unit
 val whead2 : request -> ( (string * string) list -> unit) -> (int -> unit) -> 
unit
 
-val wget_string : request -> (string -> unit) ->
+val wget_string : request -> (string -> unit) -> ?ferr:(int -> unit) ->
   (int -> int64 -> unit) -> unit
 
   

Index: src/utils/net/tcpBufferedSocket.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/net/tcpBufferedSocket.ml,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -b -r1.48 -r1.49
--- src/utils/net/tcpBufferedSocket.ml  28 Jul 2010 16:24:13 -0000      1.48
+++ src/utils/net/tcpBufferedSocket.ml  28 Jul 2010 16:25:45 -0000      1.49
@@ -59,6 +59,14 @@
 | READ_DONE of int
 | BASIC_EVENT of BasicSocket.event
 
+let string_of_event = function
+| CONNECTED -> "CONNECTED"
+| WRITE_DONE -> "WRITE_DONE"
+| CAN_REFILL -> "CAN_REFILL"
+| BUFFER_OVERFLOW -> "BUFFER_OVERFLOW"
+| READ_DONE n -> Printf.sprintf "READ_DONE %d" n
+| BASIC_EVENT e -> string_of_basic_event e
+
 type token = {
     mutable token_used : bool;
     connection_manager : connection_manager;

Index: src/utils/net/tcpBufferedSocket.mli
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/net/tcpBufferedSocket.mli,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -b -r1.18 -r1.19
--- src/utils/net/tcpBufferedSocket.mli 25 Jul 2007 19:27:10 -0000      1.18
+++ src/utils/net/tcpBufferedSocket.mli 28 Jul 2010 16:25:45 -0000      1.19
@@ -175,3 +175,6 @@
 val output_buffered : t -> int
   
 val get_latencies : bool ref -> string
+
+val string_of_event : event -> string
+