
CommonWeb: add support for several web ip blocking
lists. Specifically, added support for hooks before and after web info
resources fetching.

In CommonBlocking: creates a merged list of all blocked ranges, for
improved efficiency, and for block_list output. Ready for several
local lists, too. Keep hits separate from ranges, so they're not lost
during changes.

ip_set: added a function to merge two blocking lists, with optimization.
removed merging feature from file loading

DriverCommands: "block_list": Display IP of hits instead of
ranges. Replaced hackish html output with correct html_mods
code. added "block_reset" to reset hits statistics.

TODO: Whitelists! Doable, but I think there's enough code to
test/debug for now ;)

Index: src/daemon/common/commonBlocking.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonBlocking.ml,v
retrieving revision 1.2
diff -u -r1.2 commonBlocking.ml
--- src/daemon/common/commonBlocking.ml	3 Apr 2006 20:35:05 -0000	1.2
+++ src/daemon/common/commonBlocking.ml	16 Apr 2006 16:25:28 -0000
@@ -19,14 +19,38 @@
 
 open Printf2
 
+(* prints a new logline with date, module and starts newline *)
+let lprintf_nl = (fun fmt ->
+  lprintf "%s[CommonBlocking] "
+    (log_time ()); lprintf_nl2 fmt)
+
+(* prints a new logline with date, module and does not start newline *)
+let lprintf_n = (fun fmt ->
+  lprintf "%s[CommonBlocking] "
+    (log_time ()); lprintf fmt)
+
 (* list of functions to call when banning changes *)
 let update_hooks = ref []
 
 let add_update_hook f =
   update_hooks := f :: !update_hooks
 
-let ip_blocking_list = ref Ip_set.bl_empty
-let web_ip_blocking_list = ref Ip_set.bl_empty
+(* ranges come and go, keep hits separate from ranges *)
+type hit = {
+  mutable hit_reason : string;
+  mutable hit_count : int;
+}
+
+let hits : (Ip.t, hit) Hashtbl.t = Hashtbl.create 13
+
+let hits_reset () = Hashtbl.clear hits
+
+(* list of filenames *)
+let ip_blocking_list : string list ref = ref []
+(* list of url -> filenames associations *)
+let web_ip_blocking_list : (string * string) list ref = ref []
+let merged_ip_blocking_list = ref Ip_set.bl_empty
+
 let country_blocking_block = ref false
 let country_blocking_list = 
   Array.create (Array.length Geoip.country_code_array) false
@@ -44,26 +68,58 @@
       Geoip.country_name_array.(index))
   else None
 
+let check_ip ip =
+  if Ip.local_ip ip then None else
+    let block = ip_set_hit !merged_ip_blocking_list ip in
+    if block <> None then block else
+      let block = geoip_hit country_blocking_list ip in
+      if block <> None then block else 
+	None
+
 let update_bans () =
+  merged_ip_blocking_list := 
+    Ip_set.bl_optimize (
+      List.fold_left 
+	(fun bl (url, fn) -> 
+	  try
+	    Ip_set.bl_merge bl (Ip_set.load fn)
+	  with e ->
+	    lprintf_nl "Exception %s while loading web list %s"
+	      (Printexc2.to_string e) fn; 
+	    bl)
+	(List.fold_left 
+	  (fun bl fn -> 
+	    try
+	      Ip_set.bl_merge bl (Ip_set.load fn)
+	    with e ->
+	      lprintf_nl "Exception %s while loading local list %s"
+		(Printexc2.to_string e) fn; 
+	      bl)
+	  Ip_set.bl_empty !ip_blocking_list)
+      !web_ip_blocking_list);
   Ip.banned :=
     (fun ip ->
-      if Ip.local_ip ip then None else
-      let block = ip_set_hit !web_ip_blocking_list ip in
-      if block <> None then block else
-      let block = ip_set_hit !ip_blocking_list ip in
-      if block <> None then block else
-      let block = geoip_hit country_blocking_list ip in
-      if block <> None then block else 
-      None
+      let reason = check_ip ip in
+      (match reason with
+	| None -> ()
+	| Some reason ->
+	    (* maybe that could be made optional, if someone minds
+	       memory more than block_list output ? *)
+	    let entry =
+	      try
+		Hashtbl.find hits ip 
+	      with Not_found ->
+		let entry = { hit_reason = reason; hit_count = 0 } in
+		Hashtbl.add hits ip entry;
+		entry in
+	    entry.hit_reason <- reason;
+	    entry.hit_count <- entry.hit_count + 1);
+      reason
     );
   List.iter (fun f -> f ()) !update_hooks
 
 let set_ip_blocking_list filename =
-  ip_blocking_list :=
-    if filename = "" then
-      Ip_set.bl_empty
-    else
-      Ip_set.load filename;
+  ip_blocking_list := if filename = "" then [] else [filename];
   update_bans ()
 
 let set_geoip_dat filename =
@@ -91,25 +147,39 @@
   update_bans ()
 
 let _ =
+  let need_updating = ref false in
+  CommonWeb.add_web_before_hook (fun web_infos ->
+    need_updating := false;
+    let new_web_list =
+      List.fold_left (fun l (kind, _, url) -> 
+	if kind = "guarding.p2p" then
+	  (url, 
+	  try 
+	    List.assoc url !web_ip_blocking_list 
+	  with Not_found  -> "") :: l
+	else l) [] web_infos in
+    (* comparing lists that way is probably sufficient but not
+       necessary *)
+    if !web_ip_blocking_list <> new_web_list then begin
+      web_ip_blocking_list := new_web_list;
+      need_updating := true
+    end);
   CommonWeb.add_web_kind "guarding.p2p"
     "IP blocking lists (ipfilter and guardian v2 formats)"
-    (fun _ filename ->
-    try
-      web_ip_blocking_list :=
-	if filename = "" then
-	  Ip_set.bl_empty
-	else
-	  Ip_set.load filename;
-      update_bans ()
-    with _ -> ());
+    (fun url filename ->
+      web_ip_blocking_list := List.remove_assoc url !web_ip_blocking_list;
+      if filename <> "" then
+	web_ip_blocking_list := (url, filename) :: !web_ip_blocking_list;
+      need_updating := true);
+  CommonWeb.add_web_after_hook (fun _ ->
+    if !need_updating then update_bans ()
+  );
   CommonWeb.add_web_kind "geoip.dat" "IP to country mapping database"
     (fun _ filename ->
     Geoip.init (Geoip.unpack filename);
     update_bans ());
 
   Heap.add_memstat "CommonBlocking" (fun level buf ->
-      Printf.bprintf buf "  local ranges: %d\n" 
-	(Ip_set.bl_length !ip_blocking_list);
-      Printf.bprintf buf "  web ranges: %d\n" 
-	(Ip_set.bl_length !web_ip_blocking_list)
+      Printf.bprintf buf "  ranges: %d\n" 
+	(Ip_set.bl_length !merged_ip_blocking_list)
    )
Index: src/daemon/common/commonWeb.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonWeb.ml,v
retrieving revision 1.29
diff -u -r1.29 commonWeb.ml
--- src/daemon/common/commonWeb.ml	29 Mar 2006 14:22:08 -0000	1.29
+++ src/daemon/common/commonWeb.ml	16 Apr 2006 16:25:29 -0000
@@ -40,11 +40,19 @@
 (*************************************************************************)
 
 let file_kinds = ref []
+let before_hooks = ref []
+let after_hooks = ref []
 
 let add_web_kind kind descr f =
   let kind_record = { f = f; description = descr } in
   file_kinds := (kind, kind_record) :: !file_kinds
 
+let add_web_before_hook f =
+  before_hooks := f :: !before_hooks
+  
+let add_web_after_hook f =
+  after_hooks := f :: !after_hooks
+  
 let mldonkey_wget url f =
   let module H = Http_client in
   let r = {
@@ -154,6 +162,11 @@
 (*************************************************************************)
 
 let load_web_infos core_start =
+  List.iter (fun f ->
+    try f !!CommonOptions.web_infos with e ->
+      lprintf_nl "[cWeb] %s before loading web resources"
+	(Printexc2.to_string e)
+  ) !before_hooks;
   List.iter (fun (kind, period, url) ->
     if (core_start && period = 0) || (period <> 0 && !hours mod period = 0) then
       begin
@@ -163,7 +176,12 @@
             lprintf_nl "[cWeb] %s while loading %s"
 	      (Printexc2.to_string e) url
       end
-  ) !!CommonOptions.web_infos
+  ) !!CommonOptions.web_infos;
+  List.iter (fun f ->
+    try f !!CommonOptions.web_infos with e ->
+      lprintf_nl "[cWeb] %s after loading web resources"
+	(Printexc2.to_string e)
+  ) !after_hooks
 
 type rss_feed = {
     mutable rss_date : int;
Index: src/daemon/driver/driverCommands.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/driver/driverCommands.ml,v
retrieving revision 1.135
diff -u -r1.135 driverCommands.ml
--- src/daemon/driver/driverCommands.ml	9 Apr 2006 00:27:03 -0000	1.135
+++ src/daemon/driver/driverCommands.ml	16 Apr 2006 16:25:31 -0000
@@ -376,7 +376,7 @@
                   onClick=\\\"parent.fstatus.location.href='submit?q=friend_add+%d'\\\"
                   onMouseOver=\\\"mOvr(this);\\\"
                   onMouseOut=\\\"mOut(this);\\\"\\>"
-                    (if (!counter mod 2 == 0) then "dl-1" else "dl-2") num;
+                    (if (!counter mod 2 = 0) then "dl-1" else "dl-2") num;
                     client_print c o;
                     if use_html_mods o then
                     html_mods_td buf ([
@@ -3214,19 +3214,35 @@
 
     "block_list", Arg_none (fun o ->
       let buf = o.conn_buf in
-        if o.conn_output = HTML then
-          let mybuf = Buffer.create 1000 in
-          let mytable = ref [] in
-	  Ip_set.print_list mybuf !CommonBlocking.ip_blocking_list;
-          let listtmp = String2.split (Buffer.contents mybuf) '\n' in
-           (List.iter (fun s ->
-             mytable := !mytable @ [ ("", "srh", s); ]
-            ) listtmp);
-          html_mods_table_one_col buf "serversTable" "servers" !mytable
-        else
-	  Ip_set.print_list buf !CommonBlocking.ip_blocking_list;
+      let counter = ref 0 in
+      if o.conn_output = HTML then
+	html_mods_table_header buf "block_listTable" "results" [
+	  ( "0", "srh", "Name", "IP" ) ;
+	  ( "0", "srh", "Name", "Reason" ) ;
+	  ( "0", "srh", "Hits", "Number of hits" ) ];
+      let print_hit n ip = 
+	let hit = Hashtbl.find CommonBlocking.hits ip in
+	if o.conn_output = HTML then begin
+	  Printf.bprintf buf "\\<tr class=\\\"%s\\\"\\>"
+	    (if !counter mod 2 = 0 then "dl-1" else "dl-2");
+	  html_mods_td buf [
+	    ("", "sr", Ip.to_string ip);
+	    ("", "sr", hit.CommonBlocking.hit_reason);
+	    ("", "sr", string_of_int hit.CommonBlocking.hit_count) ];
+	  Printf.bprintf buf "\\</tr\\>";
+	  incr counter
+	end else
+	  Printf.bprintf buf "%s (%d hits): %s\n" (Ip.to_string ip)
+	    hit.CommonBlocking.hit_count hit.CommonBlocking.hit_reason;
+      	n + hit.CommonBlocking.hit_count in
+      let ips = Hashtbl.fold (fun ip hits acc -> ip :: acc)
+	CommonBlocking.hits [] in
+      (* could sort with something else, like number of hits ? *)
+      let sorted_ips = List.sort Ip.compare ips in
+      let nhits = List.fold_left print_hit 0 sorted_ips in
+      Printf.bprintf buf "%d ranges, %d hits\n" (Ip_set.bl_length !CommonBlocking.merged_ip_blocking_list) nhits;
       _s ""
-    ), ":\t\t\t\tdisplay the list of blocked IP ranges that were hit";
+    ), ":\t\t\t\tdisplay the list of blocked IPs";
 
     "block_test", Arg_one (fun arg o ->
       let ip = Ip.of_string arg in
@@ -3235,4 +3251,9 @@
         | Some reason ->
           Printf.sprintf "Blocked, %s\n" reason)
     ), "<ip> :\t\t\tcheck whether an IP is blocked";
+
+    "block_reset", Arg_none (fun o ->
+      CommonBlocking.hits_reset ();
+        _s "done"
+    ), ":\t\t\t\tClear blocked IPs list";
   ]
Index: src/daemon/driver/driverInteractive.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/driver/driverInteractive.ml,v
retrieving revision 1.72
diff -u -r1.72 driverInteractive.ml
--- src/daemon/driver/driverInteractive.ml	29 Mar 2006 15:41:33 -0000	1.72
+++ src/daemon/driver/driverInteractive.ml	16 Apr 2006 16:25:32 -0000
@@ -1811,9 +1811,8 @@
       ^ "\nServer usage:\t " ^ (if !!enable_servers then "enabled" else "disabled (you are not able to connect to ED2K Servers)")
       ^ "\nGeoip:\t\t " ^ (if !Geoip.active then "enabled, GeoLite data created by MaxMind, available from http://maxmind.com/"
           else dis_mess)
-      ^ (Printf.sprintf "\nIP blocking local: %d ranges, web: %d ranges"
-          (Ip_set.bl_length !CommonBlocking.ip_blocking_list)
-          (Ip_set.bl_length !CommonBlocking.web_ip_blocking_list))
+      ^ (Printf.sprintf "\nIP blocking: %d ranges"
+          (Ip_set.bl_length !CommonBlocking.merged_ip_blocking_list))
       ^ (if not !dns_works then
 	    Printf.sprintf "\nDNS:\t\t DNS resolution not available, web_infos %s not work"
 	      (if Autoconf.bittorrent = "yes" then "and BT does" else "do")
Index: src/utils/net/ip_set.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/net/ip_set.ml,v
retrieving revision 1.26
diff -u -r1.26 ip_set.ml
--- src/utils/net/ip_set.ml	3 Apr 2006 20:50:09 -0000	1.26
+++ src/utils/net/ip_set.ml	16 Apr 2006 16:25:33 -0000
@@ -43,7 +43,6 @@
   blocking_description: string;
   blocking_begin: Ip.t;
   blocking_end: Ip.t;
-  mutable blocking_hits: int
 }
 
 let store_blocking_descriptions = ref true
@@ -77,12 +76,6 @@
 	else
 (* Be lazy. The optimizer will deal with it. *)
 	  fixup (BL_Range (red, left, br2, (ins right br)))
-(*	  let newr = {
-	    blocking_description = br.blocking_description;
-	    blocking_begin = ip_mini br.blocking_begin br2.blocking_begin;
-	    blocking_end = ip_maxi br.blocking_end br2.blocking_end;
-	    blocking_hits = br.blocking_hits + br2.blocking_hits } in
-	  BL_Range (red, left, newr, right) *)
 
 and fixup bl =
   match bl with
@@ -98,25 +91,17 @@
       BL_Empty -> BL_Empty
     | BL_Range(_, left, v, right) -> BL_Range(false, left, v, right)
 
-let rec match_ip_aux bl ip =
+let rec match_ip bl ip =
   match bl with
       BL_Empty -> None
     | BL_Range (red, left, br, right) ->
 	if Ip.compare ip br.blocking_begin < 0 then
-	  match_ip_aux left ip
+	  match_ip left ip
 	else if Ip.compare ip br.blocking_end > 0 then
-	  match_ip_aux right ip
+	  match_ip right ip
 	else
 	  Some br
 
-let match_ip bl ip =
-  let m = match_ip_aux bl ip in
-  (match m with
-      Some br ->
-	br.blocking_hits <- br.blocking_hits + 1
-    | None -> ());
-  m
-
 let rec bl_fold_left f acc bl =
   match bl with
       BL_Empty -> acc
@@ -134,14 +119,12 @@
 	  if Ip.compare br.blocking_begin (Ip.succ pbr.blocking_end) > 0 then
 	    (add_range new_bl pbr, Some br)
 	  else 
-	    let hits_sum = br.blocking_hits + pbr.blocking_hits in
 (* next range merge with pending one, does it extend it ? *)
 	    if Ip.compare br.blocking_end pbr.blocking_end > 0 then
-	    (new_bl, Some { pbr with blocking_end = br.blocking_end;
-			    blocking_hits = hits_sum })
+	    (new_bl, Some { pbr with blocking_end = br.blocking_end })
 	  else 
 (* no, it doesn't *)
-	    (new_bl, Some { pbr with blocking_hits = hits_sum })
+	    (new_bl, Some pbr)
   in
 
 (* start with no current range *)
@@ -151,6 +134,9 @@
       None -> new_bl
     | Some pbr -> add_range new_bl pbr
 
+let bl_merge bl1 bl2 =
+  bl_fold_left (fun br acc -> add_range acc br) bl1 bl2
+
 let bl_length bl =
   bl_fold_left (fun br acc -> acc+1) 0 bl
 
@@ -164,11 +150,11 @@
     last_ip := Some (Ip.succ br.blocking_end)
   in bl_fold_left check () bl
 
-let load_merge bl filename remove =
+let bl_load filename =
   let guardian_regexp = Str.regexp "^\\(.*\\): *\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)-\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" in
   let ipfilter_regexp = Str.regexp "^\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\) *- *\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\) *, *[0-9]+ *, *\\(.*\\)$" in
 
-  let bl = ref bl in
+  let bl = ref bl_empty in
   let nranges = ref 0 in
   let error = ref false in
   Unix2.tryopen_read filename (fun cin ->
@@ -185,8 +171,7 @@
 	      else 
 		unknown_description;
 	      blocking_begin = Ip.of_string (Str.matched_group 1 line);
-	      blocking_end = Ip.of_string (Str.matched_group 2 line);
-	      blocking_hits = 0 } in
+	      blocking_end = Ip.of_string (Str.matched_group 2 line) } in
 	    bl := add_range !bl br;
 	    incr nranges
 	  end else 
@@ -197,8 +182,7 @@
 		else 
 		  unknown_description;
 	        blocking_begin = Ip.of_string (Str.matched_group 2 line);
-	        blocking_end = Ip.of_string (Str.matched_group 3 line);
-	        blocking_hits = 0 } in
+	        blocking_end = Ip.of_string (Str.matched_group 3 line) } in
 	      bl := add_range !bl br;
 	      incr nranges
 	    end else 
@@ -213,9 +197,9 @@
     done
   with End_of_file -> ());
   if !error then lprint_newline ();
-  if remove then (try Sys.remove filename with _ -> ());
   let optimized_bl = bl_optimize !bl in
-  lprintf_nl () "%d ranges loaded - optimized to %d" !nranges (bl_length optimized_bl);
+  lprintf_nl () "%d ranges loaded - optimized to %d" !nranges
+    (bl_length optimized_bl);
 (*    bl_optimizedp optimized_bl;
     for i=0 to 999999 do
       let random_ip = Ip.of_ints (Random.int 256, Random.int 256, Random.int 256, Random.int 256) in
@@ -226,6 +210,11 @@
     done; *)
   optimized_bl
 
+let bl_load_and_remove filename =
+  let bl = bl_load filename in
+  (try Sys.remove filename with _ -> ());
+  bl
+
 let load filename =
   lprintf_nl () "loading %s" filename;
   if Sys.file_exists filename then
@@ -244,7 +233,7 @@
 		      let file = Zip.find_entry ic h in
 		      lprintf_nl () "%s found in zip file" h;
 		      ignore(Misc.archive_extract filename "zip");
-		      load_merge bl_empty file.Zip.filename true
+		      bl_load_and_remove file.Zip.filename
 		    with Not_found ->
 		      find_in_zip q in
 	    find_in_zip filenames_list
@@ -269,7 +258,7 @@
 	      if String2.check_suffix ext ".bz2" then "bz2" else "gz" in
 	    (try
 	      let s = Misc.archive_extract filename filetype in
-	      load_merge bl_empty s true
+	      bl_load_and_remove s
 	    with e ->
 	      lprintf_nl () "Exception %s while extracting from %s"
 		(Printexc2.to_string e) filename;
@@ -278,7 +267,7 @@
         | ".tar.gz" | ".p2p.tar.gz" | ".dat.tar.gz" ->
 	    lprintf_nl () "tar files are not (yet) supported, please untar %s" filename;
 	    bl_empty
-        | _ -> load_merge bl_empty filename false
+        | _ -> bl_load filename
   else
     begin
       lprintf_nl () "file %s not found" filename;
@@ -295,47 +284,34 @@
 	      255, 255, 255, 255 -> 
 		{ blocking_description = unknown_description;
 		  blocking_begin = Ip.of_ints (0, 0, 0, 0);
-		  blocking_end = Ip.of_ints (255, 255, 255, 255);
-		  blocking_hits = 0 }
+		  blocking_end = Ip.of_ints (255, 255, 255, 255) }
 	    | a, 255, 255, 255 -> 
 		{ blocking_description = unknown_description;
 		  blocking_begin = Ip.of_ints (a, 0, 0, 0);
-		  blocking_end = Ip.of_ints (a, 255, 255, 255);
-		  blocking_hits = 0 }
+		  blocking_end = Ip.of_ints (a, 255, 255, 255) }
 	    | a, b, 255, 255 -> 
 		{ blocking_description = unknown_description;
 		  blocking_begin = Ip.of_ints (a, b, 0, 0);
-		  blocking_end = Ip.of_ints (a, b, 255,255);
-		  blocking_hits = 0 }
+		  blocking_end = Ip.of_ints (a, b, 255,255) }
 	    | a, b, c, 255 -> 
 		{ blocking_description = unknown_description;
 		  blocking_begin = Ip.of_ints (a, b, c, 0);
-		  blocking_end = Ip.of_ints (a, b, c, 255);
-		  blocking_hits = 0 }
+		  blocking_end = Ip.of_ints (a, b, c, 255) }
 	    | _ -> 
 		{ blocking_description = unknown_description;
 		  blocking_begin = h;
-		  blocking_end = h;
-		  blocking_hits = 0 } in
+		  blocking_end = h } in
 	  of_list_aux q (add_range bl range) in
   of_list_aux l BL_Empty
 
 let print_list buf bl =
-  let rec print_list_aux bl =
-    match bl with
-        BL_Empty -> 0
-      | BL_Range (red, left, br, right) ->
-          let nleft = print_list_aux left in
-          if br.blocking_hits > 0 then
-            Printf.bprintf buf "%s (%d hits): %s - %s\n" 
-              br.blocking_description
-              br.blocking_hits
-              (Ip.to_string br.blocking_begin)
-              (Ip.to_string br.blocking_end);
-          let nright = print_list_aux right in
-          nleft + 1 + nright in
-
-  let nranges = print_list_aux bl in
+  let print_range br acc =
+    Printf.bprintf buf "%s: %s - %s\n" 
+      br.blocking_description
+      (Ip.to_string br.blocking_begin)
+      (Ip.to_string br.blocking_end);
+    acc+1 in
+  let nranges = bl_fold_left print_range 0 bl in
   Printf.bprintf buf "%d ranges\n" nranges
 
 (*
