src/daemon/driver/driverCommands.ml

   1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20 open Int64ops
  21 open Printf2
  22 open Md4
  23 open Options
  24 open BasicSocket
  25 open TcpBufferedSocket
  26 open Ip_set
  27
  28 open GuiTypes
  29
  30 open CommonDownloads
  31 open CommonResult
  32 open CommonMessages
  33 open CommonGlobals
  34 open CommonShared
  35 open CommonSearch
  36 open CommonClient
  37 open CommonServer
  38 open CommonNetwork
  39 open CommonTypes
  40 open CommonFile
  41 open CommonComplexOptions
  42 open CommonOptions
  43 open CommonUserDb
  44 open CommonInteractive
  45 open CommonEvent
  46 open UpnpClient
  47
  48 open DriverInteractive
  49
  50 open Gettext
  51 open Autoconf
  52
  53 module VB = VerificationBitmap
  54
  55 let log_prefix = "[dCmd]"
  56
  57 let lprintf_nl fmt =
  58   lprintf_nl2 log_prefix fmt
  59
  60 let lprintf_n fmt =
  61   lprintf2 log_prefix fmt
  62
  63 let _s x = _s "DriverCommands" x
  64 let _b x = _b "DriverCommands" x
  65
  66 type command_links_data = {
  67   filename : string;
  68   filesize : int64;
  69   fileid : Md4.t;
  70   }
  71
  72 let to_cancel = ref []
  73
  74 let files_to_cancel o =
  75   let buf = o.conn_buf in
  76   Printf.bprintf buf (_b "Files to be cancelled:\n");
  77   List.iter (fun file ->
  78       file_print file o
  79   ) !to_cancel;
  80   "Type 'confirm yes/no' to cancel them"
  81
  82 let execute_command arg_list output cmd args =
  83   if !verbose then
  84     lprintf_nl "execute command %S %s" cmd (String.concat " " (List.map (Printf.sprintf "%S") args));
  85   let buf = output.conn_buf in
  86   try
  87     let rec iter list =
  88       match list with
  89         [] ->
  90           Gettext.buftext buf no_such_command cmd
  91       | (command, _, arg_kind, help) :: tail ->
  92           if command = cmd then begin
  93             if !verbose_user_commands && not (user2_is_admin output.conn_user.ui_user) then
  94               lprintf_nl "user %s issued command %s%s"
  95                 output.conn_user.ui_user.user_name
  96                 cmd
  97                 (if args = [] then "" else ", args " ^ String.concat " " args);
  98             Buffer.add_string buf (
  99               match arg_kind, args with
 100                 Arg_none f, [] -> f output
 101               | Arg_multiple f, _ -> f args output
 102               | Arg_one f, [arg] -> f arg  output
 103               | Arg_two f, [a1;a2] -> f a1 a2 output
 104               | Arg_three f, [a1;a2;a3] -> f a1 a2 a3 output
 105               | _ -> bad_number_of_args command help
 106             )
 107             end
 108           else
 109             iter tail
 110     in
 111     iter arg_list
 112   with Not_found -> ()
 113
 114 let list_options_html o list =
 115   let buf = o.conn_buf in
 116   if !!html_mods_use_js_helptext then
 117     html_mods_table_header buf "upstatsTable" "upstats" [
 118       ( Str, "srh", "Option name", "Name (Help=mouseOver)" ) ;
 119       ( Str, "srh", "Option value", "Value (press ENTER to save)" ) ;
 120       ( Str, "srh", "Option default", "Default" );
 121       ( Str, "srh", "Option type", "Type" );
 122     ]
 123   else
 124     html_mods_table_header buf "voTable" "vo" [
 125       ( Str, "srh", "Option name", "Name" ) ;
 126       ( Str, "srh", "Option value", "Value (press ENTER to save)" ) ;
 127       ( Str, "srh", "Option default", "Default" ) ;
 128       ( Str, "srh", "Option type", "Type" );
 129       ( Str, "srh", "Option description", "Help" ) ];
 130
 131   html_mods_cntr_init ();
 132
 133   List.iter (fun o ->
 134       Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"" (html_mods_cntr ());
 135
 136         if !!html_mods_use_js_helptext then
 137           Printf.bprintf buf " onMouseOver=\\\"mOvr(this);setTimeout('popLayer(\\\\\'%s\\\\\')',%d);setTimeout('hideLayer()',%d);return true;\\\" onMouseOut=\\\"mOut(this);hideLayer();setTimeout('hideLayer()',%d)\\\"\\>"
 138           (Str.global_replace (Str.regexp "\n") "\\<br\\>" (Http_server.html_real_escaped o.option_help)) !!html_mods_js_tooltips_wait !!html_mods_js_tooltips_timeout !!html_mods_js_tooltips_wait
 139         else
 140           Printf.bprintf buf "\\>";
 141
 142       if String.contains o.option_value '\n' then
 143         Printf.bprintf buf "\\<td class=\\\"sr\\\"\\>
 144 \\<a href=\\\"http://mldonkey.sourceforge.net/%s\\\"\\>%s\\</a\\>
 145 \\<form action=\\\"submit\\\" target=\\\"$S\\\" onsubmit=\\\"javascript: {setTimeout('window.location.replace(window.location.href)',500);}\\\"\\>
 146 \\<input type=hidden name=setoption value=q\\>\\<input type=hidden name=option value=%s\\>\\</td\\>
 147 \\<td\\>\\<textarea name=value rows=5 cols=20 wrap=virtual\\>%s\\</textarea\\>
 148 \\<input type=submit value=Modify\\>"
 149                   (String2.upp_initial o.option_name) o.option_name o.option_name o.option_value
 150       else
 151         begin
 152         Printf.bprintf buf "\\<td class=\\\"sr\\\"\\>
 153 \\<a href=\\\"http://mldonkey.sourceforge.net/%s\\\"\\>%s\\</a\\>\\</td\\>
 154 \\<td class=\\\"sr\\\"\\>\\<form action=\\\"submit\\\" target=\\\"$S\\\" onsubmit=\\\"javascript: {setTimeout('window.location.replace(window.location.href)',500);}\\\"\\>
 155 \\<input type=hidden name=setoption value=q\\>\\<input type=hidden name=option value=%s\\>"
 156                   (String2.upp_initial o.option_name) o.option_name o.option_name;
 157
 158           if o.option_value = "true" || o.option_value = "false" then
 159             Printf.bprintf buf "\\<select style=\\\"font-family: verdana; font-size: 10px;\\\"
 160                                 name=\\\"value\\\" onchange=\\\"this.form.submit()\\\"\\>
 161                                 \\<option selected\\>%s\\<option\\>%s\\</select\\>"
 162                                 o.option_value (if o.option_value="true" then "false" else "true")
 163           else
 164             Printf.bprintf buf "\\<input style=\\\"font-family: verdana; font-size: 10px;\\\"
 165                                 type=text name=value onchange=\\\"track_changed(this)\\\" size=20 value=\\\"%s\\\"\\>"
 166                                 o.option_value;
 167         end;
 168         Printf.bprintf buf "\\</td\\>\\</form\\>\\<td class=\\\"sr\\\"\\>%s\\</td\\>" (shorten o.option_default 40);
 169         Printf.bprintf buf "\\<td class=\\\"sr\\\"\\>%s\\</td\\>"
 170           ((if o.option_restart then Printf.sprintf "restart " else "") ^
 171            (if o.option_internal then Printf.sprintf "internal " else "") ^
 172            (if o.option_public then Printf.sprintf "public " else ""));
 173         if not !!html_mods_use_js_helptext then
 174           Printf.bprintf buf "\\<td class=\\\"sr\\\"\\>%s\\</td\\>" (Str.global_replace (Str.regexp "\n") "\\<br\\>" o.option_help);
 175         Printf.bprintf buf "\\</tr\\>"
 176
 177   )list;
 178   Printf.bprintf  buf "\\</table\\>\\</div\\>"
 179
 180
 181 let list_options oo list =
 182   let buf = oo.conn_buf in
 183   if oo.conn_output = HTML then
 184     Printf.bprintf  buf "\\<table border=0\\>";
 185   List.iter (fun o ->
 186       if String.contains o.option_value '\n' then begin
 187           if oo.conn_output = HTML then
 188             Printf.bprintf buf "
 189                   \\<tr\\>\\<td\\>\\<form action=\\\"submit\\\" $S\\>
 190                   \\<input type=hidden name=setoption value=q\\>
 191                   \\<input type=hidden name=option value=%s\\> %s \\</td\\>\\<td\\>
 192                   \\<textarea name=value rows=10 cols=70 wrap=virtual\\>
 193                   %s
 194                   \\</textarea\\>
 195                   \\<input type=submit value=Modify\\>
 196                   \\</td\\>\\</tr\\>
 197                   \\</form\\>
 198                   " o.option_name o.option_name o.option_value
 199         end
 200       else
 201       if oo.conn_output = HTML then
 202         Printf.bprintf buf "
 203               \\<tr\\>\\<td\\>\\<form action=\\\"submit\\\" $S\\>
 204 \\<input type=hidden name=setoption value=q\\>
 205 \\<input type=hidden name=option value=%s\\> %s \\</td\\>\\<td\\>
 206               \\<input type=text name=value onchange=\\\"track_changed(this)\\\" size=40 value=\\\"%s\\\"\\>
 207 \\</td\\>\\</tr\\>
 208 \\</form\\>
 209               " o.option_name o.option_name o.option_value
 210       else
 211         Printf.bprintf buf "$b%s$n = $r%s$n\n" o.option_name o.option_value)
 212   list;
 213   if oo.conn_output = HTML then
 214     Printf.bprintf  buf "\\</table\\>"
 215
 216 let list_calendar o list =
 217   let buf = o.conn_buf in
 218   if o.conn_output = HTML then begin
 219       html_mods_table_header buf "web_infoTable" "vo" [
 220         ( Str, "srh", "Weekdays", "Weekdays" ) ;
 221         ( Str, "srh", "Hours", "Hours" ) ;
 222         ( Str, "srh", "Command", "Command" ) ] ;
 223       html_mods_cntr_init ();
 224       List.iter (fun (wdays, hours, command) ->
 225           Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
 226           let wdays_string = ref "" in
 227           let hours_string = ref "" in
 228           List.iter (fun day ->
 229               if !wdays_string = "" then
 230                 wdays_string := string_of_int day
 231               else
 232                 wdays_string := Printf.sprintf "%s %s" !wdays_string (string_of_int day)) wdays;
 233           List.iter (fun hour ->
 234               if !hours_string = "" then
 235                 hours_string := string_of_int hour
 236               else
 237                 hours_string := Printf.sprintf "%s %s" !hours_string (string_of_int hour)) hours;
 238           Printf.bprintf buf "
 239               \\<td title=\\\"%s\\\" class=\\\"sr\\\"\\>%s\\</td\\>
 240               \\<td class=\\\"sr\\\"\\>%s\\</td\\>" command !wdays_string !hours_string;
 241           Printf.bprintf buf "
 242               \\<td class=\\\"sr\\\"\\>%s\\</td\\>
 243               \\</tr\\>" command
 244       ) list;
 245       Printf.bprintf buf "\\</table\\>\\</div\\>"
 246     end
 247   else begin
 248       Printf.bprintf buf "weekdays / hours / command :\n";
 249       List.iter (fun (wdays, hours, command) ->
 250           let wdays_string = ref "" in
 251           let hours_string = ref "" in
 252           List.iter (fun day ->
 253               if !wdays_string = "" then
 254                 wdays_string := string_of_int day
 255               else
 256                 wdays_string := Printf.sprintf "%s %s" !wdays_string (string_of_int day)) wdays;
 257           List.iter (fun hour ->
 258               if !hours_string = "" then
 259                 hours_string := string_of_int hour
 260               else
 261                 hours_string := Printf.sprintf "%s %s" !hours_string (string_of_int hour)) hours;
 262           Printf.bprintf buf "%s\n%s\n%s\n" !wdays_string !hours_string command
 263       )list
 264     end
 265
 266 (*** Note: don't add _s to all command description as it is already done here *)
 267
 268 let register_commands section list =
 269   register_commands
 270     (List2.tail_map
 271       (fun (cmd, action, desc) -> (cmd, section, action, _s desc)) list)
 272
 273
 274 (*************************************************************************)
 275 (*                                                                       *)
 276 (*                         Driver/General                                *)
 277 (*                                                                       *)
 278 (*************************************************************************)
 279
 280
 281 let _ =
 282   register_commands "Driver/General"
 283     [
 284
 285     "dump_heap", Arg_none (fun o ->
 286 (*        Gc.dump_heap (); *)
 287         "heap dumped"
 288     ), ":\t\t\t\tdump heap for debug";
 289
 290     "alias", Arg_multiple ( fun args o ->
 291         let out = ref "" in
 292         if List.length args = 0 then begin
 293           out := "List of aliases\n\n";
 294           List.iter (
 295             fun (a,b) ->
 296               out := !out ^ a ^ " -> " ^ b ^ "\n"
 297           ) !!alias_commands;
 298         end
 299         else begin
 300           match args with
 301               [] | [_] -> out := "Too few arguments"
 302             | al::def ->
 303                 (try
 304                    let old_def = List.assoc al !!alias_commands in
 305                    out := "removing " ^ al ^ " -> " ^ old_def ^ "\n";
 306                    alias_commands =:= List.remove_assoc al !!alias_commands;
 307                  with _ -> ());
 308
 309                 let definition = String.concat " " def in
 310                 alias_commands =:=  (al,definition) :: !!alias_commands;
 311                 out := !out ^ "Alias added";
 312         end;
 313
 314         !out
 315     ), ":\t\t\t\t\t$badd a command alias\n"
 316        ^"\t\t\t\t\tfor example: \"alias ca cancel all\" makes an alias\n"
 317        ^"\t\t\t\t\t\"ca\" performing \"cancel all\"\n"
 318        ^"\t\t\t\t\tto substitute an alias just make a new one\n"
 319        ^"\t\t\t\t\tfor example: \"alias ca vd\"$n";
 320
 321
 322     "unalias", Arg_one (
 323       fun arg o ->
 324         (try
 325            let old_def = List.assoc arg !!alias_commands in
 326            alias_commands =:= List.remove_assoc arg !!alias_commands;
 327            "removing " ^ arg ^ " -> " ^ old_def
 328          with _ -> "Alias not found");
 329
 330     ), ":\t\t\t\t$bdelete a command alias\n"
 331        ^"\t\t\t\t\texample: \"unalias ca\"$n";
 332
 333     "q", Arg_none (fun o ->
 334         raise CommonTypes.CommandCloseSocket
 335     ), ":\t\t\t\t\t$bclose telnet$n";
 336
 337     "logout", Arg_none (fun o ->
 338         let buf = o.conn_buf in
 339         if o.conn_output = HTML then begin
 340           if has_empty_password o.conn_user.ui_user then
 341             print_command_result o "logout not required, your password is empty!"
 342           else begin
 343             if use_html_mods o then begin
 344               html_mods_table_header buf "helpTable" "results" [];
 345               Buffer.add_string buf "\\<tr class=\\\"dl-1\\\"\\>";
 346               html_mods_td buf [("", "sr", "Are you sure?"); ];
 347               Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-1\\\"\\>";
 348               html_mods_td buf [("", "sr", "\\<div align=\\\"center\\\"\\>\\<a href=\\\"logout\\\" target=\\\"_parent\\\"\\>yes\\</a\\>\\</div\\>"); ];
 349               Buffer.add_string buf "\\</tr\\>\\</table\\>\\</div\\>";
 350             end else
 351               Printf.bprintf buf "Are you sure? \\<a href=\\\"logout\\\" target=\\\"_parent\\\"\\>yes\\</a\\>"
 352           end
 353         end else
 354           raise CommonTypes.CommandCloseSocket;
 355       ""
 356     ), ":\t\t\tlogout interface";
 357
 358     "kill", Arg_none (fun o ->
 359         if user2_is_admin o.conn_user.ui_user then
 360           begin
 361             CommonInteractive.clean_exit 0;
 362             _s "exit"
 363           end
 364         else
 365           _s "You are not allowed to kill MLDonkey"
 366         ), ":\t\t\t\t\t$bsave and kill the server$n";
 367
 368     "urladd", Arg_multiple (fun args o ->
 369        let (kind, url, period) = match args with
 370           | [kind; url; period] -> kind, url, int_of_string period
 371           | [kind; url] -> kind, url, 0
 372           | _  -> failwith "Bad number of arguments"
 373         in
 374         web_infos_add kind period url;
 375         (match web_infos_find url with
 376         | None -> ()
 377         | Some w -> CommonWeb.load_url true w);
 378         "url added to web_infos. downloading now"
 379     ), "<kind> <url> [<period>] :\tload this file from the web\n"
 380        ^"\t\t\t\t\tkind is either server.met (if the downloaded file is a server.met)\n"
 381        ^"\t\t\t\t\tperiod is the period between updates (in hours, default 0 = only loaded at startup)";
 382
 383     "urlremove", Arg_one (fun url o ->
 384         match web_infos_find url with
 385         | None -> "URL does not exists in web_infos"
 386         | Some w -> web_infos_remove w.url;
 387                       "removed URL from web_infos"
 388     ), "<url> :\t\t\tremove URL from web_infos";
 389
 390     "force_web_infos", Arg_multiple (fun args o ->
 391         (match args with
 392         | [] -> CommonWeb.load_web_infos false true;
 393                 "requesting all web_infos files"
 394         | args -> let list = ref [] in
 395                   List.iter (fun arg ->
 396                     Hashtbl.iter (fun key w ->
 397                       if w.kind = arg || w.url = arg then begin
 398                         CommonWeb.load_url false w;
 399                         list := arg :: !list
 400                       end
 401                   ) web_infos_table) args;
 402                   if !list = [] then
 403                     Printf.sprintf "found no web_infos entries for %s" (String.concat " " args)
 404                   else
 405                     Printf.sprintf "requesting web_infos %s" (String.concat " " !list))
 406     ), "[<list of kind|URL>] :\tre-download web_infos, leave empty to re-download all";
 407
 408     "recover_temp", Arg_none (fun o ->
 409         networks_iter (fun r ->
 410             try
 411               CommonNetwork.network_recover_temp r
 412             with _ -> ()
 413         );
 414         let buf = o.conn_buf in
 415         if o.conn_output = HTML then
 416           html_mods_table_one_row buf "serversTable" "servers" [
 417             ("", "srh", "Recover temp finished"); ]
 418         else
 419           Printf.bprintf buf "Recover temp finished";
 420         _s ""
 421     ), ":\t\t\t\trecover lost files from temp directory";
 422
 423     "vc", Arg_multiple (fun args o ->
 424         let buf = o.conn_buf in
 425         if args = ["all"] then begin
 426             if use_html_mods o then html_mods_table_header buf "vcTable" "vc" ([
 427                 ( Num, "srh ac", "Client number", "Num" ) ;
 428                 ( Str, "srh", "Network", "Network" ) ;
 429                 ( Str, "srh", "IP address", "IP address" ) ;
 430                 ] @ (if Geoip.active () then [( Str, "srh", "Country Code/Name", "CC" )] else []) @ [
 431                 ( Str, "srh", "Client name", "Client name" ) ;
 432                 ( Str, "srh", "Client brand", "CB" ) ;
 433                 ( Str, "srh", "Client release", "CR" ) ;
 434                 ] @
 435                 (if !!emule_mods_count then [( Str, "srh", "eMule MOD", "EM" )] else [])
 436                 @ [
 437                 ( Str, "srh", "Client file queue", "Q" ) ;
 438                 ( Num, "srh ar", "Total UL bytes to this client for all files", "tUL" ) ;
 439                 ( Num, "srh ar br", "Total DL bytes from this client for all files", "tDL" ) ;
 440                 ( Num, "srh ar", "Session UL bytes to this client for all files", "sUL" ) ;
 441                 ( Num, "srh ar", "Session DL bytes from this client for all files", "sDL" )]);
 442
 443             html_mods_cntr_init ();
 444             let all_clients_list = clients_get_all () in
 445             List.iter (fun num ->
 446                 let c = client_find num in
 447                 let i = client_info c in
 448                 if use_html_mods o then Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"
 449                   title=\\\"Add as friend\\\"
 450                   onClick=\\\"parent.fstatus.location.href='submit?q=friend_add+%d'\\\"
 451                   onMouseOver=\\\"mOvr(this);\\\"
 452                   onMouseOut=\\\"mOut(this);\\\"\\>"
 453                     (html_mods_cntr ()) num;
 454                     client_print c o;
 455                     if use_html_mods o then
 456                     html_mods_td buf ([
 457                      (client_software i.client_software i.client_os, "sr", client_software_short i.client_software i.client_os);
 458                      ("", "sr", i.client_release);
 459                      ] @
 460                      (if !!emule_mods_count then [("", "sr", i.client_emulemod)] else [])
 461                      @ [
 462                      ("", "sr", Printf.sprintf "%d" (List.length i.client_file_queue));
 463                      ("", "sr ar", (size_of_int64 i.client_total_uploaded));
 464                      ("", "sr ar br", (size_of_int64 i.client_total_downloaded));
 465                      ("", "sr ar", (size_of_int64 i.client_session_uploaded));
 466                      ("", "sr ar", (size_of_int64 i.client_session_downloaded))]);
 467                 if use_html_mods o then Printf.bprintf buf "\\</tr\\>"
 468                 else Printf.bprintf buf "\n";
 469             ) all_clients_list;
 470             if use_html_mods o then Printf.bprintf buf "\\</table\\>\\</div\\>";
 471           end
 472         else
 473           List.iter (fun num ->
 474               let num = int_of_string num in
 475               let c = client_find num in
 476               try client_print_info c o with e -> print_command_result o (Printexc2.to_string e);
 477           ) args;
 478         ""
 479     ), "<num|all> :\t\t\t\tview client (use arg 'all' for all clients)";
 480
 481     "version", Arg_none (fun o ->
 482         print_command_result o (CommonGlobals.version ());
 483         ""
 484     ), ":\t\t\t\tprint mldonkey version";
 485
 486     "uptime", Arg_none (fun o ->
 487         print_command_result o (log_time () ^ "- up " ^
 488           Date.time_to_string (last_time () - start_time) "verbose");
 489         ""
 490     ), ":\t\t\t\tcore uptime";
 491
 492     "sysinfo", Arg_none (fun o ->
 493         let buf = o.conn_buf in
 494         ignore(buildinfo (o.conn_output = HTML) buf);
 495         if o.conn_output = HTML then Printf.bprintf buf "\\<P\\>";
 496         ignore(runinfo (o.conn_output = HTML) buf o);
 497         if o.conn_output = HTML then Printf.bprintf buf "\\<P\\>";
 498         ignore(portinfo (o.conn_output = HTML) buf);
 499         if o.conn_output = HTML then Printf.bprintf buf "\\<P\\>";
 500         ignore(diskinfo (o.conn_output = HTML) buf);
 501         ""
 502     ), ":\t\t\t\tprint mldonkey core build, runtime and disk information";
 503
 504     "buildinfo", Arg_none (fun o ->
 505         let buf = o.conn_buf in
 506         ignore(buildinfo (o.conn_output = HTML) buf);
 507         ""
 508     ), ":\t\t\t\tprint mldonkey core build information";
 509
 510     "runinfo", Arg_none (fun o ->
 511         let buf = o.conn_buf in
 512         ignore(runinfo (o.conn_output = HTML) buf o);
 513         ""
 514     ), ":\t\t\t\tprint mldonkey runtime information";
 515
 516     "portinfo", Arg_none (fun o ->
 517         let buf = o.conn_buf in
 518         ignore(portinfo (o.conn_output = HTML) buf);
 519         ""
 520     ), ":\t\t\t\tprint mldonkey port usage information";
 521
 522     "diskinfo", Arg_none (fun o ->
 523         let buf = o.conn_buf in
 524         ignore(diskinfo (o.conn_output = HTML) buf);
 525         ""
 526     ), ":\t\t\t\tprint mldonkey disk information";
 527
 528     "activity", Arg_one (fun arg o ->
 529         let arg = int_of_string arg in
 530         let buf = o.conn_buf in
 531         let activity_begin = last_time () - arg * 60 in
 532         Fifo.iter (fun a ->
 533             if a.activity_begin > activity_begin then begin
 534                 Printf.bprintf buf "%s: activity =\n" (BasicSocket.string_of_date a.activity_begin);
 535                 Printf.bprintf buf "   servers: edonkey %03d/%03d\n"
 536                   a.activity_server_edonkey_successful_connections
 537                   a.activity_server_edonkey_connections;
 538                 Printf.bprintf buf "   clients: overnet %03d/%03d edonkey %03d/%03d\n"
 539                   a.activity_client_overnet_successful_connections
 540                   a.activity_client_overnet_connections
 541                   a.activity_client_edonkey_successful_connections
 542                   a.activity_client_edonkey_connections;
 543                 Printf.bprintf buf "   indirect: overnet %03d edonkey %03d\n"
 544                   a.activity_client_overnet_indirect_connections
 545                   a.activity_client_edonkey_indirect_connections;
 546               end
 547         ) activities;
 548         ""
 549     ), "<minutes> :\t\t\tprint activity in the last <minutes> minutes";
 550
 551     "clear_message_log", Arg_none (fun o ->
 552         Fifo.clear chat_message_fifo;
 553         Printf.sprintf "Chat messages cleared"
 554      ), ":\t\t\t\tclear chat message buffer";
 555
 556     "message_log", Arg_multiple (fun args o ->
 557         let buf = o.conn_buf in
 558         html_mods_cntr_init ();
 559
 560         (match args with
 561             [arg] ->
 562               let refresh_delay = int_of_string arg in
 563               if use_html_mods o && refresh_delay > 1 then
 564                 Printf.bprintf buf "\\<meta http-equiv=\\\"refresh\\\" content=\\\"%d\\\"\\>"
 565                   refresh_delay;
 566           | _ -> ());
 567
 568 (* rely on GC? *)
 569
 570         while (Fifo.length chat_message_fifo) > !!html_mods_max_messages  do
 571           ignore (Fifo.take chat_message_fifo)
 572         done;
 573
 574         if use_html_mods o then Printf.bprintf buf "\\<div class=\\\"messages\\\"\\>";
 575
 576         last_message_log := last_time();
 577         Printf.bprintf buf "%d logged messages\n" (Fifo.length chat_message_fifo);
 578
 579         if Fifo.length chat_message_fifo > 0 then
 580           begin
 581
 582             if use_html_mods o then
 583               html_mods_table_header buf "serversTable" "servers" [
 584                 ( Str, "srh", "Timestamp", "Time" ) ;
 585                 ( Str, "srh", "IP address", "IP address" ) ;
 586                 ( Num, "srh", "Client number", "Num" ) ;
 587                 ( Str, "srh", "Client name", "Client name" ) ;
 588                 ( Str, "srh", "Message text", "Message" ) ] ;
 589
 590             List.iter (fun (t,i,num,n,s) ->
 591                 if use_html_mods o then begin
 592                     Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>"
 593                       (html_mods_cntr ());
 594                     html_mods_td buf [
 595                       ("", "sr", Date.simple (BasicSocket.date_of_int t));
 596                       ("", "sr",  i);
 597                       ("", "sr", Printf.sprintf "%d" num);
 598                       ("", "sr", n);
 599                       ("", "srw", (if String.length s > 11 && String.sub s 0 11 = "data:image/" then
 600                           "\\<img src=\\\"" ^ String.escaped s ^ "\\\">"
 601                         else String.escaped s)) ];
 602                     Printf.bprintf buf "\\</tr\\>"
 603                   end
 604                 else
 605                   Printf.bprintf buf "\n%s [client #%d] %s(%s): %s\n"
 606                     (Date.simple (BasicSocket.date_of_int t)) num n i s;
 607             ) (List.rev (Fifo.to_list chat_message_fifo));
 608             if use_html_mods o then Printf.bprintf buf
 609                 "\\</table\\>\\</div\\>\\</div\\>";
 610
 611           end;
 612
 613         ""
 614     ), ":\t\t\t\tmessage_log [refresh delay in seconds]";
 615
 616     "message", Arg_multiple (fun args o ->
 617         let buf = o.conn_buf in
 618         match args with
 619           n :: msglist ->
 620             let msg = List.fold_left (fun a1 a2 ->
 621                   a1 ^ a2 ^ " "
 622               ) "" msglist in
 623             let cnum = int_of_string n in
 624             let c = client_find cnum in
 625             let g = client_info c in
 626             client_say c msg;
 627             log_chat_message "FROM ME" cnum ("TO: " ^ g.client_name) msg;
 628             Printf.sprintf "Sending msg to client #%d: %s" cnum msg;
 629         | _ ->
 630             if use_html_mods o then begin
 631
 632                 Printf.bprintf buf "\\<script type=\\\"text/javascript\\\"\\>
 633 \\<!--
 634 function submitMessageForm() {
 635 var formID = document.getElementById(\\\"msgForm\\\")
 636 var regExp = new RegExp (' ', 'gi') ;
 637 var msgTextOut = formID.msgText.value.replace(regExp, '+');
 638 parent.fstatus.location.href='submit?q=message+'+formID.clientNum.value+\\\"+\\\"+msgTextOut;
 639 formID.msgText.value=\\\"\\\";
 640 }
 641 //--\\>
 642 \\</script\\>";
 643
 644                 Printf.bprintf buf "\\<iframe id=\\\"msgWindow\\\" name=\\\"msgWindow\\\" height=\\\"80%%\\\"
 645             width=\\\"100%%\\\" scrolling=yes src=\\\"submit?q=message_log+20\\\"\\>\\</iframe\\>";
 646
 647                 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" name=\\\"msgForm\\\" id=\\\"msgForm\\\" action=\\\"javascript:submitMessageForm();\\\"\\>";
 648                 Printf.bprintf buf "\\<table width=100%% cellspacing=0 cellpadding=0 border=0\\>\\<tr\\>\\<td\\>";
 649                 Printf.bprintf buf "\\<select style=\\\"font-family: verdana;
 650             font-size: 12px; width: 150px;\\\" id=\\\"clientNum\\\" name=\\\"clientNum\\\" \\>";
 651
 652                 Printf.bprintf buf "\\<option value=\\\"1\\\"\\>Client/Friend list\n";
 653
 654                 let found_nums = ref [] in
 655                 let fifo_list = Fifo.to_list chat_message_fifo in
 656                 let fifo_list = List.rev fifo_list in
 657                 let found_select = ref 0 in
 658                 List.iter (fun (t,i,num,n,s) ->
 659                     if not (List.mem num !found_nums) then begin
 660
 661                         found_nums := num :: !found_nums;
 662                         Printf.bprintf buf "\\<option value=\\\"%d\\\" %s\\>%d:%s\n"
 663                           num
 664                           (if !found_select=0 then "selected" else "";)
 665                         num (try
 666                             let c = client_find num in
 667                             let g = client_info c in
 668                             g.client_name
 669                           with _ -> "unknown/expired");
 670                         found_select := 1;
 671                       end
 672                 ) fifo_list;
 673                 List.iter (fun c ->
 674                     let g = client_info c in
 675                     if not (List.mem g.client_num !found_nums) then begin
 676                         found_nums := g.client_num :: !found_nums;
 677                         Printf.bprintf buf "\\<option value=\\\"%d\\\"\\>%d:%s\n"
 678                           g.client_num g.client_num g.client_name;
 679                       end
 680                 ) !!friends;
 681
 682                 Printf.bprintf buf "\\</select\\>\\</td\\>";
 683                 Printf.bprintf buf "\\<td width=100%%\\>\\<input style=\\\"width: 99%%; font-family: verdana; font-size: 12px;\\\"
 684                 type=text id=\\\"msgText\\\" name=\\\"msgText\\\" size=50 \\>\\</td\\>";
 685                 Printf.bprintf buf "\\<td\\>\\<input style=\\\"font-family: verdana;
 686             font-size: 12px;\\\" type=submit value=\\\"Send\\\"\\>\\</td\\>\\</form\\>";
 687                 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"refresh\\\" name=\\\"refresh\\\"
 688             action=\\\"javascript:msgWindow.location.reload();\\\"\\>
 689             \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
 690             Value=\\\"Refresh\\\"\\>\\</td\\>\\</form\\>";
 691                 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"clear\\\" name=\\\"clear\\\"
 692             action=\\\"javascript:window.location.href='submit?q=clear_message_log'\\\"\\>
 693             \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
 694             Value=\\\"Clear\\\"\\>\\</td\\>\\</form\\>\\</tr\\>\\</table\\>";
 695                 ""
 696               end
 697             else
 698               _s "Usage: message <client num> <msg>\n";
 699
 700     ), "<client num> <msg> :\t\tsend a message to a client";
 701
 702     "calendar_add", Arg_two (fun hour action o ->
 703         let buf = o.conn_buf in
 704         calendar =:= ([0;1;2;3;4;5;6], [int_of_string hour], action)
 705         :: !!calendar;
 706         if use_html_mods o then
 707           html_mods_table_one_row buf "serversTable" "servers" [
 708             ("", "srh", "action added"); ]
 709         else
 710           Printf.bprintf buf "action added";
 711         _s ""
 712     ), "<hour> \"<command>\" :\tadd a command to be executed every day";
 713
 714     "vcal", Arg_none (fun o ->
 715         let buf = o.conn_buf in
 716         if use_html_mods o then begin
 717             Printf.bprintf buf "\\<div class=\\\"vo\\\"\\>
 718                 \\<table class=main cellspacing=0 cellpadding=0\\>\\<tr\\>\\<td\\>";
 719             if !!calendar = [] then
 720               html_mods_table_one_row buf "serversTable" "servers" [
 721                 ("", "srh", "no jobs defined"); ]
 722             else
 723               list_calendar o !!calendar;
 724             Printf.bprintf buf "\\</td\\>\\</tr\\>\\</table\\>\\</div\\>\\<P\\>";
 725             print_option_help o calendar
 726           end
 727         else
 728           if List.length !!calendar = 0 then
 729             Printf.bprintf buf "no jobs defined"
 730           else
 731             list_calendar o !!calendar;
 732         ""
 733     ), ":\t\t\t\t\tprint calendar";
 734
 735     ]
 736
 737 (*************************************************************************)
 738 (*                                                                       *)
 739 (*                         Driver/Servers                                *)
 740 (*                                                                       *)
 741 (*************************************************************************)
 742
 743 let _ =
 744   register_commands "Driver/Servers"
 745     [
 746
 747     "vm", Arg_none (fun o ->
 748         let buf = o.conn_buf in
 749         if use_html_mods o then Printf.bprintf buf
 750             "\\<div class=\\\"servers\\\"\\>\\<table align=center border=0 cellspacing=0 cellpadding=0\\>\\<tr\\>\\<td\\>";
 751         CommonInteractive.print_connected_servers o;
 752         if use_html_mods o then Printf.bprintf buf "\\</td\\>\\</tr\\>\\</table\\>\\</div\\>";
 753         ""), ":\t\t\t\t\t$blist connected servers$n";
 754
 755     "vma", Arg_none (fun o ->
 756         let buf = o.conn_buf in
 757         html_mods_cntr_init ();
 758         let nb_servers = ref 0 in
 759         if use_html_mods o then server_print_html_header buf "";
 760         Intmap.iter (fun _ s ->
 761             try
 762               server_print s o;
 763               incr nb_servers;
 764             with e ->
 765                 lprintf "Exception %s in server_print\n"
 766                   (Printexc2.to_string e);
 767         ) !!servers;
 768         if use_html_mods o then begin
 769             Printf.bprintf buf "\\</table\\>\\</div\\>";
 770             html_mods_table_one_row buf "serversTable" "servers" [
 771               ("", "srh", Printf.sprintf "Servers: %d known" !nb_servers); ]
 772           end
 773         else
 774           Printf.bprintf buf "Servers: %d known\n" !nb_servers;
 775         if Autoconf.donkey = "yes" && not !!enable_servers then
 776           begin
 777             if use_html_mods o then begin
 778                 Printf.bprintf buf "\\<div class=servers\\>";
 779                 html_mods_table_one_row buf "upstatsTable" "upstats" [
 780                   ("", "srh", ("You disabled server usage, therefore you are not" ^
 781                     " able to connect ED2K servers. " ^
 782                     "To use servers again 'set enable_servers true'")); ]
 783               end
 784             else
 785               Buffer.add_string buf ("You disabled server usage, therefore you are not" ^
 786                 " able to connect ED2K servers.\n" ^
 787                 "To use servers again 'set enable_servers true'\n");
 788             if use_html_mods o then Printf.bprintf buf "\\</div\\>"
 789           end;
 790     ""), ":\t\t\t\t\tlist all known servers";
 791
 792     "rem", Arg_multiple (fun args o ->
 793         let counter = ref 0 in
 794         match args with
 795           ["all"] ->
 796             Intmap.iter ( fun _ s ->
 797               server_remove s;
 798               incr counter
 799             ) !!servers;
 800             Printf.sprintf (_b "Removed all %d servers") !counter
 801         | ["blocked"] ->
 802             Intmap.iter ( fun _ s ->
 803               if server_blocked s then
 804                 begin
 805                   server_remove s;
 806                   incr counter
 807                 end
 808             ) !!servers;
 809             Printf.sprintf (_b "Removed %d blocked servers") !counter
 810         | ["disc"] ->
 811             Intmap.iter (fun _ s ->
 812               match server_state s with
 813                 NotConnected _ ->
 814                   begin
 815                     server_remove s;
 816                     incr counter
 817                   end
 818               | _ -> ()) !!servers;
 819             Printf.sprintf (_b "Removed %d disconnected servers") !counter
 820         | _ ->
 821             List.iter (fun num ->
 822                 let num = int_of_string num in
 823                 let s = server_find num in
 824                 server_remove s
 825             ) args;
 826             Printf.sprintf (_b"%d servers removed") (List.length args)
 827     ), "<server numbers|all|blocked|disc> :\tremove server(s) ('all'/'blocked'/'disc' = all/IP blocked/disconnected servers)";
 828
 829     "server_banner", Arg_one (fun num o ->
 830         let num = int_of_string num in
 831         let s = server_find num in
 832         (match server_state s with
 833             NotConnected _ -> ()
 834           | _ ->   server_banner s o);
 835         ""
 836     ), "<num> :\t\t\tprint banner of connected server <num>";
 837
 838     "server_shares", Arg_one (fun num o ->
 839         if user2_is_admin o.conn_user.ui_user then
 840         let s = server_find (int_of_string num) in
 841         (match server_state s with
 842            Connected _ -> let list = ref [] in
 843             List.iter (fun f ->
 844               match file_shared f with
 845                 None -> ()
 846               | Some sh -> list := (as_shared_impl sh) :: !list)
 847               (server_published s);
 848             print_upstats o !list (Some s)
 849           | _ -> ()
 850         )
 851         else print_command_result o "You are not allowed to use this command";
 852         _s ""
 853     ), "<num> :\t\t\tshow list of files published on server <num>";
 854
 855     "c", Arg_multiple (fun args o ->
 856         let buf = o.conn_buf in
 857         match args with
 858           [] ->
 859             networks_iter network_connect_servers;
 860             if o.conn_output = HTML then
 861               html_mods_table_one_row buf "serversTable" "servers" [
 862                 ("", "srh", "Connecting more servers"); ]
 863             else
 864               Printf.bprintf buf "connecting more servers";
 865             _s
 866         ""
 867         | _ ->
 868             List.iter (fun num ->
 869                 let num = int_of_string num in
 870                 let s = server_find num in
 871                 server_connect s
 872             ) args;
 873             if o.conn_output = HTML then
 874               html_mods_table_one_row buf "serversTable" "servers" [
 875                 ("", "srh", "Connecting more servers"); ]
 876             else
 877               Printf.bprintf buf "connecting server";
 878             _s
 879         ""
 880     ), "[<num>] :\t\t\t\tconnect to more servers (or to server <num>)";
 881
 882     "x", Arg_multiple (fun args o ->
 883         let counter = ref 0 in
 884         let is_connected state =
 885           match state with
 886           | Connecting
 887           | Connected _
 888           | Connected_initiating -> true
 889           | _ -> false
 890         in
 891         let print_result v =
 892             print_command_result o
 893              (Printf.sprintf (_b "Disconnected %d server%s") !counter (Printf2.print_plural_s !counter))
 894         in
 895         match args with
 896         | ["all"] ->
 897             Intmap.iter ( fun _ s ->
 898               if is_connected (server_state s) then begin
 899                 server_disconnect s;
 900                 incr counter
 901               end
 902             ) !!servers;
 903             print_result !counter;
 904         ""
 905         | _ ->
 906             List.iter (fun num ->
 907                 let num = int_of_string num in
 908                 let s = server_find num in
 909                 if is_connected (server_state s) then begin
 910                   server_disconnect s;
 911                   incr counter
 912                 end
 913             ) args;
 914             print_result !counter;
 915         ""
 916     ), "<server numbers|all> :\t\tdisconnect from server(s)";
 917
 918   ]
 919
 920 (*************************************************************************)
 921 (*                                                                       *)
 922 (*                         Driver/Friends                                *)
 923 (*                                                                       *)
 924 (*************************************************************************)
 925
 926 let _ =
 927   register_commands "Driver/Friends"
 928     [
 929
 930     "vfr", Arg_none (fun o ->
 931         List.iter (fun c ->
 932             client_print c o) !!friends;
 933         ""
 934     ), ":\t\t\t\t\tview friends";
 935
 936     "gfr", Arg_one (fun num o ->
 937         let num = int_of_string num in
 938         let c = client_find num in
 939         client_browse c true;
 940         _s "client browse"
 941     ), "<client num> :\t\t\task friend files";
 942
 943     "friend_add", Arg_one (fun num o ->
 944         let num = int_of_string num in
 945         let c = client_find num in
 946         friend_add c;
 947         _s "Added friend"
 948     ), "<client num> :\t\tadd client <client num> to friends";
 949
 950     "friend_remove", Arg_multiple (fun args o ->
 951         if args = ["all"] then begin
 952             List.iter (fun c ->
 953                 friend_remove c
 954             ) !!friends;
 955             _s "Removed all friends"
 956           end else begin
 957             List.iter (fun num ->
 958                 let num = int_of_string num in
 959                 let c = client_find num in
 960                 friend_remove c;
 961             ) args;
 962             Printf.sprintf (_b "%d friends removed") (List.length args)
 963           end
 964     ), "<client numbers|all> :\tremove friend (use arg 'all' for all friends)";
 965
 966     "friends", Arg_none (fun o ->
 967         let buf = o.conn_buf in
 968
 969         if use_html_mods o then begin
 970             Printf.bprintf buf "\\<div class=\\\"friends\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
 971 \\<tr\\>\\<td\\>
 972 \\<table cellspacing=0 cellpadding=0  width=100%%\\>\\<tr\\>
 973 \\<td class=downloaded width=100%%\\>\\</td\\>
 974 \\<td nowrap class=fbig\\>\\<a onclick=\\\"javascript:window.location.reload()\\\"\\>Refresh\\</a\\> \\</td\\>
 975 \\<td nowrap class=fbig\\>\\<a onclick=\\\"javascript:
 976                   { parent.fstatus.location.href='submit?q=friend_remove+all';
 977                     setTimeout('window.location.reload()',1000);
 978                     }\\\"\\>Remove All\\</a\\>
 979 \\</td\\>
 980 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript: {
 981                    var getip = prompt('Friend IP [port] ie: 192.168.0.1 4662','192.168.0.1 4662')
 982                    var reg = new RegExp (' ', 'gi') ;
 983                    var outstr = getip.replace(reg, '+');
 984                    parent.fstatus.location.href='submit?q=afr+' + outstr;
 985                     setTimeout('window.location.reload()',1000);
 986                     }\\\"\\>Add by IP\\</a\\>
 987 \\</td\\>
 988 \\</tr\\>\\</table\\>
 989 \\</td\\>\\</tr\\>
 990 \\<tr\\>\\<td\\>";
 991             html_mods_table_header buf "friendsTable" "friends" [
 992               ( Num, "srh", "Client number", "Num" ) ;
 993               ( Str, "srh", "Remove", "Remove" ) ;
 994               ( Str, "srh", "Network", "Network" ) ;
 995               ( Str, "srh", "Name", "Name" ) ;
 996               ( Str, "srh", "State", "State" ) ] ;
 997           end;
 998         html_mods_cntr_init ();
 999         List.iter (fun c ->
1000             let i = client_info c in
1001             let n = network_find_by_num i.client_network in
1002             if use_html_mods o then
1003               begin
1004
1005                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"
1006                 onMouseOver=\\\"mOvr(this);\\\"
1007                 onMouseOut=\\\"mOut(this);\\\"\\>"
1008                   (html_mods_cntr ());
1009
1010                 Printf.bprintf buf "
1011                         \\<td title=\\\"Client number\\\"
1012                         onClick=\\\"location.href='submit?q=files+%d'\\\"
1013                         class=\\\"srb\\\"\\>%d\\</td\\>
1014                         \\<td title=\\\"Remove friend\\\"
1015                         onClick=\\\"parent.fstatus.location.href='submit?q=friend_remove+%d'\\\"
1016                         class=\\\"srb\\\"\\>Remove\\</td\\>
1017                         \\<td title=\\\"Network\\\" class=\\\"sr\\\"\\>%s\\</td\\>
1018                         \\<td title=\\\"Name (click to view files)\\\"
1019                         onClick=\\\"location.href='submit?q=files+%d'\\\"
1020                         class=\\\"sr\\\"\\>%s\\</td\\>
1021                         \\<td title=\\\"Click to view files\\\"
1022             onClick=\\\"location.href='submit?q=files+%d'\\\"
1023             class=\\\"sr\\\"\\>%s\\</td\\>
1024                         \\</tr\\>"
1025                   i.client_num
1026                   i.client_num
1027                   i.client_num
1028                   n.network_name
1029                   i.client_num
1030                   i.client_name
1031                   i.client_num
1032
1033                   (let rs = try client_files c with _ -> [] in
1034                   if (List.length rs) > 0 then Printf.sprintf "%d Files Listed" (List.length rs)
1035                   else string_of_connection_state (client_state c) )
1036
1037               end
1038
1039             else
1040               Printf.bprintf buf "[%s %d] %s" n.network_name
1041                 i.client_num i.client_name
1042         ) !!friends;
1043
1044         if use_html_mods o then
1045           Printf.bprintf buf " \\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>";
1046
1047         ""
1048     ), ":\t\t\t\tdisplay all friends";
1049
1050     "files", Arg_one (fun arg o ->
1051         let buf = o.conn_buf in
1052         let n = int_of_string arg in
1053         List.iter (fun c ->
1054             if client_num c = n then begin
1055                 let rs = client_files c in
1056
1057                 let rs = List2.tail_map (fun (s, rs) ->
1058                       let r = IndexedResults.get_result rs in
1059                       rs, r, 1
1060                   ) rs in
1061                 o.conn_user.ui_last_results <- [];
1062                 DriverInteractive.print_results 0 buf o rs;
1063
1064                 ()
1065               end
1066         ) !!friends;
1067         ""), "<client num> :\t\t\tprint files from friend <client num>";
1068
1069
1070   ]
1071
1072 (*************************************************************************)
1073 (*                                                                       *)
1074 (*                         Driver/Network                                *)
1075 (*                                                                       *)
1076 (*************************************************************************)
1077
1078 let _ =
1079   register_commands "Driver/Network"
1080     [
1081
1082     "nu", Arg_one (fun num o ->
1083         if user2_is_admin o.conn_user.ui_user then begin
1084         let num = int_of_string num in
1085
1086         if num > 0 then (* we want to disable upload for a short time *)
1087           let num = min !CommonGlobals.upload_credit num in
1088           CommonGlobals.has_upload := !CommonGlobals.has_upload + num;
1089           CommonGlobals.upload_credit := !CommonGlobals.upload_credit - num;
1090         else
1091
1092         if num < 0 && !CommonGlobals.has_upload > 0 then begin
1093 (* we want to restart upload probably *)
1094           let num = - num in
1095           let num = min num !CommonGlobals.has_upload in
1096           CommonGlobals.has_upload := !CommonGlobals.has_upload - num;
1097           CommonGlobals.upload_credit := !CommonGlobals.upload_credit + num;
1098         end;
1099         if !CommonGlobals.has_upload > 0 then clear_upload_slots ();
1100         print_command_result o
1101         (Printf.sprintf "upload disabled for %d minutes (remaining credits %d)"
1102           !CommonGlobals.has_upload !CommonGlobals.upload_credit)
1103         end else
1104           print_command_result o "You are not allowed to disable upload"; ""
1105     ), "<m> :\t\t\t\tdisable upload during <m> minutes, queue all files";
1106
1107     "vu", Arg_none (fun o ->
1108         Printf.sprintf
1109           "Upload credits : %d minutes\nUpload disabled for %d minutes"
1110           !CommonGlobals.upload_credit !CommonGlobals.has_upload;
1111
1112     ), ":\t\t\t\t\tview upload credits";
1113
1114     "bw_stats", Arg_multiple (fun args o ->
1115         let buf = o.conn_buf in
1116         if use_html_mods o then
1117           begin
1118             display_bw_stats := true;
1119             let refresh_delay = ref !!html_mods_bw_refresh_delay in
1120             if args <> [] then begin
1121                 let newrd = int_of_string (List.hd args) in
1122                 if newrd > 1 then refresh_delay := newrd;
1123               end;
1124
1125             let dlkbs =
1126               (( (float_of_int !udp_download_rate) +. (float_of_int !control_download_rate)) /. 1024.0) in
1127             let ulkbs =
1128               (( (float_of_int !udp_upload_rate) +. (float_of_int !control_upload_rate)) /. 1024.0) in
1129
1130             Printf.bprintf buf "\\</head\\>\\<body\\>\\<div class=\\\"bw_stats\\\"\\>";
1131             Printf.bprintf buf "\\<table class=\\\"bw_stats\\\" cellspacing=0 cellpadding=0\\>\\<tr\\>";
1132             Printf.bprintf buf "\\<td\\>\\<table border=0 cellspacing=0 cellpadding=0\\>\\<tr\\>";
1133
1134             html_mods_td buf [
1135               ("Download KB/s (UDP|TCP), total", "bu bbig bbig1 bb4", Printf.sprintf "Down: %.1f KB/s (%d|%d), %s"
1136                   dlkbs !udp_download_rate !control_download_rate (size_of_int64 !download_counter));
1137               ("Upload KB/s (UDP|TCP), total", "bu bbig bbig1 bb4", Printf.sprintf "Up: %.1f KB/s (%d|%d), %s"
1138                   ulkbs !udp_upload_rate !control_upload_rate (size_of_int64 !upload_counter));
1139               ("Total shared files/bytes", "bu bbig bbig1 bb4", Printf.sprintf "Shared(%d): %s"
1140                 !nshared_files (size_of_int64 !nshared_bytes));
1141               ("Bandwidth (Up|Down), open connections (max_opened_connections)", "bu bbig bbig1 bb3",
1142                 Printf.sprintf "DL %d KB/s, UL %d KB/s, Conn: %d (%d)"
1143                 !!max_hard_download_rate !!max_hard_upload_rate (nb_sockets ()) !!max_opened_connections) ];
1144
1145             Printf.bprintf buf "\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\</table\\>\\</div\\>";
1146
1147             Printf.bprintf buf "\\<script type=\\\"text/javascript\\\"\\>window.parent.document.title='(D:%.1f) (U:%.1f) | %s | %s'\\</script\\>"
1148               dlkbs ulkbs o.conn_user.ui_user.user_name (CommonGlobals.version ())
1149           end
1150         else
1151           DriverInteractive.print_bw_stats buf;
1152         ""
1153     ), ":\t\t\t\tprint current bandwidth stats";
1154
1155     "bw_toggle", Arg_multiple (fun args o ->
1156         let change_bw () =
1157                 let ul_bkp = !!max_hard_upload_rate_2 in
1158                 let dl_bkp = !!max_hard_download_rate_2 in
1159                 let max_conn = !!max_opened_connections_2 in
1160                 max_hard_upload_rate_2 =:= !!max_hard_upload_rate;
1161                 max_hard_download_rate_2 =:= !!max_hard_download_rate;
1162                 max_opened_connections_2 =:= !!max_opened_connections;
1163                 max_hard_upload_rate =:= ul_bkp;
1164                 max_hard_download_rate =:=  dl_bkp;
1165                 max_opened_connections =:= max_conn;
1166         in
1167         if user2_is_admin o.conn_user.ui_user then begin
1168         (
1169                 match (List.map String.lowercase args) with
1170                 | ["high"] ->
1171                         if !!max_opened_connections < !!max_opened_connections_2 then
1172                                 change_bw ()
1173                 | ["low"] ->
1174                         if !!max_opened_connections > !!max_opened_connections_2 then
1175                                 change_bw ()
1176                 | _ -> change_bw ()
1177                 );
1178                 print_command_result o (Printf.sprintf
1179                   "new upload rate: %d | new download rate: %d | new max opened connections: %d"
1180                     !!max_hard_upload_rate !!max_hard_download_rate !!max_opened_connections)
1181                 end
1182         else
1183           print_command_result o "You are not allowed to toggle bandwidth";
1184         ""
1185     ), "[<high|low>]:\t\t\ttoggle between the two rate and opened connection sets, high/low depend on option max_open_connections*";
1186
1187     "costats", Arg_multiple (fun args o ->
1188         let filter cs =
1189           match (List.map String.lowercase args) with
1190           | [] -> cs.country_total_upload <> 0L || cs.country_total_download <> 0L
1191           | ["all"] -> true
1192           | args ->
1193               let match_star = Str.regexp "\\*" in
1194               let regexp = Str.regexp ("^\\("
1195                 ^ (List.fold_left (fun acc a -> acc
1196                 ^ (if acc <> "" then "\\|" else "")
1197                 ^ (Str.global_replace match_star ".*" a)) "" args)
1198                 ^ "\\)$") in
1199               let check_string s =
1200                 Str.string_match regexp (String.lowercase s) 0 in
1201               check_string cs.country_code ||
1202               check_string cs.country_name ||
1203               check_string cs.country_continent
1204         in
1205         let buf = o.conn_buf in
1206         if use_html_mods o then
1207           begin
1208             let u1 = BasicSocket.last_time () - !CommonStats.start_time in
1209             let u2 = (CommonStats.guptime () + u1) in
1210             let t1 = Printf.sprintf "Session uptime: %s" (Date.time_to_string u1 "verbose") in
1211             let t2 = Printf.sprintf "Total uptime: %s" (Date.time_to_string u2 "verbose") in
1212             html_mods_big_header_start buf "shares" [t1;t2];
1213
1214             html_mods_table_header buf ~total:"1" "sharesTable" "shares" [
1215                ( Str, "srh", "Country name", "Country" ) ;
1216                ( Str, "srh", "Country code", "Code" ) ;
1217                ( Str, "srh", "Continent", "Con" ) ;
1218                ( Num, "srh ar", "Session uploaded", "sUl" ) ;
1219                ( Num, "srh ar", "Session downloaded", "sDl" ) ;
1220                ( Num, "srh ar", "Session seen", "sSe" ) ;
1221                ( Num, "srh ar", "Total uploaded", "tUl" ) ;
1222                ( Num, "srh ar", "Total downloaded", "tDl" ) ;
1223                ( Num, "srh ar", "Total seen", "tSe" ) ;
1224             ];
1225             html_mods_cntr_init ();
1226             let csu = ref 0L in
1227             let csd = ref 0L in
1228             let css = ref 0L in
1229             let ctu = ref 0L in
1230             let ctd = ref 0L in
1231             let cts = ref 0L in
1232             List.iter (fun cs ->
1233               if filter cs then begin
1234                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
1235                 html_mods_td buf [
1236                     ("", "sr", cs.country_name);
1237                     (cs.country_code, "sr", CommonPictures.flag_html cs.country_code);
1238                     ("", "sr", cs.country_continent);
1239                     ("", "sr ar", size_of_int64 cs.country_session_upload);
1240                     ("", "sr ar", size_of_int64 cs.country_session_download);
1241                     ("", "sr ar", Printf.sprintf "%Ld" cs.country_session_seen);
1242                     ("", "sr ar", size_of_int64 cs.country_total_upload);
1243                     ("", "sr ar", size_of_int64 cs.country_total_download);
1244                     ("", "sr ar", Printf.sprintf "%Ld" cs.country_total_seen);
1245                     ];
1246                 Printf.bprintf buf "\\</tr\\>\n";
1247                 csu := !csu ++ cs.country_session_upload;
1248                 csd := !csd ++ cs.country_session_download;
1249                 css := !css ++ cs.country_session_seen;
1250                 ctu := !ctu ++ cs.country_total_upload;
1251                 ctd := !ctd ++ cs.country_total_download;
1252                 cts := !cts ++ cs.country_total_seen;
1253               end
1254               ) (List.sort (fun c1 c2 -> compare c1.country_code c2.country_code) !!CommonStats.country_stats);
1255               Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
1256
1257               html_mods_td buf [ (* Display totals *)
1258                 ("", "sr total", "Total");
1259                 ("", "sr total", "");
1260                 ("", "sr total", "");
1261                 ("", "sr ar total", size_of_int64 !csu);
1262                 ("", "sr ar total", size_of_int64 !csd);
1263                 ("", "sr ar total", Printf.sprintf "%Ld" !css);
1264                 ("", "sr ar total", size_of_int64 !ctu);
1265                 ("", "sr ar total", size_of_int64 !ctd);
1266                 ("", "sr ar total", Printf.sprintf "%Ld" !cts);
1267                 ];
1268               Printf.bprintf buf "\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\</table\\>\n"
1269           end
1270         else
1271           begin
1272             let list = ref [] in
1273             List.iter (fun cs ->
1274               if filter cs then list := [|
1275                 cs.country_name;
1276                 cs.country_code;
1277                 cs.country_continent;
1278                 size_of_int64 cs.country_session_upload;
1279                 size_of_int64 cs.country_session_download;
1280                 Printf.sprintf "%Ld" cs.country_session_seen;
1281                 size_of_int64 cs.country_total_upload;
1282                 size_of_int64 cs.country_total_download;
1283                 Printf.sprintf "%Ld" cs.country_total_seen;
1284               |] :: !list
1285             ) (List.sort (fun c1 c2 -> compare c1.country_code c2.country_code) !!CommonStats.country_stats);
1286             print_table_text buf
1287             [|
1288               Align_Left; Align_Left; Align_Left; Align_Right; Align_Right; Align_Right; Align_Right; Align_Right; Align_Right |]
1289             [|
1290               "Country";
1291               "Code";
1292               "Con";
1293               "sUL";
1294               "sDL";
1295               "sSeen";
1296               "tUL";
1297               "tDL";
1298               "tSeen";
1299             |] (List.rev !list)
1300           end;
1301       _s ""), "[<all|regex>]:\t\t\tdisplay country based transfer statistics for countries with data transfered,\n\t\t\t\t\tuse arg 'all' for all countries seen\n\t\t\t\t\tor * as wildcard for country name, code and continent";
1302
1303     "countries", Arg_none (fun o ->
1304         let buf = o.conn_buf in
1305         if use_html_mods o then
1306           begin
1307             html_mods_table_header buf "sharesTable" "shares" [
1308                ( Num, "srh ar", "Number", "Num" ) ;
1309                ( Str, "srh", "Country code", "Code" ) ;
1310                ( Str, "srh", "Country name", "Country" ) ;
1311                ( Str, "srh", "Continent code", "Con" ) ;
1312                ( Str, "srh", "Continent name", "Continent" ) ;
1313             ];
1314             html_mods_cntr_init ();
1315             Array.iteri (fun i _ ->
1316               Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
1317               html_mods_td buf [
1318                 ("", "sr ar", Printf.sprintf "%d" i);
1319                 (Geoip.country_code_array.(i), "sr", CommonPictures.flag_html (String.lowercase Geoip.country_code_array.(i)));
1320                 ("", "sr", Geoip.country_name_array.(i));
1321                 ("", "sr", Geoip.country_continent_code_array.(i));
1322                 ("", "sr", Geoip.country_continent_name_array.(i));
1323               ];
1324               Printf.bprintf buf "\\</tr\\>\n"
1325             ) Geoip.country_code_array;
1326             Printf.bprintf buf "\\</table\\>\n";
1327           end
1328         else
1329           begin
1330             let list = ref [] in
1331             Array.iteri (fun i _ ->
1332               list := [|
1333                 Printf.sprintf "%d" i;
1334                 Geoip.country_code_array.(i);
1335                 Geoip.country_name_array.(i);
1336                 Geoip.country_continent_code_array.(i);
1337                 Geoip.country_continent_name_array.(i);
1338               |] :: !list
1339             ) Geoip.country_code_array;
1340             print_table_text buf
1341             [|
1342               Align_Right; Align_Left; Align_Left; Align_Left; Align_Left |]
1343             [|
1344               "Num";
1345               "Country";
1346               "Code";
1347               "Con";
1348               "Continent";
1349             |] (List.rev !list)
1350           end;
1351       _s ""), ":\t\t\t\tdisplay country database";
1352
1353     "reset_costats", Arg_none (fun o ->
1354         CommonStats.country_reset ();
1355         print_command_result o (_s "country statistics resetted");
1356       _s ""), ":\t\t\t\treset country based transfer statistics and save statistics.ini";
1357
1358     "stats", Arg_none (fun o ->
1359         CommonInteractive.network_display_stats o;
1360         if use_html_mods o then
1361           print_gdstats o;
1362       _s ""), ":\t\t\t\t\tdisplay transfer statistics";
1363
1364     "gdstats", Arg_none (fun o ->
1365         if Autoconf.has_gd then
1366           if use_html_mods o then
1367             print_gdstats o
1368           else
1369             print_command_result o (_s "Only available on HTML interface")
1370         else
1371           print_command_result o (_s "Gd support was not compiled");
1372       _s ""), ":\t\t\t\tdisplay graphical transfer statistics";
1373
1374     "gdremove", Arg_none (fun o ->
1375         if Autoconf.has_gd then
1376           begin
1377             DriverGraphics.G.really_remove_files ();
1378             print_command_result o (_s "Gd files were removed")
1379           end
1380         else
1381           print_command_result o (_s "Gd support was not compiled");
1382       _s ""), ":\t\t\t\tremove graphical transfer statistics files";
1383
1384     "!", Arg_multiple (fun arg o ->
1385         if !!allow_any_command then
1386           match arg with
1387             c :: args ->
1388               let cmd = try List.assoc c !!allowed_commands with Not_found -> c in
1389               (try
1390                  let pipe_out, pipe_in = Unix.pipe () in
1391                  let pid = Unix.create_process cmd
1392                    (Array.of_list (Filename2.basename c :: args))
1393                    Unix.stdin pipe_in pipe_in in
1394                  Unix.close pipe_in;
1395                  (* can't close pipe_out in the already forked+executed process... *)
1396                  let output = Buffer.create 1024 in
1397                  let buffersize = 1024 in
1398                  let buffer = String.create buffersize in
1399                  (try
1400                     while true do
1401                       let nread = Unix.read pipe_out buffer 0 buffersize in
1402                       if nread = 0 then raise End_of_file;
1403                       Buffer.add_substring output buffer 0 nread
1404                     done
1405                   with
1406                   | End_of_file -> ()
1407                   | Unix.Unix_error (code, f, arg) ->
1408                       lprintf_nl "%s failed%s: %s" f (if arg = "" then "" else " on " ^ arg) (Unix.error_message code));
1409                  (try Unix.close pipe_out with _ -> ());
1410                  let _pid, status = Unix.waitpid [] pid in
1411                  Printf.sprintf (_b "%s\n---------------- %s")
1412                    (Buffer.contents output)
1413                    (match status with
1414                     | Unix.WEXITED exitcode ->
1415                         Printf.sprintf "Exited with code %d" exitcode
1416                     | Unix.WSIGNALED signal ->
1417                         Printf.sprintf "Was killed by signal %d" signal
1418                     | Unix.WSTOPPED signal -> (* does it matter for us ? *)
1419                         Printf.sprintf "Was stopped by signal %d" signal)
1420
1421                with Unix.Unix_error (code, f, arg) ->
1422                  Printf.sprintf "%s failed%s: %s" f (if arg = "" then "" else " on " ^ arg) (Unix.error_message code))
1423           | [] -> _s "no command given"
1424         else
1425         match arg with
1426           [arg] ->
1427             (try
1428             let cmd = List.assoc arg !!allowed_commands in
1429             let tmp = Filename2.temp_file "com" ".out" in
1430             let ret = Sys.command (Printf.sprintf "%s > %s"
1431                   cmd tmp) in
1432             let output = File.to_string tmp in
1433             Sys.remove tmp;
1434             Printf.sprintf (_b "%s\n---------------- Exited with code %d") output ret
1435             with e -> "For arbitrary commands, you must set 'allowed_any_command'")
1436         | [] ->
1437             _s "no command given"
1438         | _ -> "For arbitrary commands, you must set 'allowed_any_command'"
1439     ), "<cmd> :\t\t\t\tstart command <cmd>\n\t\t\t\t\tmust be allowed in 'allowed_commands' option or by 'allow_any_command' if arguments";
1440
1441
1442   ]
1443
1444 (*************************************************************************)
1445 (*                                                                       *)
1446 (*                         Driver/Networks                               *)
1447 (*                                                                       *)
1448 (*************************************************************************)
1449
1450 let _ =
1451   register_commands "Driver/Networks"
1452     [
1453
1454     "networks", Arg_none (fun o ->
1455         let buf = o.conn_buf in
1456         print_network_modules buf o;
1457         ""
1458     ) , ":\t\t\t\tprint all networks";
1459
1460     "enable", Arg_one (fun num o ->
1461         if user2_is_admin o.conn_user.ui_user then
1462           begin
1463             let n = network_find_by_num (int_of_string num) in
1464             network_enable n;
1465             print_command_result o "network enabled"
1466           end
1467         else
1468           print_command_result o "You are not allowed to enable networks";
1469         _s ""
1470     ) , "<num> :\t\t\t\tenable a particular network";
1471
1472     "disable", Arg_one (fun num o ->
1473         if user2_is_admin o.conn_user.ui_user then
1474           begin
1475             let n = network_find_by_num (int_of_string num) in
1476             network_disable n;
1477             print_command_result o "network disabled"
1478           end
1479         else
1480           print_command_result o "You are not allowed to disable networks";
1481         _s ""
1482     ) , "<num> :\t\t\t\tdisable a particular network";
1483
1484     "discover_ip", Arg_none (fun o ->
1485       CommonGlobals.discover_ip true;
1486       print_command_result o "discover ip started";
1487            ""
1488     ) , ":\t\t\t\tstart IP discovery";
1489
1490     "force_porttest", Arg_none (fun o ->
1491     networks_iter (fun n ->
1492       match network_porttest_result n with
1493         | PorttestNotAvailable -> ()
1494         | _ -> network_porttest_start n;
1495     );
1496     if use_html_mods o then
1497       print_command_result o "porttest started, use command
1498         \\<u\\>\\<a onclick=\\\"javascript:window.location.href='submit?q=porttest'\\\"\\>porttest\\</a\\>\\</u\\> to see results"
1499     else
1500       print_command_result o "porttest started, use command 'porttest' to see results";
1501            ""
1502     ) , ":\t\t\tforce start network porttest";
1503
1504     "porttest", Arg_none (fun o ->
1505         let buf = o.conn_buf in
1506         let age time = Date.time_to_string (BasicSocket.last_time () - time) "verbose" in
1507         let list = ref [] in
1508         let put_list e = list := e :: !list in
1509         networks_iter (fun n ->
1510         match network_porttest_result n with
1511          | PorttestNotAvailable ->
1512              put_list (n.network_name , "Porttest not available")
1513          | PorttestNotStarted ->
1514              put_list (n.network_name , "Porttest started");
1515              network_porttest_start n
1516          | PorttestInProgress time ->
1517              put_list (n.network_name , Printf.sprintf "Porttest in progress, started %s ago" (age time))
1518          | PorttestResult (time, s) ->
1519              put_list (n.network_name , Printf.sprintf "Porttest finished %s ago \n%s" (age time) s)
1520     );
1521     if use_html_mods o then begin
1522       Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
1523                           \\<tr\\>\\<td\\>\\<table cellspacing=0 cellpadding=0  width=100%%\\>
1524                           \\<tr\\>\\<td class=downloaded width=100%%\\>\\</td\\>
1525                             \\<td nowrap class=\\\"fbig\\\"\\>
1526                             \\<a onclick=\\\"javascript:window.location.href='submit?q=force_porttest'\\\"\\>Restart porttest\\</a\\>\\</td\\>
1527                             \\<td nowrap class=\\\"fbig pr\\\"\\>
1528                             \\<a onclick=\\\"javascript:window.location.reload()\\\"\\>Refresh results\\</a\\>\\</td\\>
1529                           \\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\<tr\\>\\<td\\>";
1530       html_mods_table_header buf "sharesTable" "shares" [
1531         ( Str, "srh", "Network", "Network" ) ;
1532         ( Str, "srh", "Result", "Result" ) ]
1533     end;
1534     html_mods_cntr_init ();
1535     List.iter (fun (net, result) ->
1536       if use_html_mods o then
1537         Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>\\<td class=\\\"sr\\\"\\>%s\\</td\\>\\<td class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>"
1538           (html_mods_cntr ()) net (Str.global_replace (Str.regexp "\n") "\\<br\\>" result)
1539       else
1540         Printf.bprintf buf "----- %s: -----\n%s\n\n" net result;
1541     ) !list;
1542     if use_html_mods o then
1543       Printf.bprintf buf "\\</table\\>\\</div\\>\\</td\\>\\</tr\\>\\</table\\>"
1544     else
1545       Printf.bprintf buf "\n\nuse command 'porttest' again to refresh the results \nuse command 'force_porttest' to force a new porttest";
1546         ""
1547     ) , ":\t\t\t\tprint network porttest results";
1548
1549     ]
1550
1551 (*************************************************************************)
1552 (*                                                                       *)
1553 (*                         Driver/Searches                               *)
1554 (*                                                                       *)
1555 (*************************************************************************)
1556
1557 let _ =
1558   register_commands "Driver/Searches"
1559     [
1560
1561     "forget", Arg_multiple (fun args o ->
1562         let user = o.conn_user in
1563         begin
1564           match args with
1565             ["all"] ->
1566               List.iter (fun s ->
1567                   CommonSearch.search_forget user (CommonSearch.search_find s.search_num);
1568               ) user.ui_user_searches
1569           | [] ->
1570               begin
1571                 match user.ui_user_searches with
1572                   [] -> ()
1573                 | s :: _ ->
1574                     CommonSearch.search_forget user
1575                       (CommonSearch.search_find s.search_num);
1576               end
1577
1578           | _ ->
1579               List.iter (fun arg ->
1580                   let num = int_of_string arg in
1581                   CommonSearch.search_forget user (CommonSearch.search_find num)
1582               ) args;
1583         end;
1584         ""
1585     ), "<num1> <num2> ... :\t\tforget searches <num1> <num2> ...";
1586
1587     "vr", Arg_multiple (fun args o ->
1588         let buf = o.conn_buf in
1589         let user = o.conn_user in
1590         match args with
1591           num :: _ ->
1592             List.iter (fun num ->
1593                 let num = int_of_string num in
1594                 let s = search_find num in
1595                 DriverInteractive.print_search buf s o) args;
1596             ""
1597         | [] ->
1598             begin
1599               match user.ui_user_searches with
1600                 [] ->
1601                   if o.conn_output = HTML then
1602                     html_mods_table_one_row buf "searchTable" "search" [
1603                       ("", "srh", "No search to print"); ]
1604                   else
1605                     Printf.bprintf buf "No search to print";
1606             ""
1607               | s :: _ ->
1608                   DriverInteractive.print_search buf s o;
1609                   ""
1610             end;
1611     ), "[<num>] :\t\t\t\t$bview results of a search$n";
1612
1613     "s", Arg_multiple (fun args o ->
1614         let buf = o.conn_buf in
1615         let user = o.conn_user in
1616         let query, net = CommonSearch.search_of_args args in
1617         ignore (CommonInteractive.start_search user
1618             (let module G = GuiTypes in
1619             { G.search_num = 0;
1620               G.search_query = query;
1621               G.search_max_hits = 10000;
1622               G.search_type = RemoteSearch;
1623               G.search_network = net;
1624             }) buf);
1625         ""
1626     ), "<query> :\t\t\t\t$bsearch for files on all networks$n\n\n\tWith special args:\n\t-network <netname>\n\t-minsize <size>\n\t-maxsize <size>\n\t-media <Video|Audio|...>\n\t-Video\n\t-Audio\n\t-format <format>\n\t-title <word in title>\n\t-album <word in album>\n\t-artist <word in artist>\n\t-field <field> <fieldvalue>\n\t-not <word>\n\t-and <word>\n\t-or <word>\n";
1627
1628     "ls", Arg_multiple (fun args o ->
1629         let buf = o.conn_buf in
1630         let user = o.conn_user in
1631         let query, net = CommonSearch.search_of_args args in
1632         ignore (CommonInteractive.start_search user
1633             (let module G = GuiTypes in
1634             { G.search_num = 0;
1635               G.search_query = query;
1636               G.search_max_hits = 10000;
1637               G.search_type = LocalSearch;
1638               G.search_network = net;
1639             }) buf);
1640         ""
1641     ), "<query> :\t\t\t\tsearch for files locally\n\n\tWith special args:\n\t-network <netname>\n\t-minsize <size>\n\t-maxsize <size>\n\t-media <Video|Audio|...>\n\t-Video\n\t-Audio\n\t-format <format>\n\t-title <word in title>\n\t-album <word in album>\n\t-artist <word in artist>\n\t-field <field> <fieldvalue>\n\t-not <word>\n\t-and <word>\n\t-or <word>\n";
1642
1643     "vs", Arg_none (fun o ->
1644         let buf = o.conn_buf in
1645         let user = o.conn_user in
1646         let num_searches = List.length user.ui_user_searches in
1647         if num_searches < 1 then
1648           if o.conn_output = HTML then
1649             html_mods_table_one_row buf "searchTable" "search" [
1650               ("", "srh", "No search yet"); ]
1651           else
1652             Printf.bprintf buf "No search yet"
1653         else begin
1654             if o.conn_output = HTML then
1655               Printf.bprintf  buf "Searching %d queries\n" (
1656                 List.length user.ui_user_searches);
1657             List.iter (fun s ->
1658                 Printf.bprintf buf "%s[%-5d]%s %s %s (found %d)\n"
1659                   (if o.conn_output = HTML then
1660                     Printf.sprintf "\\<a href=\\\"submit\\?q=forget\\+%d\\\" target=fstatus\\>[Forget]\\</a\\> \\<a href=\\\"submit\\?q=vr\\+%d\\\"\\>" s.search_num s.search_num
1661                   else "")
1662                 s.search_num
1663                   s.search_string
1664                   (if o.conn_output = HTML then "\\</a\\>" else "")
1665                 (if s.search_waiting = 0 then _s "done" else
1666                     string_of_int s.search_waiting)
1667                 s.search_nresults
1668             ) (List.sort (fun f1 f2 -> compare f1.search_num f2.search_num)
1669             user.ui_user_searches)
1670           end;
1671         ""
1672     ), ":\t\t\t\t\tview all queries";
1673
1674     "view_custom_queries", Arg_none (fun o ->
1675         let buf = o.conn_buf in
1676         if o.conn_output <> HTML then
1677           Printf.bprintf buf "%d custom queries defined\n"
1678             (List.length (customized_queries ()));
1679         let custom_commands = ref [] in
1680         List.iter (fun (name, q) ->
1681             if o.conn_output = HTML then
1682               begin
1683                 if use_html_mods o then
1684                   custom_commands := !custom_commands @ [ ( "bu bbig",
1685                   name,
1686                   Printf.sprintf "mSub('output','custom=%s')" (Url.encode name),
1687                   name ) ; ]
1688                 else
1689                   Printf.bprintf buf
1690                     "\\<a href=\\\"submit\\?custom=%s\\\" $O\\> %s \\</a\\>\n"
1691                     (Url.encode name) name;
1692               end
1693             else
1694
1695               Printf.bprintf buf "[%s]\n" name
1696         ) (customized_queries ());
1697
1698         if use_html_mods o then
1699           html_mods_commands buf "commandsTable" "commands" (!custom_commands @ [
1700             ("bu bbig", "Visit FileHeaven",
1701              "parent.frames[_getFrameByName('output')].location.href='http://www.fileheaven.org/'", "FileHeaven");
1702             ("bu bbig", "Visit FileDonkey",
1703              "parent.frames[_getFrameByName('output')].location.href='http://www.filedonkey.com/'", "FileDonkey");
1704             ("bu bbig", "Visit Bitzi",
1705              "parent.frames[_getFrameByName('output')].location.href='http://www.fileheaven.org/'", "Bitzi");
1706             ("bu bbig", "Visit eMugle",
1707              "parent.frames[_getFrameByName('output')].location.href='http://www.emugle.com/'", "eMugle");
1708           ]);
1709         ""
1710     ), ":\t\t\tview custom queries";
1711
1712     "d", Arg_multiple (fun args o ->
1713         List.iter (fun arg ->
1714             CommonInteractive.download_file o arg) args;
1715         ""
1716     ), "<num> :\t\t\t\t$bfile to download$n";
1717
1718     "force_download", Arg_none (fun o ->
1719         if !forceable_download = [] then
1720           begin
1721             let output = (if o.conn_output = HTML then begin
1722                 let buf = Buffer.create 100 in
1723                 Printf.bprintf buf "\\<div class=\\\"cs\\\"\\>";
1724                 html_mods_table_header buf "dllinkTable" "results" [];
1725                 Printf.bprintf buf "\\<tr\\>";
1726                 html_mods_td buf [ ("", "srh", "No download to force"); ];
1727                 Printf.bprintf buf "\\</tr\\>\\</table\\>\\</div\\>\\</div\\>";
1728                 Buffer.contents buf
1729               end
1730             else begin
1731                 Printf.sprintf "No download to force"
1732             end) in
1733             _s output
1734           end
1735         else
1736           begin
1737             let r = List.hd !forceable_download in
1738               CommonNetwork.networks_iter (fun n ->
1739                 ignore (network_download n r o.conn_user.ui_user o.conn_user.ui_user.user_default_group));
1740
1741             let output = (if o.conn_output = HTML then begin
1742                 let buf = Buffer.create 100 in
1743                 Printf.bprintf buf "\\<div class=\\\"cs\\\"\\>";
1744                 html_mods_table_header buf "dllinkTable" "results" [];
1745                 Printf.bprintf buf "\\<tr\\>";
1746                 html_mods_td buf [ ("", "srh", "Forced start of "); ];
1747                 Printf.bprintf buf "\\</tr\\>\\<tr class=\\\"dl-1\\\"\\>";
1748                 html_mods_td buf [ ("", "sr", (List.hd r.result_names)); ];
1749                 Printf.bprintf buf "\\</tr\\>\\</table\\>\\</div\\>\\</div\\>";
1750                 Buffer.contents buf
1751               end
1752             else begin
1753                 Printf.sprintf "Forced start of : %s" (List.hd r.result_names)
1754             end) in
1755             _s output
1756           end;
1757     ), ":\t\t\tforce download of an already downloaded file";
1758
1759     ]
1760
1761 (*************************************************************************)
1762 (*                                                                       *)
1763 (*                         Driver/Options                                *)
1764 (*                                                                       *)
1765 (*************************************************************************)
1766
1767 let _ =
1768   register_commands "Driver/Options"
1769     [
1770
1771     "set", Arg_two (fun name value o ->
1772         if user2_is_admin o.conn_user.ui_user then begin
1773         try
1774           try
1775             let gui_type, ip, port =
1776               match o.conn_info with
1777               | None -> None, None, None
1778               | Some (gui_type, (ip, port)) -> Some gui_type, Some ip, Some port
1779             in
1780             CommonInteractive.set_fully_qualified_options name value
1781               ~user:(Some o.conn_user.ui_user.user_name)
1782               ~ip:ip ~port:port ~gui_type:gui_type ();
1783             Printf.sprintf "option %s value changed" name
1784           with _ ->
1785               Options.set_simple_option downloads_ini name value;
1786               Printf.sprintf "option %s value changed" name
1787         with
1788         | Not_found -> Printf.sprintf "Option %s does not exist" name
1789         | e -> Printf.sprintf "Error %s" (Printexc2.to_string e)
1790           end
1791         else
1792           _s "You are not allowed to change options"
1793     ), "<option_name> <option_value> :\t$bchange option value$n";
1794
1795     "save", Arg_multiple (fun args o ->
1796         if !allow_saving_ini_files then begin
1797         match args with
1798           ["options"] -> DriverInteractive.save_config (); _s "options saved"
1799         | ["sources"] -> CommonComplexOptions.save_sources (); _s "sources saved"
1800         | ["backup"] -> CommonComplexOptions.backup_options (); _s "backup saved"
1801         | ["all"] ->
1802                DriverInteractive.save_config ();
1803                CommonComplexOptions.save_sources ();
1804                CommonComplexOptions.backup_options ();
1805                 _s "options, sources and backup saved"
1806         | _ -> DriverInteractive.save_config ();
1807                CommonComplexOptions.save_sources (); _s "options and sources saved"
1808         end else _s "base directory full, ini file saving disabled until core shutdown"
1809         ), "[<options|sources|backup>] :\tsave options and/or sources or backup (empty for options and sources)";
1810
1811     "vo", Arg_none (fun o ->
1812         let buf = o.conn_buf in
1813         if use_html_mods o then begin
1814
1815           if !!html_mods_use_js_helptext then
1816             Printf.bprintf buf "\\<div id=\\\"object1\\\" style=\\\"position:absolute; background-color:#FFFFDD;color:black;border-color:black;border-width:20px;font-size:8pt; visibility:visible; left:25px; top:-100px; z-index:+1\\\" onmouseover=\\\"overdiv=1;\\\"  onmouseout=\\\"overdiv=0; setTimeout(\\\'hideLayer()\\\',1000)\\\"\\>\\&nbsp;\\</div\\>";
1817
1818           Printf.bprintf buf "\\<div class=\\\"friends\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
1819 \\<tr\\>\\<td\\>
1820 \\<table cellspacing=0 cellpadding=0  width=100%%\\>\\<tr\\>
1821 \\<td class=downloaded width=100%%\\>\\</td\\>
1822 \\<td nowrap title=\\\"Show shares Tab (also related for incoming directory)\\\" class=\\\"fbig fbigpad\\\"\\>\\<a onclick=\\\"javascript:window.location.href='submit?q=shares'\\\"\\>Shares\\</a\\>\\</td\\>
1823 %s
1824 \\<td nowrap title=\\\"Show Web_infos Tab where you can add/remove automatic downloads like serverlists\\\" class=\\\"fbig fbigpad\\\"\\>\\<a onclick=\\\"javascript:window.location.href='submit?q=vwi'\\\"\\>Web infos\\</a\\>\\</td\\>
1825 \\<td nowrap title=\\\"Show Calendar Tab, there are information about automatically jobs\\\" class=\\\"fbig fbigpad\\\"\\>\\<a onclick=\\\"javascript:window.location.href='submit?q=vcal'\\\"\\>Calendar\\</a\\>\\</td\\>
1826 \\<td nowrap title=\\\"Change to simple Webinterface without html_mods\\\" class=\\\"fbig fbigpad\\\"\\>\\<a onclick=\\\"javascript:window.location.href='submit?q=html_mods'\\\"\\>Toggle html_mods\\</a\\>\\</td\\>
1827 \\<td nowrap title=\\\"voo\\\" class=\\\"fbig pr fbigpad\\\"\\>\\<a onclick=\\\"javascript:window.location.href='submit?q=voo+1'\\\"\\>Full Options\\</a\\>\\</td\\>
1828 \\</tr\\>\\</table\\>
1829 \\</td\\>\\</tr\\>
1830 \\<tr\\>\\<td\\>"
1831 (if (user2_is_admin o.conn_user.ui_user) then
1832   "\\<td nowrap title=\\\"Show users Tab where you can add/remove Users\\\" class=\\\"fbig fbigpad\\\"\\>\\<a onclick=\\\"javascript:window.location.href='submit?q=users'\\\"\\>Users\\</a\\>\\</td\\>"
1833  else "");
1834
1835             list_options_html o  (
1836               [
1837 (* replaced strings_of_option_html by strings_of_option *)
1838                 strings_of_option max_hard_upload_rate;
1839                 strings_of_option max_hard_download_rate;
1840                 strings_of_option telnet_port;
1841                 strings_of_option gui_port;
1842                 strings_of_option http_port;
1843                 strings_of_option global_login;
1844                 strings_of_option allowed_ips;
1845                 strings_of_option set_client_ip;
1846                 strings_of_option force_client_ip;
1847                 strings_of_option discover_ip;
1848               ] );
1849
1850             Printf.bprintf buf "\\</td\\>\\</tr\\>\\<tr\\>\\<td\\>\\<table cellspacing=0 cellpadding=0  width=100%%\\>\\<tr\\>\\<td class=downloaded width=100%%\\>\\</td\\>
1851 \\<td nowrap title=\\\"Toggle option helptext from javascript popup to html table\\\" class=\\\"fbig fbigb pr fbigpad\\\"\\>
1852 \\<a onclick=\\\"javascript: {parent.fstatus.location.href='submit?q=set+html_mods_use_js_helptext+%s'; setTimeout('window.location.replace(window.location.href)',1000);return true;}\\\"\\>toggle js_helptext\\</a\\>
1853 \\</td\\>\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\</table\\>\\</div\\>\\</br\\>" (if !!html_mods_use_js_helptext then "false" else "true");
1854
1855             html_mods_table_one_row buf "downloaderTable" "downloaders" [
1856             ("", "srh", "!! press ENTER to send changes to core !!"); ]
1857
1858           end
1859
1860         else
1861           list_options o  (
1862             [
1863               strings_of_option max_hard_upload_rate;
1864               strings_of_option max_hard_download_rate;
1865               strings_of_option telnet_port;
1866               strings_of_option gui_port;
1867               strings_of_option http_port;
1868               strings_of_option global_login;
1869               strings_of_option allowed_ips;
1870               strings_of_option set_client_ip;
1871               strings_of_option force_client_ip;
1872               strings_of_option discover_ip;
1873             ]
1874           );
1875
1876         "\nUse '$rvoo$n' for all options"
1877     ), ":\t\t\t\t\t$bdisplay options$n";
1878
1879
1880
1881
1882     "voo", Arg_multiple (fun args o ->
1883         let buf = o.conn_buf in
1884         let put fmt = Printf.bprintf buf fmt in
1885         let changed_list = List.sort (fun d1 d2 -> compare d1 d2) (List.filter (fun o ->
1886             o.option_value <> o.option_default && not (String2.starts_with o.option_name "enable_")
1887             ) (CommonInteractive.all_simple_options ())) in
1888         if use_html_mods o then begin
1889
1890             put "\\<script type=\\\"text/javascript\\\"\\>
1891 \\<!--
1892 function pluginSubmit() {
1893 var formID = document.getElementById(\\\"pluginForm\\\");
1894 var v = formID.plugin.value;
1895 location.href='submit?q=voo+'+v;
1896 }
1897 function submitHtmlModsStyle() {
1898 var formID = document.getElementById(\\\"htmlModsStyleForm\\\");
1899 var v = formID.modsStyle.value;
1900 if (\\\"0123456789.\\\".indexOf(v) == -1)
1901 { parent.fstatus.location.href='submit?q=html_theme+\\\"'+v+'\\\"';} else
1902 { parent.fstatus.location.href='submit?q=html_mods_style+'+v;}
1903 }
1904 //--\\>
1905 \\</script\\>";
1906
1907             let button ~title ~cls ~cmd content = put "\\<td nowrap title=\\\"%s\\\" class=\\\"%s\\\"\\>\\<a onclick=\\\"javascript:window.location.href='submit?q=%s';setTimeout('window.location.replace(window.location.href)',500)\\\"\\>%s\\</a\\>\\</td\\>" title cls cmd content
1908             in
1909
1910             let select name options =
1911               put "\\<select id=\\\"%s\\\" name=\\\"%s\\\"
1912 style=\\\"padding: 0px; font-size: 10px; font-family: verdana\\\" onchange=\\\"this.form.submit()\\\"\\>" name name;
1913               List.iter (fun (n,v) ->
1914                 put "\\<option value=\\\"%s\\\"\\>%s\\</option\\>\n" n v;
1915               ) options;
1916               put "\\</select\\>"
1917             in
1918
1919             let tabnumber = ref 0 in
1920             let mtabs = ref 1 in
1921
1922             if !!html_mods_use_js_helptext then
1923              put "\\<div id=\\\"object1\\\" style=\\\"position:absolute; background-color:#FFFFDD;color:black;border-color:black;border-width:20px;font-size:8pt; visibility:visible; left:25px; top:-100px; z-index:+1\\\" onmouseover=\\\"overdiv=1;\\\"  onmouseout=\\\"overdiv=0; setTimeout(\\\'hideLayer()\\\',1000)\\\"\\>\\&nbsp;\\</div\\>";
1924
1925             put "\\<div class=\\\"vo\\\"\\>";
1926             put "\\<table class=main cellspacing=0 cellpadding=0\\>";
1927             put "\\<tr\\>\\<td\\>";
1928             put "\\<table cellspacing=0 cellpadding=0 class='hcenter'\\>\\<tr\\>";
1929
1930             List.iter (fun (s,title) ->
1931                 incr tabnumber; incr mtabs;
1932                 button ~title ~cls:"fbig" ~cmd:(Printf.sprintf "voo+%d" !tabnumber) s
1933             ) [ ("Client", "Client related options & Up/Download limitations ") ;
1934                 ("Ports", "Interface ports, each Network port is stored in Network plugin options") ;
1935                 ("html", "Show Webinterface related options") ;
1936                 ("Delays", "Delays & timeouts") ;
1937                 ("Files", "File related options") ;
1938                 ("Mail", "eMail information options") ;
1939                 ("Net", "activate/deaktivate Networks, some TCP/IP & IP blocking options") ;
1940                 ("Misc", "miscellaneous") ;
1941                 ("changed", "Show changed options") ];
1942
1943             button ~title:"Show all options" ~cls:"fbig" ~cmd:"voo" "All";
1944             put "\\<td nowrap class=\\\"fbig pr\\\"\\>
1945 \\<form style=\\\"margin: 0px;\\\" name=\\\"pluginForm\\\" id=\\\"pluginForm\\\"
1946 action=\\\"javascript:pluginSubmit();\\\"\\>";
1947
1948             let options =
1949               let netlist = List.map
1950                 (fun s -> incr tabnumber; s,!tabnumber)
1951                 (CommonInteractive.all_active_network_opfile_network_names ())
1952               in
1953               let duplist = ref [] in
1954               List.map (fun (s,t) ->
1955                 let name = if List.memq s !duplist then s^"+" else s in
1956                 duplist := name :: !duplist;
1957                 string_of_int t, name
1958               ) (List.sort (fun (s1,_) (s2,_) -> compare s1 s2) netlist);
1959             in
1960
1961             select "plugin" (("0","Plugins") :: options);
1962
1963             put "\\</form\\>\\</td\\>\\</tr\\>\\</table\\>";
1964             put "\\</td\\>\\</tr\\>";
1965             put "\\<tr\\>\\<td\\>";
1966
1967             list_options_html o (
1968               match args with
1969               |  [] | _ :: _ :: _ ->
1970                   CommonInteractive.all_simple_options ()
1971
1972               | ["changed"] ->
1973                   changed_list
1974
1975               | [arg] ->
1976                   try
1977                   let tab = int_of_string arg in
1978                   match tab with
1979                     1 ->
1980                       [
1981                         strings_of_option global_login;
1982                         strings_of_option set_client_ip;
1983                         strings_of_option force_client_ip;
1984                         strings_of_option discover_ip;
1985                         strings_of_option max_upload_slots;
1986                         strings_of_option max_release_slots;
1987                         strings_of_option dynamic_slots;
1988                         strings_of_option max_hard_upload_rate;
1989                         strings_of_option max_hard_download_rate;
1990                         strings_of_option max_opened_connections;
1991                         strings_of_option max_hard_upload_rate_2;
1992                         strings_of_option max_hard_download_rate_2;
1993                         strings_of_option max_opened_connections_2;
1994                         strings_of_option max_indirect_connections;
1995                         strings_of_option max_connections_per_second;
1996                         strings_of_option max_concurrent_downloads;
1997                       ]
1998
1999                   | 2 ->
2000                       [
2001                         strings_of_option gui_bind_addr;
2002                         strings_of_option telnet_bind_addr;
2003                         strings_of_option http_bind_addr;
2004                         strings_of_option client_bind_addr;
2005                         strings_of_option gui_port;
2006                         strings_of_option telnet_port;
2007                         strings_of_option http_port;
2008                         strings_of_option http_realm;
2009                         strings_of_option allowed_ips;
2010                       ]
2011                   | 3 ->
2012                       [
2013                         strings_of_option html_mods_use_relative_availability;
2014                         strings_of_option html_mods_human_readable;
2015                         strings_of_option html_mods_vd_network;
2016                         strings_of_option html_mods_vd_active_sources;
2017                         strings_of_option html_mods_vd_age;
2018                         strings_of_option html_mods_vd_user;
2019                         strings_of_option html_mods_vd_group;
2020                         strings_of_option html_mods_vd_last;
2021                         strings_of_option html_mods_vd_prio;
2022                         strings_of_option html_mods_show_pending;
2023                         strings_of_option html_mods_load_message_file;
2024                         strings_of_option html_mods_max_messages;
2025                         strings_of_option html_mods_bw_refresh_delay;
2026                         strings_of_option html_frame_border;
2027                         strings_of_option html_checkbox_vd_file_list;
2028                         strings_of_option html_checkbox_search_file_list;
2029                         strings_of_option commands_frame_height;
2030                         strings_of_option html_vd_barheight;
2031                         strings_of_option html_vd_chunk_graph;
2032                         strings_of_option html_vd_chunk_graph_style;
2033                         strings_of_option html_vd_chunk_graph_max_width;
2034                         strings_of_option display_downloaded_results;
2035                         strings_of_option vd_reload_delay;
2036                         strings_of_option html_use_gzip;
2037                         strings_of_option html_flags;
2038                         strings_of_option html_mods_use_js_tooltips;
2039                         strings_of_option html_mods_js_tooltips_wait;
2040                         strings_of_option html_mods_js_tooltips_timeout;
2041                         strings_of_option html_mods_use_js_helptext;
2042                         ] @ (if Autoconf.has_gd then
2043                         [strings_of_option html_mods_vd_gfx;] else []) @
2044                         (if Autoconf.has_gd_jpg && Autoconf.has_gd_png
2045                          then [strings_of_option html_mods_vd_gfx_png;] else []) @
2046                         (if Autoconf.has_gd then [
2047                         strings_of_option html_mods_vd_gfx_remove;
2048                         strings_of_option html_mods_vd_gfx_split;
2049                         strings_of_option html_mods_vd_gfx_stack;
2050                         strings_of_option html_mods_vd_gfx_fill;
2051                         strings_of_option html_mods_vd_gfx_flip;
2052                         strings_of_option html_mods_vd_gfx_mean;
2053                         strings_of_option html_mods_vd_gfx_transparent;
2054                         strings_of_option html_mods_vd_gfx_h;
2055                         strings_of_option html_mods_vd_gfx_h_intervall;
2056                         strings_of_option html_mods_vd_gfx_h_dynamic;
2057                         strings_of_option html_mods_vd_gfx_h_grid_time;
2058                         strings_of_option html_mods_vd_gfx_subgrid;
2059                         strings_of_option html_mods_vd_gfx_x_size;
2060                         strings_of_option html_mods_vd_gfx_y_size;
2061                         strings_of_option html_mods_vd_gfx_tag;
2062                         strings_of_option html_mods_vd_gfx_tag_use_source;
2063                         strings_of_option html_mods_vd_gfx_tag_source;
2064                         strings_of_option html_mods_vd_gfx_tag_png;
2065                         strings_of_option html_mods_vd_gfx_tag_enable_title;
2066                         strings_of_option html_mods_vd_gfx_tag_title;
2067                         strings_of_option html_mods_vd_gfx_tag_title_x_pos;
2068                         strings_of_option html_mods_vd_gfx_tag_title_y_pos;
2069                         strings_of_option html_mods_vd_gfx_tag_dl_x_pos;
2070                         strings_of_option html_mods_vd_gfx_tag_dl_y_pos;
2071                         strings_of_option html_mods_vd_gfx_tag_ul_x_pos;
2072                         strings_of_option html_mods_vd_gfx_tag_ul_y_pos;
2073                         strings_of_option html_mods_vd_gfx_tag_x_size;
2074                         strings_of_option html_mods_vd_gfx_tag_y_size;
2075                         ] else [])
2076                   | 4 ->
2077                       [
2078                         strings_of_option save_options_delay;
2079                         strings_of_option update_gui_delay;
2080                         strings_of_option server_connection_timeout;
2081                         strings_of_option compaction_delay;
2082                         strings_of_option min_reask_delay;
2083                         strings_of_option buffer_writes;
2084                         strings_of_option buffer_writes_delay;
2085                         strings_of_option buffer_writes_threshold;
2086                       ]
2087                   | 5 ->
2088                       [
2089                         strings_of_option previewer;
2090                         strings_of_option temp_directory;
2091                         strings_of_option filenames_utf8;
2092                         strings_of_option share_scan_interval;
2093                         strings_of_option hdd_temp_minfree;
2094                         strings_of_option hdd_temp_stop_core;
2095                         strings_of_option hdd_coredir_minfree;
2096                         strings_of_option hdd_coredir_stop_core;
2097                         strings_of_option hdd_send_warning_interval;
2098                         strings_of_option file_started_cmd;
2099                         strings_of_option file_completed_cmd;
2100                         strings_of_option allow_browse_share;
2101                         strings_of_option auto_commit;
2102                         strings_of_option pause_new_downloads;
2103                         strings_of_option release_new_downloads;
2104                         strings_of_option create_file_mode;
2105                         strings_of_option create_dir_mode;
2106                         strings_of_option create_file_sparse;
2107                         strings_of_option log_file;
2108                         strings_of_option log_file_size;
2109                         strings_of_option log_size;
2110                       ]
2111                   | 6 ->
2112                       [
2113                         strings_of_option mail;
2114                         strings_of_option smtp_port;
2115                         strings_of_option smtp_server;
2116                         strings_of_option smtp_login;
2117                         strings_of_option smtp_password;
2118                         strings_of_option add_mail_brackets;
2119                         strings_of_option filename_in_subject;
2120                         strings_of_option url_in_mail;
2121                       ]
2122                   | 7 ->
2123                       ( (if Autoconf.donkey = "yes" then [(strings_of_option enable_overnet)] else [])
2124                         @ [
2125                         ] @
2126                         (if Autoconf.donkey = "yes" then [(strings_of_option enable_kademlia)] else [])
2127                         @ [
2128                         ] @
2129                         (if Autoconf.donkey = "yes" then [(strings_of_option enable_donkey)] else [])
2130                         @ [
2131                         ] @
2132                         (if Autoconf.bittorrent = "yes" then [(strings_of_option enable_bittorrent)] else [])
2133                         @ [
2134                         ] @
2135                         (if Autoconf.fasttrack = "yes" then [(strings_of_option enable_fasttrack)] else [])
2136                         @ [
2137                         ] @
2138                         (if Autoconf.opennapster = "yes" then [(strings_of_option enable_opennap)] else [])
2139                         @ [
2140                         ] @
2141                         (if Autoconf.soulseek = "yes" then [(strings_of_option enable_soulseek)] else [])
2142                         @ [
2143                         ] @
2144                         (if Autoconf.gnutella = "yes" then [(strings_of_option enable_gnutella)] else [])
2145                         @ [
2146                         ] @
2147                         (if Autoconf.gnutella2 = "yes" then [(strings_of_option enable_gnutella2)] else [])
2148                         @ [
2149                         ] @
2150                         (if Autoconf.direct_connect = "yes" then [(strings_of_option enable_directconnect)] else [])
2151                         @ [
2152                         ] @
2153                         (if Autoconf.openft = "yes" then [(strings_of_option enable_openft)] else [])
2154                         @ [
2155                         ] @
2156                         (if Autoconf.filetp = "yes" then [(strings_of_option enable_fileTP)] else [])
2157                         @ [
2158                         ] @
2159                         (if Autoconf.upnp_natpmp then [(strings_of_option upnp_port_forwarding)] else [])
2160                         @ [
2161                         ] @
2162                         (if Autoconf.upnp_natpmp then [(strings_of_option clear_upnp_port_at_exit)] else [])
2163                         @ [
2164                         strings_of_option tcpip_packet_size;
2165                         strings_of_option mtu_packet_size;
2166                         strings_of_option minimal_packet_size;
2167                         strings_of_option ip_blocking;
2168                         strings_of_option ip_blocking_descriptions;
2169                         strings_of_option ip_blocking_countries;
2170                         strings_of_option ip_blocking_countries_block;
2171                       ])
2172                   | 8 ->
2173                       [
2174                         strings_of_option term_ansi;
2175                         strings_of_option run_as_user;
2176                         strings_of_option run_as_useruid;
2177                         strings_of_option messages_filter;
2178                         strings_of_option comments_filter;
2179                         strings_of_option max_displayed_results;
2180                         strings_of_option max_name_len;
2181                         strings_of_option max_result_name_len;
2182                         strings_of_option max_filenames;
2183                         strings_of_option max_client_name_len;
2184                         strings_of_option emule_mods_count;
2185                         strings_of_option emule_mods_showall;
2186                         strings_of_option backup_options_format;
2187                         strings_of_option backup_options_delay;
2188                         strings_of_option backup_options_generations;
2189                         strings_of_option small_files_slot_limit;
2190                       ]
2191                   | 9 ->
2192                       changed_list
2193
2194                   | _ ->
2195                       let v = CommonInteractive.some_simple_options (tab - !mtabs) in
2196                       List.sort (fun d1 d2 -> compare d1 d2) v;
2197               with _ ->
2198                     let v = CommonInteractive.parse_simple_options args in
2199                     List.sort (fun d1 d2 -> compare d1 d2) v;
2200
2201
2202             );
2203             put "\\</td\\>\\</tr\\>";
2204             put "\\<tr\\>\\<td\\>";
2205
2206             put "\\<table cellspacing=0 cellpadding=0 class='hcenter'\\>\\<tr\\>";
2207
2208             button ~title:"Show shares Tab (also related for incoming directory)" ~cls:"fbig fbigb" ~cmd:"shares" "Shares";
2209             if (user2_is_admin o.conn_user.ui_user) then
2210               button ~title:"Show users Tab where you can add/remove Users" ~cls:"fbig fbigb" ~cmd:"users" "Users";
2211
2212             button ~title:"Show Web_infos Tab where you can add/remove automatic downloads like serverlists" ~cls:"fbig fbigb" ~cmd:"vwi" "Web infos";
2213             button ~title:"Show Calendar Tab, there are information about automatically jobs" ~cls:"fbig fbigb" ~cmd:"vcal" "Calendar";
2214             put "\\<td nowrap class=\\\"fbig fbigb pr\\\"\\>
2215 \\<form style=\\\"margin: 0px;\\\" name=\\\"htmlModsStyleForm\\\" id=\\\"htmlModsStyleForm\\\"
2216 action=\\\"javascript:submitHtmlModsStyle();\\\"\\>";
2217
2218             let options =
2219               ("0", "style/theme")
2220               ::
2221               Array.to_list (Array.mapi (fun i style -> string_of_int i, style.style_name) CommonMessages.styles)
2222               @
2223               if Sys.file_exists html_themes_dir then begin
2224                 let list = Unix2.list_directory html_themes_dir in
2225                 List.fold_left (fun acc d ->
2226                   if Unix2.is_directory (Filename.concat html_themes_dir d) then
2227                     let sd = (if String.length d > 11 then String.sub d 0 11 else d) in
2228                     (d,sd) :: acc
2229                   else
2230                     acc
2231                 ) [] (List.sort (fun d1 d2 -> compare d1 d2) list);
2232               end
2233               else []
2234             in
2235
2236             select "modsStyle" options;
2237
2238             put "\\</form\\>\\</td\\>\\</tr\\>\\</table\\>";
2239             put "\\</td\\>\\</tr\\>";
2240             put "\\<tr\\>\\<td\\>";
2241             put "\\<table cellspacing=0 cellpadding=0 class='hcenter'\\>\\<tr\\>";
2242             button ~title:"Change to simple Webinterface without html_mods" ~cls:"fbig fbigb fbigpad" ~cmd:"html_mods" "toggle html_mods";
2243             put "\\<td nowrap title=\\\"Toggle option helptext from javascript popup to html table\\\" class=\\\"fbig fbigb pr fbigpad\\\"\\>
2244 \\<a onclick=\\\"javascript: {parent.fstatus.location.href='submit?q=set+html_mods_use_js_helptext+%s'; setTimeout('window.location.replace(window.location.href)',1000);return true;}\\\"\\>toggle js_helptext\\</a\\>" (if !!html_mods_use_js_helptext then "false" else "true");
2245             put "\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\</table\\>\\</div\\>\\</br\\>";
2246
2247           html_mods_table_one_row buf "downloaderTable" "downloaders" [
2248           ("", "srh", "!! press ENTER to send changes to core !!"); ];
2249           end
2250
2251         else begin
2252           match args with
2253             | [] | _ :: _ :: _ -> list_options o (CommonInteractive.all_simple_options ())
2254             | ["9"] | ["changed"] -> list_options o changed_list
2255             | [_] -> list_options o (CommonInteractive.parse_simple_options args);
2256           end;
2257         ""
2258     ), "[<option>|changed]:\t\t\tprint options (use * as wildcard), 'changed' prints all changed options, leave empty to print all options";
2259
2260     "vwi", Arg_none (fun o ->
2261         let buf = o.conn_buf in
2262         if use_html_mods o then begin
2263             Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
2264 \\<tr\\>\\<td\\>
2265 \\<table cellspacing=0 cellpadding=0  width='100%%'\\>\\<tr\\>
2266 \\<td class=downloaded width='100%%'\\>\\</td\\>
2267 \\<td nowrap title=\\\"force downloading all web_infos files\\\" class=\\\"fbig\\\"\\>
2268 \\<a onclick=\\\"javascript: {parent.fstatus.location.href='submit?q=force_web_infos';}\\\"\\>Re-download all\\</a\\>
2269 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript: {
2270                    var getdir = prompt('Input: <kind> <URL> [<period>]','server.met URL')
2271                    parent.fstatus.location.href='submit?q=urladd+' + encodeURIComponent(getdir);
2272                    setTimeout('window.location.reload()',1000);
2273                     }\\\"\\>Add URL\\</a\\>
2274 \\</td\\>
2275 \\</tr\\>\\</table\\>
2276 \\</td\\>\\</tr\\>
2277 \\<tr\\>\\<td\\>";
2278
2279             if Hashtbl.length web_infos_table = 0 then
2280               html_mods_table_one_row buf "serversTable" "servers" [
2281                 ("", "srh", "no jobs defined"); ]
2282             else begin
2283
2284               html_mods_table_header buf "web_infoTable" "vo" [
2285                 ( Str, "srh ac", "Click to remove URL", "Remove" ) ;
2286                 ( Str, "srh", "Download now", "DL" ) ;
2287                 ( Str, "srh", "Filetype", "Type" ) ;
2288                 ( Num, "srh", "Interval in hours", "Interval" ) ;
2289                 ( Str, "srh", "URL", "URL" ) ;
2290                 ( Str, "srh", "URL state", "State" ) ;
2291               ] ;
2292
2293               html_mods_cntr_init ();
2294               Hashtbl.iter (fun key w ->
2295                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
2296                 Printf.bprintf buf "
2297         \\<td title=\\\"Click to remove URL\\\"
2298         onMouseOver=\\\"mOvr(this);\\\"
2299         onMouseOut=\\\"mOut(this);\\\"
2300         onClick=\\\'javascript:{
2301         parent.fstatus.location.href=\\\"submit?q=urlremove+\\\\\\\"%s\\\\\\\"\\\"
2302         setTimeout(\\\"window.location.reload()\\\",1000);}'
2303         class=\\\"srb\\\"\\>Remove\\</td\\>" (Url.encode w.url);
2304                 Printf.bprintf buf "
2305         \\<td title=\\\"Download now\\\"
2306         onMouseOver=\\\"mOvr(this);\\\"
2307         onMouseOut=\\\"mOut(this);\\\"
2308         onClick=\\\'javascript:{
2309         parent.fstatus.location.href=\\\"submit?q=force_web_infos+\\\\\\\"%s\\\\\\\"\\\";}'
2310         class=\\\"srb\\\"\\>DL\\</td\\>" (Url.encode w.url);
2311           Printf.bprintf buf "
2312               \\<td title=\\\"%s\\\" class=\\\"sr\\\"\\>%s\\</td\\>
2313               \\<td class=\\\"sr\\\"\\>%d\\</td\\>"  w.url w.kind w.period;
2314           Printf.bprintf buf "
2315               \\<td class=\\\"sr\\\"\\>%s\\</td\\>" w.url;
2316           Printf.bprintf buf "
2317               \\<td class=\\\"sr\\\"\\>%s\\</td\\>
2318               \\</tr\\>" (string_of_web_infos_state w.state);
2319               ) web_infos_table;
2320             end;
2321             Printf.bprintf buf "\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
2322
2323             html_mods_table_header buf "web_infoTable" "vo" [
2324               ( Str, "srh", "Web kind", "Kind" );
2325               ( Str, "srh", "Description", "Type" ) ];
2326
2327             html_mods_cntr_init ();
2328             List.iter (fun (kind, data) ->
2329                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
2330                 Printf.bprintf buf "
2331               \\<td class=\\\"sr\\\"\\>%s\\</td\\>
2332               \\<td class=\\\"sr\\\"\\>%s\\</td\\>" kind data.description
2333             ) !CommonWeb.file_kinds;
2334
2335             Printf.bprintf buf "\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
2336             print_option_help o web_infos
2337
2338           end
2339         else
2340             begin
2341               Printf.bprintf buf "kind / period / url / state :\n";
2342               Hashtbl.iter (fun key w ->
2343                   Printf.bprintf buf "%s ; %d ; %s; %s\n"
2344                     w.kind w.period w.url (string_of_web_infos_state w.state)
2345               ) web_infos_table;
2346               Printf.bprintf buf "\nAllowed values for kind:\n";
2347               List.iter (fun (kind, data) ->
2348                   Printf.bprintf buf "%s - %s\n" kind data.description
2349               ) !CommonWeb.file_kinds
2350             end;
2351         ""
2352     ), ":\t\t\t\t\tprint web_infos options";
2353
2354     "options", Arg_multiple (fun args o ->
2355         let buf = o.conn_buf in
2356         match args with
2357           [] ->
2358             Printf.bprintf buf "Available sections for options: \n";
2359
2360             List.iter (fun s ->
2361                 Printf.bprintf buf "  $b%s$n\n" (section_name s);
2362             ) (sections downloads_ini);
2363
2364             networks_iter (fun r ->
2365                 List.iter (fun file ->
2366                     List.iter (fun s ->
2367                         Printf.bprintf buf "  $b%s::%s$n\n"
2368                           r.network_name
2369                           (section_name s);
2370                     ) (sections file)
2371                 ) r.network_config_file
2372             );
2373             "\n\nUse 'options section' to see options in this section"
2374
2375         | ss ->
2376
2377             let print_section name prefix (s: options_section) =
2378               if List.mem name ss then
2379                 Printf.bprintf buf "Options in section $b%s$n:\n" name;
2380               List.iter (fun o ->
2381                   Printf.bprintf buf "  %s [$r%s%s$n]= $b%s$n\n"
2382                     (if o.option_desc = "" then
2383                       o.option_name else o.option_desc)
2384                   prefix o.option_name o.option_value
2385               ) (strings_of_section_options "" s)
2386             in
2387             List.iter (fun s ->
2388                 print_section (section_name s) "" s
2389             ) (sections downloads_ini);
2390
2391             networks_iter (fun r ->
2392                 List.iter (fun file ->
2393                     List.iter (fun s ->
2394                         print_section
2395                           (Printf.sprintf "%s::%s" r.network_name
2396                             (section_name s)) (r.network_shortname ^ "-") s
2397                     ) (sections file)
2398                 ) r.network_config_file
2399             );
2400
2401             "\nUse '$rset option \"value\"$n' to change a value where options is
2402 the name between []"
2403     ), ":\t\t\t\t$bprint options values by section$n";
2404
2405   ]
2406
2407 (*************************************************************************)
2408 (*                                                                       *)
2409 (*                         Driver/Sharing                                *)
2410 (*                                                                       *)
2411 (*************************************************************************)
2412
2413 let _ =
2414   register_commands "Driver/Sharing"
2415     [
2416
2417     "reshare", Arg_none (fun o ->
2418         let buf = o.conn_buf in
2419         shared_check_files ();
2420         if o.conn_output = HTML then
2421           html_mods_table_one_row buf "serversTable" "servers" [
2422             ("", "srh", "Reshare check done"); ]
2423         else
2424           Printf.bprintf buf "Reshare check done";
2425         _s ""
2426     ), ":\t\t\t\tcheck shared files for removal";
2427
2428      "debug_disk", Arg_one (fun arg o ->
2429          let buf = o.conn_buf in
2430          let print_i64o = function
2431            | None -> "Unknown"
2432            | Some v -> Printf.sprintf "%Ld" v in
2433          let print_io = function
2434            | None -> "Unknown"
2435            | Some v -> Printf.sprintf "%d" v in
2436          Printf.bprintf buf "working on dir %s\n" arg;
2437          Printf.bprintf buf "bsize %s\n" (print_i64o (Unix32.bsize arg));
2438          Printf.bprintf buf "blocks %s\n" (print_i64o (Unix32.blocks arg));
2439          Printf.bprintf buf "bfree %s\n" (print_i64o (Unix32.bfree arg));
2440          Printf.bprintf buf "bavail %s\n" (print_i64o (Unix32.bavail arg));
2441          Printf.bprintf buf "fnamelen %s\n" (print_io (Unix32.fnamelen arg));
2442          Printf.bprintf buf "filesystem %s\n" (Unix32.filesystem arg);
2443          let print_i64o_amount = function
2444            | None -> "Unknown"
2445            | Some v -> Printf.sprintf "%Ld - %s" v (size_of_int64 v) in
2446          Printf.bprintf buf "disktotal %s\n" (print_i64o_amount (Unix32.disktotal arg));
2447          Printf.bprintf buf "diskfree %s\n" (print_i64o_amount (Unix32.diskfree arg));
2448          Printf.bprintf buf "diskused %s\n" (print_i64o_amount (Unix32.diskused arg));
2449          let print_percento = function
2450            | None -> "Unknown"
2451            | Some p -> Printf.sprintf "%d%%" p in
2452          Printf.bprintf buf "percentused %s\n" (print_percento (Unix32.percentused arg));
2453          Printf.bprintf buf "percentfree %s\n" (print_percento (Unix32.percentfree arg));
2454          let stat = Unix.LargeFile.stat arg in
2455          Printf.bprintf buf "\nstat_device %d\n" stat.Unix.LargeFile.st_dev;
2456          Printf.bprintf buf "stat_inode %d\n" stat.Unix.LargeFile.st_ino;
2457
2458          _s ""
2459      ), "debug command (example: disk .)";
2460
2461      "debug_dir", Arg_one (fun arg o ->
2462          let buf = o.conn_buf in
2463          let filelist = Unix2.list_directory arg in
2464          Printf.bprintf buf "%d entries in dir %s\n" (List.length filelist) arg;
2465          List.iter (fun file ->
2466            Printf.bprintf buf "%s\n     %s\nMime %s\n\n"
2467              file
2468              (match Magic.M.magic_fileinfo (Filename.concat arg file) false with
2469                 None -> "unknown"
2470               | Some fileinfo -> fileinfo)
2471              (match Magic.M.magic_fileinfo (Filename.concat arg file) true with
2472                 None -> "unknown"
2473               | Some fileinfo -> fileinfo)
2474          ) filelist;
2475          _s ""
2476      ), "debug command (example: disk .)";
2477
2478      "debug_fileinfo", Arg_one (fun arg o ->
2479          let buf = o.conn_buf in
2480          (try
2481             let module U = Unix.LargeFile in
2482             let s = U.stat arg in
2483             Printf.bprintf buf "st_dev %d\n" s.U.st_dev;
2484             Printf.bprintf buf "st_ino %d\n" s.U.st_ino;
2485             Printf.bprintf buf "st_uid %d\n" s.U.st_uid;
2486             Printf.bprintf buf "st_gid %d\n" s.U.st_gid;
2487             Printf.bprintf buf "st_size %Ld\n" s.U.st_size;
2488             Printf.bprintf buf "st_atime %s\n" (Date.to_full_string s.U.st_atime);
2489             Printf.bprintf buf "st_mtime %s\n" (Date.to_full_string s.U.st_mtime);
2490             Printf.bprintf buf "st_ctime %s\n" (Date.to_full_string s.U.st_ctime);
2491             let user,group = Unix32.owner arg in
2492             Printf.bprintf buf "username %s\n" user;
2493             Printf.bprintf buf "groupname %s\n" group;
2494           with e -> Printf.bprintf buf "Error %s when opening %s\n" (Printexc2.to_string e) arg);
2495          _s ""
2496      ), "debug command (example: file .)";
2497
2498      "debug_rlimit", Arg_none (fun o ->
2499          let buf = o.conn_buf in
2500          let cpu = Unix2.ml_getrlimit Unix2.RLIMIT_CPU in
2501          let fsize = Unix2.ml_getrlimit Unix2.RLIMIT_FSIZE in
2502          let data = Unix2.ml_getrlimit Unix2.RLIMIT_DATA in
2503          let stack = Unix2.ml_getrlimit Unix2.RLIMIT_STACK in
2504          let core = Unix2.ml_getrlimit Unix2.RLIMIT_CORE in
2505          let rss = Unix2.ml_getrlimit Unix2.RLIMIT_RSS in
2506          let nprof = Unix2.ml_getrlimit Unix2.RLIMIT_NPROF in
2507          let nofile = Unix2.ml_getrlimit Unix2.RLIMIT_NOFILE in
2508          let memlock = Unix2.ml_getrlimit Unix2.RLIMIT_MEMLOCK in
2509          let rlimit_as = Unix2.ml_getrlimit Unix2.RLIMIT_AS in
2510          Printf.bprintf buf "cpu %d %d\n" cpu.Unix2.rlim_cur cpu.Unix2.rlim_max;
2511          Printf.bprintf buf "fsize %d %d\n" fsize.Unix2.rlim_cur fsize.Unix2.rlim_max;
2512          Printf.bprintf buf "data %d %d\n" data.Unix2.rlim_cur data.Unix2.rlim_max;
2513          Printf.bprintf buf "stack %d %d\n" stack.Unix2.rlim_cur stack.Unix2.rlim_max;
2514          Printf.bprintf buf "core %d %d\n" core.Unix2.rlim_cur core.Unix2.rlim_max;
2515          Printf.bprintf buf "rss %d %d\n" rss.Unix2.rlim_cur rss.Unix2.rlim_max;
2516          Printf.bprintf buf "nprof %d %d\n" nprof.Unix2.rlim_cur nprof.Unix2.rlim_max;
2517          Printf.bprintf buf "nofile %d %d\n" nofile.Unix2.rlim_cur nofile.Unix2.rlim_max;
2518          Printf.bprintf buf "memlock %d %d\n" memlock.Unix2.rlim_cur memlock.Unix2.rlim_max;
2519          Printf.bprintf buf "as %d %d\n" rlimit_as.Unix2.rlim_cur rlimit_as.Unix2.rlim_max;
2520          _s ""
2521      ), "debug command";
2522
2523     "shares", Arg_none (fun o ->
2524         if user2_is_admin o.conn_user.ui_user then begin
2525         let buf = o.conn_buf in
2526
2527         if use_html_mods o then begin
2528             Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
2529 \\<tr\\>\\<td\\>
2530 \\<table cellspacing=0 cellpadding=0  width='100%%'\\>\\<tr\\>
2531 \\<td class=downloaded width=100%%\\>\\</td\\>
2532 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript: {
2533                    var getdir = prompt('Input: <priority#> <directory> [<strategy>] (surround dir with quotes if necessary)','0 /home/mldonkey/share')
2534                    parent.fstatus.location.href='submit?q=share+' + encodeURIComponent(getdir);
2535                    setTimeout('window.location.reload()',1000);
2536                     }\\\"\\>Add Share\\</a\\>
2537 \\</td\\>
2538 \\</tr\\>\\</table\\>
2539 \\</td\\>\\</tr\\>
2540 \\<tr\\>\\<td\\>";
2541
2542             html_mods_table_header buf "sharesTable" "shares" [
2543                ( Str, "srh ac", "Click to unshare directory", "Unshare" ) ;
2544                ( Num, "srh ar", "Priority", "P" ) ;
2545                ( Str, "srh", "Directory", "Directory" ) ;
2546                ( Str, "srh", "Strategy", "Strategy" ) ;
2547                ( Num, "srh ar", "HDD used", "used" ) ;
2548                ( Num, "srh ar", "HDD free", "free" ) ;
2549                ( Num, "srh ar", "% free", "% free" ) ;
2550                ( Str, "srh", "Filesystem", "FS" ) ];
2551
2552             html_mods_cntr_init ();
2553             List.iter (fun shared_dir ->
2554                 let dir = shared_dir.shdir_dirname in
2555                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>
2556         \\<td title=\\\"Click to unshare this directory\\\"
2557         onMouseOver=\\\"mOvr(this);\\\"
2558         onMouseOut=\\\"mOut(this);\\\"
2559         onClick=\\\'javascript:{
2560         parent.fstatus.location.href=\\\"submit?q=unshare+\\\\\\\"%s\\\\\\\"\\\"
2561         setTimeout(\\\"window.location.reload()\\\",1000);}'
2562         class=\\\"srb\\\"\\>Unshare\\</td\\>
2563         \\<td class=\\\"sr ar\\\"\\>%d\\</td\\>
2564         \\<td class=\\\"sr\\\"\\>%s\\</td\\>
2565         \\<td class=\\\"sr\\\"\\>%s\\</td\\>
2566         \\<td class=\\\"sr ar\\\"\\>%s\\</td\\>
2567         \\<td class=\\\"sr ar\\\"\\>%s\\</td\\>
2568         \\<td class=\\\"sr ar\\\"\\>%s\\</td\\>
2569         \\<td class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>"
2570                 (html_mods_cntr ())
2571                 (Url.encode dir)
2572                 shared_dir.shdir_priority
2573                 dir
2574                 shared_dir.shdir_strategy
2575                 (match Unix32.diskused dir with
2576                 | None -> "---"
2577                 | Some du -> size_of_int64 du)
2578                 (match Unix32.diskfree dir with
2579                 | None -> "---"
2580                 | Some df -> size_of_int64 df)
2581                 (match Unix32.percentfree dir with
2582                 | None -> "---"
2583                 | Some p -> Printf.sprintf "%d%%" p)
2584                 (Unix32.filesystem dir);
2585             )
2586             !!shared_directories;
2587
2588             Printf.bprintf buf "\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
2589             print_option_help o shared_directories;
2590             Printf.bprintf buf "\\<P\\>";
2591
2592             html_mods_big_header_start buf "sharesTable" ["Share strategies"];
2593             html_mods_table_header buf "sharesTable" "shares" [
2594                ( Str, "srh", "Name", "Name" ) ;
2595                ( Str, "srh", "Incoming", "Incoming" ) ;
2596                ( Str, "srh", "Directories", "Directories" ) ;
2597                ( Str, "srh", "Recursive", "Recursive" ) ;
2598                ( Num, "srh", "Minsize", "Minsize" ) ;
2599                ( Num, "srh", "Maxsize", "Maxsize" ) ;
2600                ( Str, "srh", "Extensions", "Extensions" ) ];
2601
2602             html_mods_cntr_init ();
2603
2604             let int64_print v =
2605               if v = Int64.max_int then "unlimited" else Int64ops.int64_to_human_readable v in
2606
2607             List.iter (fun (s,t) ->
2608                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
2609                 html_mods_td buf [
2610                     ("", "sr", s);
2611                     ("", "sr", string_of_bool t.sharing_incoming);
2612                     ("", "sr", string_of_bool t.sharing_directories);
2613                     ("", "sr", string_of_bool t.sharing_recursive);
2614                     ("", "sr", (int64_print t.sharing_minsize));
2615                     ("", "sr", (int64_print t.sharing_maxsize));
2616                     ("", "sr", (String.concat " " t.sharing_extensions));
2617                     ];
2618                 Printf.bprintf buf "\\</tr\\>\n"
2619               ) !!sharing_strategies;
2620
2621           end
2622         else
2623           begin
2624
2625             Printf.bprintf buf "Shared directories:\n";
2626             List.iter (fun sd ->
2627                 Printf.bprintf buf "  %d %s %s\n"
2628                 sd.shdir_priority sd.shdir_dirname sd.shdir_strategy)
2629             !!shared_directories;
2630
2631           end;
2632         ""
2633           end
2634         else
2635           _s "You are not allowed to list shared directories"
2636     ), ":\t\t\t\tprint shared directories";
2637
2638     "share", Arg_multiple (fun args o ->
2639         if user2_is_admin o.conn_user.ui_user then begin
2640         let (prio, arg, strategy) = match args with
2641           | [prio; arg; strategy] -> int_of_string prio, arg, strategy
2642           | [prio; arg] -> int_of_string prio, arg, "only_directory"
2643           | [arg] -> 0, arg, "only_directory"
2644           | _  -> failwith "Bad number of arguments"
2645         in
2646
2647         let shdir = {
2648             shdir_dirname = arg;
2649             shdir_priority = prio;
2650             shdir_networks = [];
2651             shdir_strategy = strategy;
2652           } in
2653
2654         if Unix2.is_directory arg then
2655           begin
2656             try
2657               let d = List.find (fun d -> d.shdir_dirname = arg) !!shared_directories in
2658               let old_prio = d.shdir_priority in
2659               d.shdir_priority <- prio;
2660               Printf.sprintf "prio of %s changed from %d to %d"
2661                 d.shdir_dirname old_prio d.shdir_priority
2662             with Not_found ->
2663               shared_directories =:= shdir :: !!shared_directories;
2664               shared_add_directory shdir;
2665               Printf.sprintf "directory %s added%s"
2666                 shdir.shdir_dirname
2667                 (if shdir.shdir_priority <> 0 then
2668                     Printf.sprintf " with prio %d" shdir.shdir_priority
2669                  else "")
2670           end
2671         else
2672           "no such directory"
2673           end
2674         else
2675           _s "You are not allowed to share directories"
2676     ), "<priority> <dir> [<strategy>] :\tshare directory <dir> with <priority> [and sharing strategy <strategy>]";
2677
2678     "unshare", Arg_one (fun arg o ->
2679
2680         if user2_is_admin o.conn_user.ui_user then begin
2681         let found = ref false in
2682         shared_directories =:= List.filter (fun sd ->
2683             let diff = sd.shdir_dirname <> arg in
2684             if not diff then begin
2685               found := true;
2686               shared_iter (fun s ->
2687                 let impl = as_shared_impl s in
2688                   if (Filename.dirname impl.impl_shared_fullname) = arg
2689                     then shared_unshare s
2690               )
2691             end;
2692             diff
2693         ) !!shared_directories;
2694         if !found then begin
2695             CommonShared.shared_check_files ();
2696             _s "directory removed"
2697           end else
2698           _s "directory already unshared"
2699           end
2700         else
2701           _s "You are not allowed to unshare directories"
2702     ), "<dir> :\t\t\t\tunshare directory <dir>";
2703
2704     "upstats", Arg_none (fun o ->
2705         if not (user2_can_view_uploads o.conn_user.ui_user) then
2706           print_command_result o "You are not allowed to see upload statistics"
2707         else
2708           begin
2709             let list = ref [] in
2710             shared_iter (fun s ->
2711               let impl = as_shared_impl s in
2712               list := impl :: !list
2713             );
2714             print_upstats o !list None;
2715           end;
2716         _s ""
2717     ), ":\t\t\t\tstatistics on upload";
2718
2719     "links", Arg_multiple (fun args o ->
2720         let buf = o.conn_buf in
2721         if not (user2_can_view_uploads o.conn_user.ui_user) then
2722           print_command_result o "You are not allowed to see shared files list"
2723         else begin
2724
2725         let list = Hashtbl.create !shared_counter in
2726
2727         let compute_shares () =
2728           shared_iter (fun s ->
2729             let impl = as_shared_impl s in
2730             try
2731               ignore (Hashtbl.find list impl.impl_shared_id)
2732             with Not_found ->
2733                 Hashtbl.add list impl.impl_shared_id {
2734                     filename = impl.impl_shared_codedname;
2735                     filesize = impl.impl_shared_size;
2736                     fileid = impl.impl_shared_id;
2737                 })
2738         in
2739
2740         let compute_downloads () =
2741           List.iter (fun f ->
2742             try
2743               ignore (Hashtbl.find list f.file_md4)
2744             with Not_found ->
2745                 Hashtbl.add list f.file_md4 {
2746                     filename = f.file_name;
2747                     filesize = f.file_size;
2748                     fileid = f.file_md4;
2749                 }) (List2.tail_map file_info
2750                       (user2_filter_files !!files o.conn_user.ui_user))
2751         in
2752
2753         let list =
2754           List.sort ( fun f1 f2 ->
2755             String.compare
2756               (Filename.basename f1.filename)
2757               (Filename.basename f2.filename)
2758         )
2759         (match args with
2760          | ["downloading"] -> compute_downloads (); Hashtbl2.to_list list
2761          | ["shared"] -> compute_shares (); Hashtbl2.to_list list
2762          | _ -> compute_shares (); compute_downloads (); Hashtbl2.to_list list)
2763         in
2764
2765         List.iter (fun f ->
2766           if (f.fileid <> Md4.null) then
2767             Printf.bprintf buf "%s\n" (file_print_ed2k_link
2768               (Filename.basename f.filename) f.filesize f.fileid);
2769         ) list;
2770         end;
2771         "Done"
2772     ), "[downloading|shared|empty for all]: list links of shared files";
2773
2774     "uploaders", Arg_none (fun o ->
2775         let buf = o.conn_buf in
2776
2777         if not (user2_can_view_uploads o.conn_user.ui_user) then
2778           print_command_result o "You are not allowed to see uploaders list"
2779         else begin
2780
2781         let nuploaders = Intmap.length !uploaders in
2782         if use_html_mods o then
2783           begin
2784             html_mods_cntr_init ();
2785             Printf.bprintf buf "\\<div class=\\\"uploaders\\\"\\>";
2786             html_mods_table_one_row buf "uploadersTable" "uploaders" [
2787               ("", "srh", Printf.sprintf "Total upload slots: %d (%d) | Pending slots: %d\n" nuploaders
2788                 (Fifo.length CommonUploads.upload_clients)
2789                 (Intmap.length !CommonUploads.pending_slots_map)); ];
2790             if nuploaders > 0 then
2791
2792               begin
2793
2794                 html_mods_table_header buf "uploadersTable" "uploaders" ([
2795                   ( Num, "srh ac", "Client number", "Num" ) ;
2796                   ( Str, "srh", "Network", "Network" ) ;
2797                   ( Str, "srh", "Connection type [I]ndirect [D]irect", "C" ) ;
2798                   ( Str, "srh", "Client name", "Client name" ) ;
2799                   ( Str, "srh", "Secure User Identification [N]one, [P]assed, [F]ailed", "S" ) ;
2800                   ( Str, "srh", "IP address", "IP address" ) ;
2801                   ] @ (if Geoip.active () then [( Str, "srh", "Country Code/Name", "CC" )] else []) @ [
2802                   ( Str, "srh", "Connected time (minutes)", "CT" ) ;
2803                   ( Str, "srh", "Client brand", "CB" ) ;
2804                   ( Str, "srh", "Client release", "CR" ) ;
2805                   ] @
2806                   (if !!emule_mods_count then [( Str, "srh", "eMule MOD", "EM" )] else [])
2807                   @ [
2808                   ( Num, "srh ar", "Total DL bytes from this client for all files", "tDL" ) ;
2809                   ( Num, "srh ar", "Total UL bytes to this client for all files", "tUL" ) ;
2810                   ( Num, "srh ar", "Session DL bytes from this client for all files", "sDL" ) ;
2811                   ( Num, "srh ar", "Session UL bytes to this client for all files", "sUL" ) ;
2812                   ( Str, "srh ar", "Slot kind", "Slot" ) ;
2813                   ( Str, "srh", "Filename", "Filename" ) ]);
2814
2815                 List.iter (fun c ->
2816                     try
2817                       let i = client_info c in
2818                       if is_connected i.client_state then begin
2819
2820                           Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"
2821                         title=\\\"[%d] Add as friend (avg: %.1f KB/s)\\\"
2822                         onMouseOver=\\\"mOvr(this);\\\"
2823                         onMouseOut=\\\"mOut(this);\\\"
2824                         onClick=\\\"parent.fstatus.location.href='submit?q=friend_add+%d'\\\"\\>"
2825                             (html_mods_cntr ()) (client_num c)
2826                           (Int64.to_float i.client_session_uploaded /. 1024. /.
2827                               float_of_int (max 1 ((last_time ()) - i.client_connect_time)))
2828                           (client_num c);
2829
2830                           html_mods_td buf [
2831                             ("", "sr", Printf.sprintf "%d" (client_num c)); ];
2832
2833                           let ips,cc,cn = string_of_kind_geo i.client_kind i.client_country_code in
2834
2835                           client_print_html c o;
2836                           html_mods_td buf ([
2837                             ("", "sr", (match i.client_sui_verified with
2838                               | None -> "N"
2839                                | Some b -> if b then "P" else "F"
2840                             ));
2841                             ("", "sr", ips);
2842                             ] @ (if Geoip.active () then [(cn, "sr", CommonPictures.flag_html cc)] else []) @ [
2843                             ("", "sr", Printf.sprintf "%d" (((last_time ()) - i.client_connect_time) / 60));
2844                             (client_software i.client_software i.client_os, "sr", client_software_short i.client_software i.client_os);
2845                             ("", "sr", i.client_release);
2846                             ] @
2847                             (if !!emule_mods_count then [("", "sr", i.client_emulemod)] else [])
2848                             @ [
2849                             ("", "sr ar", size_of_int64 i.client_total_downloaded);
2850                             ("", "sr ar", size_of_int64 i.client_total_uploaded);
2851                             ("", "sr ar", size_of_int64 i.client_session_downloaded);
2852                             ("", "sr ar", size_of_int64 i.client_session_uploaded);
2853                             (let text1, text2 =
2854                                 match client_slot c with
2855                                 | FriendSlot -> "Friend", "F"
2856                                 | ReleaseSlot -> "Release", "R"
2857                                 | SmallFileSlot -> "Small file", "S"
2858                                 | PrioSlot dir -> "Prio dir: " ^ dir, "P"
2859                                 | _ -> "", "" in text1, "sr ar", text2);
2860                             ("", "sr", (match i.client_upload with
2861                                   Some f -> shorten f !!max_name_len
2862                                 | None -> "") ) ]);
2863
2864                           Printf.bprintf buf "\\</tr\\>"
2865                         end
2866                     with _ -> ()
2867                 ) (List.sort
2868                     (fun c1 c2 -> compare (client_num c1) (client_num c2))
2869                   (Intmap.to_list !uploaders));
2870                 Printf.bprintf buf "\\</table\\>\\</div\\>";
2871               end;
2872
2873             if !!html_mods_show_pending && Intmap.length !CommonUploads.pending_slots_map > 0 then
2874
2875               begin
2876                 Printf.bprintf buf "\\<br\\>\\<br\\>";
2877                 html_mods_table_header buf "uploadersTable" "uploaders" ([
2878                   ( Num, "srh ac", "Client number", "Num" ) ;
2879                   ( Str, "srh", "Network", "Network" ) ;
2880                   ( Str, "srh", "Connection type [I]ndirect [D]irect", "C" ) ;
2881                   ( Str, "srh", "Client name", "Client name" ) ;
2882                   ( Str, "srh", "Secure User Identification [N]one, [P]assed, [F]ailed", "S" ) ;
2883                   ( Str, "srh", "IP address", "IP address" ) ;
2884                   ] @ (if Geoip.active () then [( Str, "srh", "Country Code/Name", "CC" )] else []) @ [
2885                   ( Str, "srh", "Client brand", "CB" ) ;
2886                   ( Str, "srh", "Client release", "CR" ) ;
2887                   ] @
2888                   (if !!emule_mods_count then [( Str, "srh", "eMule MOD", "EM" )] else [])
2889                   @ [
2890                   ( Num, "srh ar", "Total DL bytes from this client for all files", "tDL" ) ;
2891                   ( Num, "srh ar", "Total UL bytes to this client for all files", "tUL" ) ;
2892                   ( Num, "srh ar", "Session DL bytes from this client for all files", "sDL" ) ;
2893                   ( Num, "srh ar", "Session UL bytes to this client for all files", "sUL" ) ;
2894                   ( Str, "srh", "Filename", "Filename" ) ]);
2895
2896                 Intmap.iter (fun cnum c ->
2897
2898                     try
2899                       let i = client_info c in
2900                       let ips,cc,cn = string_of_kind_geo i.client_kind i.client_country_code in
2901
2902                       Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"
2903                                         title=\\\"Add as Friend\\\" onMouseOver=\\\"mOvr(this);\\\" onMouseOut=\\\"mOut(this);\\\"
2904                                         onClick=\\\"parent.fstatus.location.href='submit?q=friend_add+%d'\\\"\\>"
2905                         (html_mods_cntr ()) cnum;
2906
2907                       html_mods_td buf [
2908                         ("", "sr", Printf.sprintf "%d" (client_num c)); ];
2909
2910                       client_print_html c o;
2911
2912                       html_mods_td buf ([
2913                         ("", "sr", (match i.client_sui_verified with
2914                           | None -> "N"
2915                           | Some b -> if b then "P" else "F"
2916                         ));
2917                         ("", "sr", ips);
2918                         ] @ (if Geoip.active () then [(cn, "sr", CommonPictures.flag_html cc)] else []) @ [
2919                         (client_software i.client_software i.client_os, "sr", client_software_short i.client_software i.client_os);
2920                         ("", "sr", i.client_release);
2921                         ] @
2922                         (if !!emule_mods_count then [("", "sr", i.client_emulemod )] else [])
2923                         @ [
2924                         ("", "sr ar", size_of_int64 i.client_total_downloaded);
2925                         ("", "sr ar", size_of_int64 i.client_total_uploaded);
2926                         ("", "sr ar", size_of_int64 i.client_session_downloaded);
2927                         ("", "sr ar", size_of_int64 i.client_session_uploaded);
2928                         ("", "sr", (match i.client_upload with
2929                               Some f -> shorten f !!max_name_len
2930                             | None -> "") ) ]);
2931
2932                       Printf.bprintf buf "\\</tr\\>";
2933                     with _ -> ();
2934
2935                 ) !CommonUploads.pending_slots_map;
2936                 Printf.bprintf buf "\\</table\\>\\</div\\>";
2937               end;
2938             Printf.bprintf buf "\\</div\\>"
2939           end
2940         else
2941           begin
2942             Intmap.iter (fun _ c ->
2943                 try
2944                   let i = client_info c in
2945                   client_print c o;
2946                   Printf.bprintf buf "client: %s downloaded: %s uploaded: %s\n" i.client_software (Int64.to_string i.client_total_downloaded) (Int64.to_string i.client_total_uploaded);
2947                   match i.client_upload with
2948                     Some cu ->
2949                       Printf.bprintf buf "      filename: %s\n" cu
2950                   | None -> ()
2951                 with _ ->
2952                     Printf.bprintf buf "no info on client %d\n" (client_num c )
2953             ) !uploaders;
2954
2955             Printf.bprintf buf "Total upload slots: %d (%d) | Pending slots: %d\n" nuploaders
2956               (Fifo.length CommonUploads.upload_clients)
2957             (Intmap.length !CommonUploads.pending_slots_map);
2958           end
2959       end;
2960       ""
2961     ), ":\t\t\t\tshow users currently uploading";
2962
2963
2964   ]
2965
2966 (*************************************************************************)
2967 (*                                                                       *)
2968 (*                         Driver/Downloads                              *)
2969 (*                                                                       *)
2970 (*************************************************************************)
2971
2972 let _ =
2973   let resume_alias s = s, Arg_multiple (fun args o ->
2974         if args = ["all"] && user2_is_admin o.conn_user.ui_user then
2975           List.iter (fun file ->
2976               file_resume file (admin_user ())
2977           ) !!files
2978         else
2979           List.iter (fun num ->
2980               let num = int_of_string num in
2981               List.iter (fun file ->
2982                   if (as_file_impl file).impl_file_num = num then
2983                       file_resume file o.conn_user.ui_user
2984               ) !!files) args; ""
2985     ), "<num|all> :\t\t\tresume a paused download (use arg 'all' for all files)"
2986   in
2987   register_commands "Driver/Downloads"
2988     [
2989
2990     "priority", Arg_multiple (fun args o ->
2991         let buf = o.conn_buf in
2992         match args with
2993           p :: files ->
2994             let absolute, p = if String2.check_prefix p "=" then
2995                 true, int_of_string (String2.after p 1)
2996               else false, int_of_string p in
2997             List.iter (fun arg ->
2998                 try
2999                   let file = file_find (int_of_string arg) in
3000                   let priority = if absolute then p
3001                     else (file_priority file) + p in
3002                   let priority = if priority < -100 then -100 else
3003                     if priority > 100 then 100 else priority in
3004                   set_file_priority file priority;
3005                   Printf.bprintf buf "Setting priority of %s to %d\n"
3006                     (file_best_name file) (file_priority file);
3007                 with _ -> failwith (Printf.sprintf "No file number %s" arg)
3008             ) files;
3009             force_download_quotas ();
3010             _s "done"
3011         | [] -> "Bad number of args"
3012
3013     ), "<priority> <files numbers> :\tchange file priorities";
3014
3015     "download_order", Arg_two (fun num v o ->
3016         try
3017           let file = file_find (int_of_string num) in
3018           (match v with
3019           | "linear" -> ignore (CommonFile.file_download_order file (Some CommonTypes.LinearStrategy))
3020           | _ -> ignore (CommonFile.file_download_order file (Some CommonTypes.AdvancedStrategy)));
3021           _s (Printf.sprintf "Changed download order of %s to %s"
3022                 (file_best_name file) (file_print_download_order file))
3023         with e -> Printf.sprintf "Exception %s" (Printexc2.to_string e)
3024     ), "<file number> <random|linear> :\tchange download order of file blocks (default random, with first and last block first)";
3025
3026     "confirm", Arg_one (fun arg o ->
3027         match String.lowercase arg with
3028           "yes" | "y" | "true" ->
3029             List.iter (fun file ->
3030                 try
3031                   file_cancel file o.conn_user.ui_user
3032                 with e ->
3033                     lprintf "Exception %s in cancel file %d\n"
3034                       (Printexc2.to_string e) (file_num file)
3035             ) !to_cancel;
3036             to_cancel := [];
3037             _s "Files cancelled"
3038         | "no" | "n" | "false" ->
3039             to_cancel := [];
3040             _s "cancel aborted"
3041         | "what" | "w" ->
3042             files_to_cancel o
3043         | _ -> failwith "Invalid argument"
3044     ), "<yes|no|what> :\t\t\tconfirm cancellation";
3045
3046     "test_recover", Arg_one (fun num o ->
3047
3048         let num = int_of_string num in
3049         let file = file_find num in
3050         let segments = CommonFile.recover_bytes file in
3051         let buf = o.conn_buf in
3052         Printf.bprintf buf "Segments:\n";
3053         let downloaded = ref zero in
3054         List.iter (fun (begin_pos, end_pos) ->
3055             Printf.bprintf buf "   %Ld - %Ld\n" begin_pos end_pos;
3056             downloaded := !downloaded ++ (end_pos -- begin_pos);
3057         ) segments;
3058         Printf.sprintf "Downloaded: %Ld\n" !downloaded
3059     ), "<num> :\t\t\tprint the segments downloaded in file";
3060
3061
3062     "cancel", Arg_multiple (fun args o ->
3063
3064         let file_cancel num =
3065           if not (List.memq num !to_cancel) then
3066             to_cancel := num :: !to_cancel
3067         in
3068         if args = ["all"] && user2_is_admin o.conn_user.ui_user then
3069           List.iter (fun file ->
3070               file_cancel file
3071           ) !!files
3072         else
3073           List.iter (fun num ->
3074               let num = int_of_string num in
3075               List.iter (fun file ->
3076                   if (as_file_impl file).impl_file_num = num then begin
3077                       lprintf "TRY TO CANCEL FILE\n";
3078                       file_cancel file
3079                     end
3080               ) !!files) args;
3081         files_to_cancel o
3082     ), "<num|all> :\t\t\tcancel download (use arg 'all' for all files)";
3083
3084     "downloaders", Arg_none (fun o ->
3085         let buf = o.conn_buf in
3086
3087         if use_html_mods o then
3088           html_mods_table_header buf "downloadersTable" "downloaders" ([
3089               ( Num, "srh ac", "Client number (click to add as friend)", "Num" ) ;
3090               ( Str, "srh", "Client state", "CS" ) ;
3091               ( Str, "srh", "Client name", "Name" ) ;
3092               ( Str, "srh", "Client brand", "CB" ) ;
3093               ( Str, "srh", "Client release", "CR" ) ;
3094             ] @
3095               (if !!emule_mods_count then [( Str, "srh", "eMule MOD", "EM" )] else [])
3096             @ [
3097               ( Str, "srh", "Overnet [T]rue, [F]alse", "O" ) ;
3098               ( Num, "srh ar", "Connected time (minutes)", "CT" ) ;
3099               ( Str, "srh", "Connection [I]ndirect, [D]irect", "C" ) ;
3100               ( Str, "srh", "Secure User Identification [N]one, [P]assed, [F]ailed", "S" ) ;
3101               ( Str, "srh", "IP address", "IP address" ) ;
3102               ] @ (if Geoip.active () then [( Str, "srh", "Country Code/Name", "CC" )] else []) @ [
3103               ( Num, "srh ar", "Total UL bytes to this client for all files", "tUL");
3104               ( Num, "srh ar", "Total DL bytes from this client for all files", "tDL");
3105               ( Num, "srh ar", "Session UL bytes to this client for all files", "sUL");
3106               ( Num, "srh ar", "Session DL bytes from this client for all files", "sDL");
3107               ( Str, "srh", "Filename", "Filename" ) ]);
3108
3109         let counter = ref 0 in
3110
3111         List.iter
3112           (fun file ->
3113             if (CommonFile.file_downloaders file o !counter) then counter := 0 else counter := 1;
3114         ) (user2_filter_files !!files o.conn_user.ui_user);
3115
3116         if use_html_mods o then Printf.bprintf buf "\\</table\\>\\</div\\>";
3117
3118         ""
3119     ) , ":\t\t\t\tdisplay downloaders list";
3120
3121     "verify_chunks", Arg_multiple (fun args o ->
3122         let buf = o.conn_buf in
3123         match args with
3124           [arg] ->
3125             let num = int_of_string arg in
3126               List.iter
3127                 (fun file -> if (as_file_impl file).impl_file_num = num then
3128                     begin
3129                       Printf.bprintf  buf "Verifying Chunks of file %d" num;
3130                       file_check file;
3131                     end
3132               )
3133               !!files;
3134             ""
3135         | _ -> ();
3136             _s "done"
3137     ), "<num> :\t\t\tverify chunks of file <num>";
3138
3139     "pause", Arg_multiple (fun args o ->
3140       let filter =
3141         match args with (* TODO richer condition language *)
3142         | ["where";"priority";(">"|"<" as op);n] ->
3143           let n = int_of_string n in
3144           let op = if op = ">" then (>) else (<) in
3145           (fun file -> op (file_priority file) n)
3146         | ["all"] -> (fun _ -> true)
3147         | l ->
3148           let l = List.map int_of_string l in
3149           (fun file -> List.mem (file_num file) l)
3150       in
3151       List.iter begin fun file ->
3152         if filter file then
3153           file_pause file o.conn_user.ui_user
3154       end !!files;
3155       ""
3156     ), "<num|all|where priority < prio> :\t\t\tpause a download (use arg 'all' for all files)";
3157
3158     resume_alias "resume";
3159     resume_alias "unpause";
3160     resume_alias "continue";
3161
3162     "release", Arg_one (fun arg o ->
3163         let num = int_of_string arg in
3164         let file = file_find num in
3165         let old_state = file_release file in
3166         set_file_release file (not (file_release file)) o.conn_user.ui_user;
3167         Printf.sprintf "%s, file: %s"
3168           (match old_state, file_release file with
3169               true, false -> "deactivated release state"
3170             | false, true -> "activated release state"
3171             | _ -> "unchanged status, enough rights?")
3172           (shorten (file_best_name file) !!max_name_len)
3173     ), "<num> :\t\t\t\tchange release state of a download";
3174
3175     "commit", Arg_none (fun o ->
3176         List.iter (fun file ->
3177             file_commit file
3178         ) !!done_files;
3179         let buf = o.conn_buf in
3180         if o.conn_output = HTML then
3181           html_mods_table_one_row buf "serversTable" "servers" [
3182             ("", "srh", "Committed"); ]
3183         else
3184           Printf.bprintf buf "Committed";
3185         ""
3186     ) , ":\t\t\t\t$bmove downloaded files to incoming directory$n";
3187
3188     "vd", Arg_multiple (fun args o ->
3189         let buf = o.conn_buf in
3190         let list = user2_filter_files !!files o.conn_user.ui_user in
3191         let filelist = List2.tail_map file_info list in
3192         match args with
3193           | ["queued"] ->
3194               let list = List.filter ( fun f -> f.file_state = FileQueued ) filelist in
3195               DriverInteractive.display_active_file_list buf o list;
3196               ""
3197           | ["paused"] ->
3198               let list = List.filter ( fun f -> f.file_state = FilePaused ) filelist in
3199               DriverInteractive.display_active_file_list buf o list;
3200               ""
3201           | ["downloading"] ->
3202               let list = List.filter ( fun f -> f.file_state = FileDownloading ) filelist in
3203               DriverInteractive.display_file_list buf o list;
3204               ""
3205           | [arg] ->
3206             let num = int_of_string arg in
3207             if o.conn_output = HTML then
3208               begin
3209                 if use_html_mods o then
3210                   Printf.bprintf buf "\\<div class=\\\"sourcesTable al\\\"\\>\\<table cellspacing=0 cellpadding=0\\>
3211                                 \\<tr\\>\\<td\\>
3212                                 \\<table cellspacing=0 cellpadding=0 width=100%%\\>\\<tr\\>
3213                                 \\<td nowrap class=\\\"fbig\\\"\\>\\<a onclick=\\\"javascript:window.location.href='files'\\\"\\>Display all files\\</a\\>\\</td\\>
3214                                 \\<td nowrap class=\\\"fbig\\\"\\>\\<a onClick=\\\"javascript:parent.fstatus.location.href='submit?q=verify_chunks+%d'\\\"\\>Verify chunks\\</a\\>\\</td\\>
3215                                 \\<td nowrap class=\\\"fbig\\\"\\>\\<a onClick=\\\"javascript:window.location.href='preview_download?q=%d'\\\"\\>Preview\\</a\\>\\</td\\>
3216                                 \\<td nowrap class=\\\"fbig\\\"\\>\\<a onClick=\\\"javascript:window.location.href='submit?q=debug_get_download_prio+%d'\\\"\\>Debug\\</a\\>\\</td\\>
3217                                 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript:window.location.reload()\\\"\\>Reload\\</a\\>\\</td\\>
3218                                 \\<td class=downloaded width=100%%\\>\\</td\\>
3219                                 \\</tr\\>\\</table\\>
3220                                 \\</td\\>\\</tr\\>
3221                                 \\<tr\\>\\<td\\>" num num num
3222                 else begin
3223                     Printf.bprintf  buf "\\<a href=\\\"files\\\"\\>Display all files\\</a\\>  ";
3224                     Printf.bprintf  buf "\\<a href=\\\"submit?q=verify_chunks+%d\\\"\\>Verify chunks\\</a\\>  " num;
3225                     Printf.bprintf  buf "\\<a href=\\\"submit?q=preview+%d\\\"\\>Preview\\</a\\> \n " num;
3226                   end
3227               end;
3228             List.iter
3229               (fun file -> if (as_file_impl file).impl_file_num = num then
3230                   CommonFile.file_print file o)
3231             list;
3232             List.iter
3233               (fun file -> if (as_file_impl file).impl_file_num = num then
3234                   CommonFile.file_print file o)
3235             !!done_files;
3236             ""
3237         | _ ->
3238             DriverInteractive.display_file_list buf o filelist;
3239             ""
3240     ), "[<num>|queued|paused|downloading] :\t$bview file info for download <num>, or lists of queued, paused or downloading files, or all downloads if no argument given$n";
3241
3242     "preview", Arg_one (fun arg o ->
3243
3244         let num = int_of_string arg in
3245         let file = file_find num in
3246         file_preview file;
3247         _s "done"
3248     ), "<file number> :\t\t\tstart previewer for file <file number>";
3249
3250     "rename", Arg_two (fun arg new_name o ->
3251         let num = int_of_string arg in
3252         try
3253           let file = file_find num in
3254           set_file_best_name file new_name "" 0;
3255           Printf.sprintf (_b "Download %d renamed to %s") num (file_best_name file)
3256         with e -> Printf.sprintf (_b "No file number %d, error %s") num (Printexc2.to_string e)
3257     ), "<num> \"<new name>\" :\t\tchange name of download <num> to <new name>";
3258
3259     "filenames_variability", Arg_none (fun o ->
3260       let list = List2.tail_map file_info
3261         (user2_filter_files !!files o.conn_user.ui_user) in
3262       DriverInteractive.filenames_variability o list;
3263       _s "done"
3264     ), ":\t\t\ttell which files have several very different names";
3265
3266     "dllink", Arg_multiple (fun args o ->
3267         let url = String2.unsplit args ' ' in
3268         dllink_parse (o.conn_output = HTML) url o.conn_user.ui_user
3269         ), "<link> :\t\t\t\tdownload ed2k, sig2dat, torrent or other link";
3270
3271     "dllinks", Arg_one (fun arg o ->
3272         let result = Buffer.create 100 in
3273         let file = File.to_string arg in
3274         let lines = String2.split_simplify file '\n' in
3275         List.iter (fun line ->
3276           Buffer.add_string result (dllink_parse (o.conn_output = HTML) line o.conn_user.ui_user);
3277           Buffer.add_string result (if o.conn_output = HTML then "\\<P\\>" else "\n")
3278         ) lines;
3279         (Buffer.contents result)
3280     ), "<file> :\t\t\tdownload all the links contained in the file";
3281
3282   ]
3283
3284 (*************************************************************************)
3285 (*                                                                       *)
3286 (*                         Driver/Users                                  *)
3287 (*                                                                       *)
3288 (*************************************************************************)
3289
3290 let _ =
3291   register_commands "Driver/Users" [
3292
3293     "useradd", Arg_multiple (fun args o ->
3294         let group_convert g =
3295           try
3296             if String.lowercase g = "none" || g = "" then None
3297             else Some (user2_group_find g).group_name
3298           with Not_found -> None
3299         in
3300         let (user, pass, group, cdir, mail, mdl) =
3301           match args with
3302           | [user; pass; group; cdir; mail; mdl] ->
3303               user, pass, (group_convert group), cdir, mail, (try int_of_string mdl with _ -> 0)
3304           | [user; pass; group; cdir; mail] -> user, pass, (group_convert group), cdir, mail, 0
3305           | [user; pass; group; cdir] -> user, pass, (group_convert group), cdir, "", 0
3306           | [user; pass; group] -> user, pass, (group_convert group), "", "", 0
3307           | [user; pass] -> user, pass, Some admin_group_name, "", "", 0
3308           | _ -> failwith "wrong parameters"
3309         in
3310         if user2_is_admin o.conn_user.ui_user
3311           || o.conn_user.ui_user.user_name = user then
3312           if user2_user_exists user then
3313             begin
3314               user2_user_set_password (user2_user_find user) pass;
3315               print_command_result o (Printf.sprintf "Password of user %s changed" user)
3316             end
3317           else
3318             begin
3319               match group with
3320               | None -> user2_user_add user (Md4.string pass)
3321                           ~groups:[] ~default_group:None ~commit_dir:cdir ~mail:mail ~max_dl:mdl ();
3322                         print_command_result o (Printf.sprintf "User %s added" user)
3323               | Some g -> user2_user_add user (Md4.string pass)
3324                             ~groups:[g] ~default_group:group ~commit_dir:cdir ~mail:mail ~max_dl:mdl ();
3325                           print_command_result o (Printf.sprintf "User %s added, group %s" user g)
3326             end
3327         else
3328           print_command_result o "You are not allowed to add users";
3329         _s ""
3330     ), "<user> <passwd> [<group>] [<commit_dir>] [<mail>] [<max_downloads>]: add new mldonkey user/change user password";
3331
3332     "userdel", Arg_one (fun user o ->
3333         if user <> o.conn_user.ui_user.user_name then
3334           if user2_is_admin o.conn_user.ui_user then
3335             if user = (admin_user ()).user_name then
3336               print_command_result o "User 'admin' can not be removed"
3337             else
3338               try
3339                 let u = user2_user_find user in
3340                 let n = user2_num_user_dls u in
3341                 if n <> 0 then print_command_result o
3342                   (Printf.sprintf "User %s has %d downloads, can not delete" user n)
3343                 else
3344                   user2_user_remove user;
3345                   print_command_result o (Printf.sprintf "User %s removed" user)
3346               with
3347                 Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3348           else
3349             print_command_result o "You are not allowed to remove users"
3350         else
3351           print_command_result o "You can not remove yourself";
3352         _s ""
3353     ), "<user> :\t\t\tremove a mldonkey user";
3354
3355     "usergroupadd", Arg_two (fun user group o ->
3356         if user2_is_admin o.conn_user.ui_user then
3357           begin
3358             try
3359               let u = user2_user_find user in
3360                 begin
3361                   try
3362                     let g = user2_group_find group in
3363                     if List.mem g u.user_groups then
3364                       print_command_result o
3365                         (Printf.sprintf "User %s already member of group %s" u.user_name g.group_name)
3366                     else
3367                       begin
3368                         user2_user_add_group u g;
3369                         print_command_result o
3370                           (Printf.sprintf "Added group %s to user %s" g.group_name u.user_name)
3371                       end
3372                   with Not_found -> print_command_result o (Printf.sprintf "Group %s does not exist" group)
3373                 end
3374             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3375           end
3376         else
3377           print_command_result o "You are not allowed to add groups to a user";
3378         _s ""
3379     ), "<user> <group> :\t\tadd a group to a mldonkey user";
3380
3381     "usergroupdel", Arg_two (fun user group o ->
3382         if user2_is_admin o.conn_user.ui_user
3383           || o.conn_user.ui_user.user_name = user then
3384           begin
3385             try
3386               let u = user2_user_find user in
3387                 begin
3388                   try
3389                     let g = user2_group_find group in
3390                     if not (List.mem g u.user_groups) then
3391                       print_command_result o (Printf.sprintf "User %s is not member of group %s" user group)
3392                     else
3393                       if Some g = u.user_default_group then
3394                         print_command_result o (Printf.sprintf "Group %s is default group of user %s, can not remove. Use command userdgroup to change default_group." group user)
3395                       else
3396                         begin
3397                           let counter = ref 0 in
3398                           List.iter (fun f ->
3399                             if file_owner f = u && file_group f = Some g then
3400                               begin
3401                                 incr counter;
3402                                 set_file_group f u.user_default_group
3403                               end
3404                           ) !!files;
3405                           user2_user_remove_group (user2_user_find user) (user2_group_find group);
3406                           print_command_result o (Printf.sprintf "Removed group %s from user %s%s"
3407                             group user
3408                             (if !counter = 0 then "" else Printf.sprintf ", changed file_group of %d file%s to default_group %s"
3409                                !counter (Printf2.print_plural_s !counter) (user2_print_group u.user_default_group)))
3410                         end
3411                   with Not_found -> print_command_result o (Printf.sprintf "Group %s does not exist" group)
3412                 end
3413             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3414           end
3415
3416         else
3417           print_command_result o "You are not allowed to remove groups from a user";
3418         _s ""
3419     ), "<user> <group> :\t\tremove a group from a mldonkey user";
3420
3421     "userdgroup", Arg_two (fun user group o ->
3422         if user2_is_admin o.conn_user.ui_user
3423           || o.conn_user.ui_user.user_name = user then
3424           begin
3425             try
3426               let u = user2_user_find user in
3427                 begin
3428                   try
3429                     let g = if String.lowercase group = "none" then None else Some (user2_group_find group) in
3430                     let update_dgroup () =
3431                       match g with
3432                         None -> true
3433                       | Some g1 when List.mem g1 u.user_groups -> true
3434                       | _ -> false
3435                     in
3436                     if update_dgroup () then
3437                       begin
3438                         user2_user_set_default_group u g;
3439                         print_command_result o (Printf.sprintf "Changed default group of user %s to group %s" u.user_name (user2_print_user_default_group u))
3440                       end
3441                     else print_command_result o (Printf.sprintf "User %s is not member of group %s" u.user_name group)
3442                   with Not_found -> print_command_result o (Printf.sprintf "Group %s does not exist" group)
3443                 end
3444             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3445           end
3446         else
3447           print_command_result o "You are not allowed to change default group";
3448         _s ""
3449     ), "<user> <group|None> :\tchange user default group";
3450
3451     "passwd", Arg_one (fun passwd o ->
3452         begin
3453           try
3454             let u = user2_user_find o.conn_user.ui_user.user_name in
3455             user2_user_set_password u passwd;
3456             print_command_result o (Printf.sprintf "Password of user %s changed" u.user_name)
3457           with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" o.conn_user.ui_user.user_name)
3458         end;
3459         _s ""
3460     ), "<passwd> :\t\t\tchange own password";
3461
3462     "usermail", Arg_two (fun user mail o ->
3463         if user2_is_admin o.conn_user.ui_user
3464           || o.conn_user.ui_user.user_name = user then
3465           begin
3466             try
3467               let u = user2_user_find user in
3468               user2_user_set_mail u mail;
3469               print_command_result o (Printf.sprintf "User %s has new mail %s" user mail)
3470             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3471           end
3472         else print_command_result o "You are not allowed to change mail addresses";
3473         _s ""
3474     ), "<user> <mail> :\t\tchange user mail address";
3475
3476     "userdls", Arg_two (fun user dls o ->
3477         if user2_is_admin o.conn_user.ui_user then
3478           begin
3479             try
3480               let u = user2_user_find user in
3481               user2_user_set_dls u (int_of_string dls);
3482               print_command_result o (Printf.sprintf "User %s has now %s downloads allowed" user (user2_print_user_dls (user2_user_find user)))
3483             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3484           end
3485         else print_command_result o "You are not allowed to change this value";
3486         _s ""
3487     ), "<user> <num> :\t\t\tchange number of allowed concurrent downloads";
3488
3489     "usercommit", Arg_two (fun user dir o ->
3490         if user2_is_admin o.conn_user.ui_user
3491           || o.conn_user.ui_user.user_name = user then
3492           begin
3493             try
3494               let u = user2_user_find user in
3495               user2_user_set_commit_dir u dir;
3496               print_command_result o (Printf.sprintf "User %s has new commit dir %s" u.user_name u.user_commit_dir)
3497             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3498           end
3499         else print_command_result o "You are not allowed to change this value";
3500         _s ""
3501     ), "<user> <dir> :\t\tchange user specific commit directory";
3502
3503     "groupadd", Arg_two (fun group admin o ->
3504         let g_admin =
3505           try
3506             bool_of_string admin
3507           with _ -> false
3508         in
3509         if user2_is_admin o.conn_user.ui_user then
3510           if user2_group_exists group then
3511             print_command_result o (Printf.sprintf "Group %s already exists" group)
3512           else
3513             begin
3514               user2_group_add group g_admin;
3515               print_command_result o (Printf.sprintf "Group %s added" group)
3516             end
3517         else
3518           print_command_result o "You are not allowed to add a group";
3519         _s ""
3520     ), "<group> <admin: true|false> :\tadd new mldonkey group";
3521
3522     "groupdel", Arg_one (fun group o ->
3523         if user2_is_admin o.conn_user.ui_user then
3524           begin
3525             try
3526               let g = user2_group_find group in
3527               let g_dls = user2_num_group_dls g in
3528               let g_mem = user2_num_group_members g in
3529               if g_dls <> 0 then
3530                 print_command_result o
3531                   (Printf.sprintf "Can not remove group %s, it has %d download%s"
3532                     group g_dls (Printf2.print_plural_s g_dls))
3533               else
3534                 if g_mem <> 0 then
3535                   print_command_result o
3536                     (Printf.sprintf "Can not remove group %s, it has %d member%s"
3537                       group g_mem (Printf2.print_plural_s g_mem))
3538                 else
3539                   if g = admin_group () then
3540                     print_command_result o (Printf.sprintf "Can not remove system group %s" group)
3541                   else
3542                     begin
3543                       user2_group_remove g;
3544                       print_command_result o (Printf.sprintf "Removed group %s" group)
3545                     end
3546             with Not_found -> print_command_result o (Printf.sprintf "Group %s does not exist" group)
3547           end
3548         else
3549           print_command_result o "You are not allowed to remove users";
3550           _s ""
3551     ), "<group> :\t\t\tremove an unused mldonkey group";
3552
3553     "groupadmin", Arg_two (fun group admin o ->
3554         if user2_is_admin o.conn_user.ui_user then
3555           begin
3556             try
3557               let g = user2_group_find group in
3558               if g = admin_group () then
3559                 print_command_result o (Printf.sprintf "Can not change state of system group %s" group)
3560               else
3561                 begin
3562                   user2_group_admin g (bool_of_string admin);
3563                   print_command_result o (Printf.sprintf "Changed admin status of group %s to %b" g.group_name g.group_admin)
3564                 end
3565             with Not_found -> print_command_result o (Printf.sprintf "Group %s does not exist" group)
3566           end
3567         else
3568           print_command_result o "You are not allowed to change group admin status";
3569         _s ""
3570     ), "<group> <true|false> :\tchange group admin status";
3571
3572     "users", Arg_none (fun o ->
3573         let buf = o.conn_buf in
3574         if user2_is_admin o.conn_user.ui_user then begin
3575
3576         if use_html_mods o then begin
3577             Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
3578 \\<tr\\>\\<td\\>
3579 \\<table cellspacing=0 cellpadding=0  width=100%%\\>\\<tr\\>
3580 \\<td class=downloaded width=100%%\\>\\</td\\>
3581 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript: {
3582                    var getdir = prompt('Input: <user> <pass>','user pass <group> <commit_dir>')
3583                    var reg = new RegExp (' ', 'gi') ;
3584                    var outstr = getdir.replace(reg, '+');
3585                    parent.fstatus.location.href='submit?q=useradd+' + outstr;
3586                    setTimeout('window.location.reload()',1000);
3587                     }\\\"\\>Add user\\</a\\>
3588 \\</td\\>\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\<tr\\>\\<td\\>";
3589
3590             html_mods_table_header buf "sharesTable" "shares" [
3591               ( Str, "srh ac", "Click to remove user", "Remove" ) ;
3592               ( Str, "srh", "Username", "User" ) ;
3593               ( Str, "srh ac", "Only member of admin groups have admin rights", "Admin" ) ;
3594               ( Str, "srh", "Member of groups", "Groups" ) ;
3595               ( Str, "srh", "Default group", "Default group" ) ;
3596               ( Str, "srh", "Mail address", "Email" ) ;
3597               ( Str, "srh", "Commit dir", "Commit dir" ) ;
3598               ( Num, "srh ar", "Download quota", "Max DLs" ) ;
3599               ( Num, "srh ar", "Download count", "DLs" ) ];
3600
3601             html_mods_cntr_init ();
3602             user2_users_iter (fun user ->
3603                 let u_dls = user2_num_user_dls user in
3604                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>"
3605                 (html_mods_cntr ());
3606                 if user <> (admin_user ()) && (u_dls = 0) then Printf.bprintf buf
3607 "\\<td title=\\\"Click to remove user\\\"
3608 onMouseOver=\\\"mOvr(this);\\\"
3609 onMouseOut=\\\"mOut(this);\\\"
3610 onClick=\\\'javascript:{
3611 parent.fstatus.location.href=\\\"submit?q=userdel+\\\\\\\"%s\\\\\\\"\\\";
3612 setTimeout(\\\"window.location.reload()\\\",1000);}'
3613 class=\\\"srb\\\"\\>Remove\\</td\\>" user.user_name
3614                 else Printf.bprintf buf
3615 "\\<td title=\\\"%s\\\"
3616 class=\\\"srb\\\"\\>------\\</td\\>"
3617   (if user.user_name = (admin_user ()).user_name then "Admin user can not be removed" else
3618      if u_dls <> 0 then Printf.sprintf "User has %d download%s" u_dls
3619      (Printf2.print_plural_s u_dls) else "");
3620                 html_mods_td buf [
3621                   ("", "sr", user.user_name);
3622                   ("", "sr ac", Printf.sprintf "%b" (user2_is_admin user));
3623                   ("Click to remove group", "sr",
3624                       let buf1 = Buffer.create 100 in
3625                       user2_user_groups_iter user (fun group ->
3626                         if user2_default_group_matches_group user.user_default_group group then
3627                           Printf.bprintf buf1 "%s " group.group_name
3628                         else
3629                           Printf.bprintf buf1
3630 "\\<a onMouseOver=\\\"mOvr(this);\\\"
3631 onMouseOut=\\\"mOut(this);\\\"
3632 onClick=\\\'javascript:{
3633 parent.fstatus.location.href=\\\"submit?q=usergroupdel+\\\\\\\"%s\\\\\\\"+\\\\\\\"%s\\\\\\\"\\\";
3634 setTimeout(\\\"window.location.reload()\\\",1000);}'
3635 class=\\\"srb\\\"\\>%s\\</a\\> " user.user_name group.group_name group.group_name
3636                       );
3637                       Buffer.contents buf1);
3638                   ("", "sr", user2_print_user_default_group user);
3639                   ("", "sr", user.user_mail);
3640                   ("", "sr", user.user_commit_dir);
3641                   ("", "sr ar", user2_print_user_dls user);
3642                   ("", "sr ar", string_of_int u_dls)];
3643             );
3644             Printf.bprintf buf "\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
3645             print_option_help o userlist;
3646             Printf.bprintf buf "\\<P\\>";
3647
3648             Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
3649 \\<tr\\>\\<td\\>
3650 \\<table cellspacing=0 cellpadding=0  width=100%%\\>\\<tr\\>
3651 \\<td class=downloaded width=100%%\\>\\</td\\>
3652 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript: {
3653                    var getdir = prompt('Input: <group> <admin: true|false>','group true')
3654                    var reg = new RegExp (' ', 'gi') ;
3655                    var outstr = getdir.replace(reg, '+');
3656                    parent.fstatus.location.href='submit?q=groupadd+' + outstr;
3657                    setTimeout('window.location.reload()',1000);
3658                     }\\\"\\>Add group\\</a\\>
3659 \\</td\\>\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\<tr\\>\\<td\\>";
3660
3661             html_mods_table_header buf "sharesTable" "shares" [
3662               ( Str, "srh ac", "Click to remove group", "Remove" );
3663               ( Str, "srh", "Groupname", "Group" );
3664               ( Str, "srh ac", "Click to change status", "Admin" );
3665               ( Num, "srh ar", "Member count", "Mem" );
3666               ( Num, "srh ar", "Download count", "DLs" ) ];
3667
3668             html_mods_cntr_init ();
3669             user2_groups_iter (fun group ->
3670                 let g_dls = user2_num_group_dls group in
3671                 let g_mem = user2_num_group_members group in
3672                 let is_sys_group = group = admin_group () in
3673                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
3674                 if g_dls = 0 && g_mem = 0 && not is_sys_group then Printf.bprintf buf
3675 "\\<td title=\\\"Click to remove group\\\"
3676 onMouseOver=\\\"mOvr(this);\\\" onMouseOut=\\\"mOut(this);\\\" onClick=\\\'javascript:{
3677 parent.fstatus.location.href=\\\"submit?q=groupdel+\\\\\\\"%s\\\\\\\"\\\";
3678 setTimeout(\\\"window.location.reload()\\\",1000);}'
3679 class=\\\"srb\\\"\\>Remove\\</td\\>" group.group_name
3680                 else
3681                     Printf.bprintf buf "\\<td title=\\\"%s\\\" class=\\\"srb\\\"\\>------\\</td\\>"
3682                       (if g_dls <> 0 then Printf.sprintf "Group is assigned to %d download%s"
3683                                             g_dls (Printf2.print_plural_s g_dls) else
3684                         if g_mem <> 0 then Printf.sprintf "Group has %d member%s"
3685                                             g_mem (Printf2.print_plural_s g_mem) else
3686                         if is_sys_group then "System group can not be removed" else "");
3687
3688                 html_mods_td buf [("", "sr", group.group_name)];
3689
3690                 if is_sys_group then
3691                   html_mods_td buf [("System group, can not change state", "sr ac", Printf.sprintf "%b" group.group_admin)]
3692                 else Printf.bprintf buf
3693 "\\<td title=\\\"Change admin status\\\"
3694 onMouseOver=\\\"mOvr(this);\\\" onMouseOut=\\\"mOut(this);\\\" onClick=\\\'javascript:{
3695 parent.fstatus.location.href=\\\"submit?q=groupadmin+\\\\\\\"%s\\\\\\\"+\\\\\\\"%s\\\\\\\"\\\";
3696 setTimeout(\\\"window.location.reload()\\\",1000);}'
3697 class=\\\"sr ac\\\"\\>%s\\</td\\>"
3698   group.group_name
3699   (if group.group_admin then "false" else "true")
3700   (if group.group_admin then "true" else "false");
3701
3702                 html_mods_td buf [
3703                   ("", "sr ar", Printf.sprintf "%d" (user2_num_group_members group));
3704                   ("", "sr ar", Printf.sprintf "%d" g_dls);
3705                   ]);
3706
3707             Printf.bprintf buf "\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
3708             print_option_help o grouplist;
3709             Printf.bprintf buf "\\<P\\>";
3710
3711             Buffer.add_string buf "\\<div class=\\\"cs\\\"\\>";
3712             html_mods_table_header buf "helpTable" "results" [];
3713             Buffer.add_string buf "\\<tr\\>";
3714             html_mods_td buf [
3715               ("", "srh", "");
3716               ("", "srh", "Commands to manipulate user data");
3717               ("", "srh", ""); ];
3718             Buffer.add_string buf "\\</tr\\>";
3719             html_mods_cntr_init ();
3720             let list = Hashtbl2.to_list2 commands_by_kind in
3721             let list = List.sort (fun (s1,_) (s2,_) -> compare s1 s2) list in
3722             List.iter (fun (s,list) ->
3723               if s = "Driver/Users" then
3724               let list = List.sort (fun (s1,_) (s2,_) -> compare s1 s2) !list in
3725               List.iter (fun (cmd, help) ->
3726                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
3727                 html_mods_td buf [
3728                   ("", "sr", "\\<a href=\\\"submit?q=" ^ cmd ^
3729                     "\\\"\\>" ^ cmd ^ "\\</a\\>");
3730                   ("", "srw", Str.global_replace (Str.regexp "\n") "\\<br\\>" help);
3731                   ("", "sr", "\\<a href=\\\"http://mldonkey.sourceforge.net/" ^ (String2.upp_initial cmd) ^
3732                     "\\\"\\>wiki\\</a\\>"); ];
3733                 Printf.bprintf buf "\\</tr\\>\n"
3734               ) list
3735           ) list
3736           end
3737         else begin
3738           let list = ref [] in
3739           user2_users_iter (fun user -> list := [|
3740             user.user_name;
3741             Printf.sprintf "%b" (user2_is_admin user);
3742             (user2_print_user_groups " " user);
3743             (user2_print_user_default_group user);
3744             user.user_mail;
3745             user.user_commit_dir;
3746             (user2_print_user_dls user);
3747             (string_of_int (user2_num_user_dls user));
3748           |] :: !list );
3749           print_table_text buf
3750           [|
3751             Align_Left; Align_Left; Align_Left; Align_Left; Align_Left; Align_Left; Align_Right; Align_Right |]
3752           [|
3753             "User";
3754             "Admin";
3755             "Groups";
3756             "Dgroup";
3757             "Email";
3758             "Commit dir";
3759             "Max dls";
3760             "Dls";
3761           |] (List.rev !list);
3762           Printf.bprintf buf "\n";
3763           let list = ref [] in
3764           user2_groups_iter (fun group -> list := [|
3765             group.group_name;
3766             Printf.sprintf "%b" group.group_admin;
3767             (string_of_int (user2_num_group_members group));
3768             (string_of_int (user2_num_group_dls group));
3769           |] :: !list );
3770           print_table_text buf
3771           [|
3772             Align_Left; Align_Left; Align_Right; Align_Right |]
3773           [|
3774             "Group";
3775             "Admin";
3776             "Members";
3777             "Downloads";
3778           |] (List.rev !list);
3779           end
3780         end else print_command_result o "You are not allowed to list users";
3781           _s ""
3782     ), ":\t\t\t\t\tprint users";
3783
3784     "whoami", Arg_none (fun o ->
3785         print_command_result o o.conn_user.ui_user.user_name;
3786         _s ""
3787     ), ":\t\t\t\tprint logged-in user name";
3788
3789     "groups", Arg_none (fun o ->
3790         print_command_result o (user2_print_user_groups " " o.conn_user.ui_user);
3791         _s ""
3792     ), ":\t\t\t\tprint groups of logged-in user";
3793
3794     "dgroup", Arg_none (fun o ->
3795         print_command_result o (user2_print_user_default_group o.conn_user.ui_user);
3796         _s ""
3797     ), ":\t\t\t\tprint default group of logged-in user";
3798
3799     "chgrp", Arg_two (fun group filenum o ->
3800         let num = int_of_string filenum in
3801         begin try
3802           let file = file_find num in
3803           if String.lowercase group = "none" then
3804             begin
3805               if user2_allow_file_admin file o.conn_user.ui_user then
3806                 begin
3807                   set_file_group file None;
3808                   print_command_result o (Printf.sprintf (_b "Changed group of download %d to %s") num group)
3809                 end
3810               else
3811                 print_command_result o (Printf.sprintf (_b "You are not allowed to change group of download %d to %s") num group)
3812             end
3813           else
3814             begin
3815               try
3816                 let g = user2_group_find group in
3817                 if user2_allow_file_admin file o.conn_user.ui_user &&
3818                    List.mem g (file_owner file).user_groups then
3819                   begin
3820                     set_file_group file (Some g);
3821                     print_command_result o (Printf.sprintf (_b "Changed group of download %d to %s") num group)
3822                   end
3823                 else
3824                   print_command_result o (Printf.sprintf (_b "You are not allowed to change group of download %d to %s") num group)
3825               with Not_found -> print_command_result o (Printf.sprintf (_b "Group %s not found") group)
3826             end
3827         with Not_found -> print_command_result o (Printf.sprintf (_b "File %d not found") num)
3828         end;
3829         _s ""
3830     ), "<group> <num> :\t\t\tchange group of download <num> to <group>, use group = none for private file";
3831
3832     "chown", Arg_two (fun user filenum o ->
3833         let num = int_of_string filenum in
3834         begin
3835           try
3836             let file = file_find num in
3837             begin
3838               try
3839                 let u = user2_user_find user in
3840                 if user2_is_admin o.conn_user.ui_user then
3841                   begin
3842                     set_file_owner file u;
3843                     match file_group file with
3844                     | None ->
3845                         print_command_result o (Printf.sprintf (_b "Changed owner of download %d to %s") num user)
3846                     | Some g ->
3847                         if List.mem g u.user_groups then
3848                           print_command_result o (Printf.sprintf (_b "Changed owner of download %d to %s") num user)
3849                         else
3850                           begin
3851                             set_file_group file u.user_default_group;
3852                             print_command_result o (Printf.sprintf
3853                               (_b "owner %s is not member of file_group %s, changing file_group to user_default_group %s")
3854                               user g.group_name (user2_print_user_default_group u))
3855                           end
3856                   end
3857                 else
3858                   print_command_result o (Printf.sprintf (_b "You are not allowed to change owner of download %d to %s") num user)
3859               with Not_found -> print_command_result o (Printf.sprintf (_b "User %s not found") user)
3860             end
3861           with Not_found -> print_command_result o (Printf.sprintf (_b "File %d not found") num)
3862         end;
3863         _s ""
3864     ), "<user> <num> :\t\t\tchange owner of download <num> to <user>";
3865
3866   ]
3867
3868
3869 (*************************************************************************)
3870 (*                                                                       *)
3871 (*                         Driver/Xpert                                  *)
3872 (*                                                                       *)
3873 (*************************************************************************)
3874
3875 let _ =
3876   register_commands "Driver/Xpert"
3877     [
3878
3879 (*
3880       "debug_set_download_prio", Arg_two
3881         (fun arg priostring  o ->
3882            let num = int_of_string arg in
3883            let file = file_find num in
3884              CommonSwarming.set_swarmer_chunk_priorities file priostring;
3885              "set prio"
3886
3887         ), ":\t\t\t\t\tset block download priorities for a file. 0=never download, >0=download largest prio first";
3888 *)
3889
3890       "debug_get_download_prio", Arg_one
3891         (fun arg o ->
3892            let buf = o.conn_buf in
3893            let pr fmt = Printf.bprintf buf fmt in
3894            let num = int_of_string arg in
3895            let file = file_find num in
3896            let swarmer = CommonSwarming.file_swarmer file in
3897            let prio = CommonSwarming.get_swarmer_block_priorities swarmer in
3898            let downloaded = CommonSwarming.get_swarmer_block_verified swarmer in
3899            pr "\\<code\\>";
3900            pr "priorities: ";
3901            String.iter (fun c ->
3902              let c = max 0 (min 9 (Char.code c)) in
3903              let c = Char.chr (c + Char.code '0') in
3904              Buffer.add_char buf c) prio;
3905            pr "\n";
3906            pr "downloaded: %s\n" (VB.to_string downloaded);
3907
3908            Unix32.subfile_tree_map (file_fd file)
3909            begin fun fname start length current_length ->
3910              let stop = if length <> 0L then (start ++ length -- 1L) else start in
3911              let blockstart = try CommonSwarming.compute_block_num swarmer start with _ -> 0 in
3912              let blockend = try CommonSwarming.compute_block_num swarmer stop with _ -> 0 in
3913              pr "sf:%5Ld ef:%5Ld l:%Ld cl:%Ld > sc:%5d ec:%5d filename:%-30s \n"
3914                       start
3915                       stop
3916                       length
3917                       current_length
3918                       blockstart
3919                       blockend
3920                       fname;
3921              (*make a chunk downloaded status string for a subfile*)
3922              (try
3923                 for i = blockstart to blockend do
3924                   Buffer.add_char buf (VB.state_to_char (VB.get downloaded i));
3925                 done;
3926                 pr "\n";
3927               with _ -> ())
3928            end;
3929            pr "\\</code\\>";
3930            "";
3931     ), ":\t\t\t\t\tget file block priorities for a file, and show subfile completion status";
3932
3933     "set_subfile_prio", Arg_multiple
3934       (fun args o ->
3935         match args with
3936         | filenum :: priochar :: subfilestart :: q ->
3937             let filenum = int_of_string filenum in
3938             let priochar = int_of_string priochar in
3939             let subfilestart = int_of_string subfilestart in
3940             let subfileend =
3941               match q with
3942               | subfileend :: _ -> int_of_string subfileend
3943               | [] -> subfilestart
3944             in
3945             let file = file_find filenum in
3946             let swarmer = CommonSwarming.file_swarmer file in
3947 (*
3948             let priostring =
3949               CommonSwarming.get_swarmer_chunk_priorities file in
3950 *)
3951             let subfile1 = Unix32.find_file_index (file_fd file) subfilestart in
3952             let subfile2 = Unix32.find_file_index (file_fd file) subfileend in
3953             let subfile_pos = function (_,y,_) -> y in
3954             let subfile_len = function (_,_,y) -> y in
3955             let start = subfile_pos subfile1 in
3956             let stop =
3957               subfile_pos subfile2 ++ subfile_len subfile2
3958 (*                 -- if subfile_len subfile2 > 0L then 1L else 0L  *)
3959             in
3960 (*
3961             Printf.bprintf buf "file %s\nstart %Ld stop %Ld prio %u\n"
3962               swarmer.CommonSwarming.s_filename start stop priochar;
3963 *)
3964             CommonSwarming.swarmer_set_interval swarmer (start,stop,priochar);
3965             (* show file *)
3966 (*             execute_command !CommonNetwork.network_commands o "vd" [string_of_int filenum]; *)
3967             string_of_int priochar
3968         | _ -> bad_number_of_args "" ""
3969     ), "set_subfile_prio <download id> <prio> <1st subfile (0-based)> <optional last subfile>";
3970
3971     "reload_messages", Arg_none (fun o ->
3972         CommonMessages.load_message_file ();
3973         "\\<script type=\\\"text/javascript\\\"\\>top.window.location.reload();\\</script\\>"
3974     ), ":\t\t\treload messages file";
3975
3976     "log", Arg_none (fun o ->
3977         let buf = o.conn_buf in
3978         log_to_buffer buf;
3979         _s "------------- End of log"
3980     ), ":\t\t\t\t\tdump current log state to console";
3981
3982     "ansi", Arg_one (fun arg o ->
3983         let b = bool_of_string arg in
3984         if b then begin
3985             o.conn_output <- ANSI;
3986           end else
3987           o.conn_output <- TEXT;
3988         _s "$rdone$n"
3989     ), ":\t\t\t\t\ttoggle ansi terminal (devel)";
3990
3991     "term", Arg_two (fun w h o ->
3992         let w = int_of_string w in
3993         let h = int_of_string h in
3994         o.conn_width <- w;
3995         o.conn_height <- h;
3996         "set"),
3997     "<width> <height> :\t\t\tset terminal width and height (devel)";
3998
3999     "stdout", Arg_one (fun arg o ->
4000         if (bool_of_string arg) then
4001           begin
4002             lprintf_nl "Enable logging to stdout...";
4003             log_to_file stdout;
4004             lprintf_nl "Logging to stdout..."
4005           end
4006         else
4007           begin
4008             lprintf_nl "Disable logging to stdout...";
4009             close_log ();
4010             if !!log_file <> "" then
4011               begin
4012                 let oc = open_out_gen [Open_creat; Open_wronly; Open_append] 0o644 !!log_file in
4013                   log_to_file oc;
4014                   lprintf_nl "Reopened %s" !!log_file
4015               end
4016           end;
4017         Printf.sprintf (_b "log to stdout %s")
4018         (if (bool_of_string arg) then _s "enabled" else _s "disabled")
4019     ), "<true|false> :\t\t\treactivate log to stdout";
4020
4021     "debug_client", Arg_multiple (fun args o ->
4022         List.iter (fun arg ->
4023             let num = int_of_string arg in
4024             debug_clients := Intset.add num !debug_clients;
4025             (try let c = client_find num in client_debug c true with _ -> ())
4026         ) args;
4027         _s "done"
4028     ), "<client nums> :\t\tdebug message in communications with these clients";
4029
4030     "debug_file", Arg_multiple (fun args o ->
4031         List.iter (fun arg ->
4032             let num = int_of_string arg in
4033             let file = file_find num in
4034             Printf.bprintf o.conn_buf
4035               "File %d:\n%s" num
4036               (file_debug file);
4037         ) args;
4038         _s "done"
4039     ), "<client nums> :\t\tdebug file state";
4040
4041     "clear_debug", Arg_none (fun o ->
4042
4043         Intset.iter (fun num ->
4044             try let c = client_find num in
4045               client_debug c false with _ -> ()
4046         ) !debug_clients;
4047         debug_clients := Intset.empty;
4048         _s "done"
4049     ), ":\t\t\t\tclear the table of clients being debugged";
4050
4051     "merge", Arg_two (fun f1 f2 o ->
4052         let file1 = file_find (int_of_string f1) in
4053         let file2 = file_find (int_of_string f2) in
4054         CommonSwarming.merge file1 file2;
4055         "The two files are now merged"
4056     ), "<num1> <num2> :\t\t\ttry to swarm downloads from file <num2> (secondary) to file <num1> (primary)";
4057
4058     "open_log", Arg_none (fun o ->
4059         if !!log_file <> "" then
4060           begin
4061             let log = !!log_file in
4062               CommonOptions.log_file =:= log;
4063             Printf.sprintf "opened logfile %s" !!log_file
4064           end
4065         else
4066           Printf.sprintf "works only if log_file is set"
4067     ), ":\t\t\t\tenable logging to file";
4068
4069     "close_log", Arg_none (fun o ->
4070   lprintf_nl "Stopped logging...";
4071         close_log ();
4072         _s "log stopped"
4073     ), ":\t\t\t\tclose logging to file";
4074
4075      "clear_log", Arg_none (fun o ->
4076         if !!log_file <> "" then
4077           begin
4078             close_log ();
4079             let oc = open_out_gen [Open_creat; Open_wronly; Open_trunc] 0o644 !!log_file in
4080               log_to_file oc;
4081               lprintf_nl "Cleared %s" !!log_file;
4082               Printf.sprintf "Logfile %s cleared" !!log_file
4083           end
4084         else
4085           Printf.sprintf "works only if log_file is set"
4086      ), ":\t\t\t\tclear log_file";
4087
4088     "html_mods", Arg_none (fun o ->
4089         if !!html_mods then
4090           begin
4091             html_mods =:= false;
4092             commands_frame_height =:= 140;
4093           end
4094         else
4095           begin
4096             html_mods =:= true;
4097             html_mods_style =:= 0;
4098             commands_frame_height =:= CommonMessages.styles.(!!html_mods_style).frame_height;
4099             CommonMessages.colour_changer() ;
4100           end;
4101
4102         "\\<script type='text/javascript'\\>top.window.location.replace('/');\\</script\\>"
4103     ), ":\t\t\t\ttoggle html_mods";
4104
4105
4106     "html_mods_style", Arg_multiple (fun args o ->
4107         let buf = o.conn_buf in
4108         if args = [] then begin
4109             Array.iteri (fun i style ->
4110                 Printf.bprintf buf "%d: %s\n" i style.style_name;
4111             ) CommonMessages.styles;
4112             ""
4113           end
4114         else begin
4115             html_mods =:= true;
4116             html_mods_theme =:= "";
4117             let num = int_of_string (List.hd args) in
4118
4119             html_mods_style =:=
4120               if num >= 0 && num < Array.length CommonMessages.styles then
4121                 num else 0;
4122             commands_frame_height =:= CommonMessages.styles.(!!html_mods_style).frame_height;
4123             CommonMessages.colour_changer ();
4124             "\\<script type='text/javascript'\\>top.window.location.replace('/');\\</script\\>"
4125           end
4126
4127     ), ":\t\t\tselect html_mods_style <#>";
4128
4129     "rss", Arg_none (fun o ->
4130         let buf = o.conn_buf in
4131         let module CW = CommonWeb in
4132         Hashtbl.iter (fun url feed ->
4133             let r = feed.CW.rss_value in
4134             if o.conn_output = HTML then begin
4135                 Printf.bprintf buf "\\</pre\\>\\<div class=\\\"cs\\\"\\>";
4136                 html_mods_table_header buf "rssTable" "results" [
4137                    ( Str, "sr", "Content", "Content" ) ;
4138                    ( Str, "sr", "MLDonkey Download", "Download" ) ];
4139                 Printf.bprintf buf "\\<tr\\>";
4140                 html_mods_td buf [
4141                   (r.Rss.ch_title ^ " : " ^ url ^ (Printf.sprintf ", loaded %d hours ago" (((last_time ()) - feed.CW.rss_date) / 3600)), "srh", r.Rss.ch_title);
4142                   ("", "srh", "") ];
4143                 Printf.bprintf buf "\\</tr\\>"
4144               end
4145             else begin
4146                 Printf.bprintf buf "%s:\n" url;
4147                 Printf.bprintf buf "   loaded %d hours ago\n" (feed.CW.rss_date / 3600);
4148                 Printf.bprintf buf "   title: %s\n" r.Rss.ch_title;
4149             end;
4150             html_mods_cntr_init ();
4151             List.iter (fun item ->
4152                 match item.Rss.item_title, item.Rss.item_link with
4153                   None, _
4154                 | _, None -> ()
4155                 | Some title, Some link ->
4156                   if o.conn_output = HTML then begin
4157                       Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
4158                       html_mods_td buf [
4159                         (title, "sr", "\\<a href=\\\"" ^ link ^ "\\\"\\>" ^ title ^ "\\</a\\>");
4160                         (title, "sr",
4161                           "\\<a href=\\\"submit?q=dllink+"
4162                           ^ (Url.encode link)
4163                           ^ "\\\"\\ title=\\\"\\dllink\\\"\\>dllink\\</a\\>"
4164                           ^
4165                           " \\<a href=\\\"submit?q=http+"
4166                           ^ (Url.encode link)
4167                           ^ "\\\"\\ title=\\\"\\http\\\"\\>http\\</a\\>"
4168                           ^
4169                           " \\<a href=\\\"submit?q=startbt+"
4170                           ^ (Url.encode link)
4171                           ^ "\\\"\\ title=\\\"\\startbt\\\"\\>startbt\\</a\\>"
4172                         )
4173                       ];
4174                       Printf.bprintf buf "\\</tr\\>"
4175                     end
4176                   else begin
4177                       Printf.bprintf buf "     %s\n" title;
4178                       Printf.bprintf buf "       > %s\n" link
4179                     end
4180             ) r.Rss.ch_items;
4181             if o.conn_output = HTML then
4182                 Printf.bprintf buf "\\</table\\>\\</div\\>\\</div\\>\\<pre\\>";
4183         ) CW.rss_feeds;
4184         ""
4185
4186
4187     ), ":\t\t\t\t\tprint RSS feeds";
4188
4189     "html_theme", Arg_multiple (fun args o ->
4190         let buf = o.conn_buf in
4191         if args = [] then begin
4192             Printf.bprintf buf "Usage: html_theme <theme name>\n";
4193             Printf.bprintf buf "To use internal theme: html_theme \\\"\\\"\n";
4194             Printf.bprintf buf "Current theme: %s\n\n" !!html_mods_theme;
4195             Printf.bprintf buf "Available themes:\n";
4196             if Sys.file_exists html_themes_dir then begin
4197                 let list = Unix2.list_directory html_themes_dir in
4198                 List.iter (fun d ->
4199                     if Unix2.is_directory (Filename.concat html_themes_dir d) then
4200                       Printf.bprintf buf "%s\n" d;
4201                 ) (List.sort (fun d1 d2 -> compare d1 d2) list);
4202               end;
4203             ""
4204           end
4205         else begin
4206 (* html_mods =:= true; *)
4207             html_mods_theme =:= List.hd args;
4208             "\\<script type=\\\"text/javascript\\\"\\>top.window.location.reload();\\</script\\>"
4209           end
4210
4211     ), "<theme> :\t\t\tselect html_theme";
4212
4213     "mem_stats", Arg_multiple (fun args o ->
4214         let buf = o.conn_buf in
4215         let level = match args with
4216           [] -> 0
4217         | n :: _ -> int_of_string n in
4218         Heap.print_memstats level buf (use_html_mods o);
4219         ""
4220     ), ":\t\t\t\tprint memory stats [<verbosity #num>]";
4221
4222     "close_all_sockets", Arg_none (fun o ->
4223         BasicSocket.close_all ();
4224         _s "All sockets closed"
4225     ), ":\t\t\tclose all opened sockets";
4226
4227     "use_poll", Arg_one (fun arg o ->
4228         let b = bool_of_string arg in
4229         BasicSocket.use_poll b;
4230         Printf.sprintf "poll: %s" (string_of_bool b)
4231     ), "<bool> :\t\t\tuse poll instead of select";
4232
4233     "close_fds", Arg_none (fun o ->
4234         Unix32.close_all ();
4235         let buf = o.conn_buf in
4236         if o.conn_output = HTML then
4237           html_mods_table_one_row buf "serversTable" "servers" [
4238             ("", "srh", "All files closed"); ]
4239         else
4240           Printf.bprintf buf "All files closed";
4241         ""
4242     ), ":\t\t\t\tclose all files (use to free space on disk after remove)";
4243
4244     "debug_socks", Arg_none (fun o ->
4245         BasicSocket.print_sockets o.conn_buf;
4246         _s "done"
4247     ), ":\t\t\t\tfor debugging only";
4248
4249     "block_list", Arg_none (fun o ->
4250       let buf = o.conn_buf in
4251       if o.conn_output = HTML then
4252         List.iter (fun (tablename, l) ->
4253           html_mods_cntr_init ();
4254           html_mods_table_header buf ~total:"1" tablename "servers" [
4255             ( Str, "srh ac br", "Description (" ^ tablename ^ ")", "Description (" ^ tablename ^ ")") ;
4256             ( Num, "srh ar", "Hits", "Hits") ;
4257             ( Str, "srh ac", "Range", "Range")];
4258           let nhits =
4259             Ip_set.bl_fold_left (fun nhits br ->
4260                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>"
4261                   (html_mods_cntr ());
4262                 html_mods_td buf [
4263                   ("Description", "sr br", br.Ip_set.blocking_description);
4264                   ("Hits", "sr ar br", string_of_int br.Ip_set.blocking_hits);
4265                   ("Range", "sr", Printf.sprintf "%s - %s"
4266                     (Ip.to_string br.Ip_set.blocking_begin)
4267                     (Ip.to_string br.Ip_set.blocking_end))];
4268                 Printf.bprintf buf "\\</tr\\>";
4269               (nhits + br.Ip_set.blocking_hits)
4270             ) 0 l
4271           and nranges = Ip_set.bl_length l in
4272           Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>"
4273             (html_mods_cntr ());
4274           if nranges > 0 then
4275           html_mods_td buf [
4276             ("Total ranges", "sr br total", ("Total ranges " ^ string_of_int nranges));
4277             ("Hits", "sr ar br total", Printf.sprintf "%s" (string_of_int nhits));
4278             ("", "sr br total", "")]
4279           else begin
4280           html_mods_td buf [
4281             ("no " ^ tablename ^ " loaded", "sr", "no " ^ tablename ^ " loaded");
4282             ("", "sr", "");
4283             ("", "sr", "")];
4284           end;
4285           Printf.bprintf buf "\\</tr\\>\\</table\\>\\<P\\>";
4286         ) [
4287           ("Web blocking list", !CommonBlocking.web_ip_blocking_list);
4288           ("Local blocking list", !CommonBlocking.ip_blocking_list)]
4289       else begin
4290         Printf.bprintf buf "Web blocking list\n";
4291         Ip_set.print_list buf !CommonBlocking.web_ip_blocking_list;
4292         Printf.bprintf buf "Local blocking list\n";
4293         Ip_set.print_list buf !CommonBlocking.ip_blocking_list;
4294       end;
4295       _s ""
4296     ), ":\t\t\t\tdisplay the list of blocked IP ranges that were hit";
4297
4298     "block_test", Arg_one (fun arg o ->
4299       let ip = Ip.of_string arg in
4300       _s (match !Ip.banned (ip, None) with
4301           None -> "Not blocked"
4302         | Some reason ->
4303           Printf.sprintf "Blocked, %s\n" reason)
4304     ), "<ip> :\t\t\tcheck whether an IP is blocked";
4305
4306     "debug_pictures", Arg_two (fun dir output o ->
4307         CommonPictures.compute_ocaml_code dir output;
4308         _s "done"
4309     ), ":\t\t\tfor debugging only";
4310
4311     "debug_upnp", Arg_multiple ( fun args o ->
4312                 match args with
4313                         | ["init"] ->
4314                                 UpnpClient.init_maps ();
4315
4316                         | ["add"; intPort; extPort; isTcp; notes ] ->
4317                                 UpnpClient.maps_add_item 1 (int_of_string intPort) (int_of_string extPort) (int_of_string isTcp) notes;
4318
4319                         | ["start"] ->
4320                                 UpnpClient.job_start ();
4321
4322                         | ["remove"; intPort; extPort; isTcp; notes] ->
4323                                 UpnpClient.maps_remove_item 1 (int_of_string intPort) (int_of_string extPort) (int_of_string isTcp) notes;
4324
4325                         | ["clear"] ->
4326                                 UpnpClient.remove_all_maps 0 ;
4327
4328                         | ["stop"] ->
4329                                 UpnpClient.job_stop 0;
4330
4331                         | ["show"] | [] ->
4332                                 let buf = o.conn_buf in
4333                                         let     maps = UpnpClient.maps_get () in
4334                                         Printf.bprintf buf "upnp port forwarding status:\n";
4335                                         List.iter (fun map ->
4336                                                 let msg = UpnpClient.strings_port_map map in
4337                                                 Printf.bprintf buf "%s\n" msg;
4338                                         ) maps;
4339
4340                         | _ -> ();
4341                                 ;
4342                         _s "done"
4343     ), ":\t\t\t\t\t$debugging upnp\n"
4344        ^"\t\t\t\t\tfor example: \"add 4662 4662 1 ed_port\" add port forwarding intPort extPort isTcp notes\n"
4345        ^"\t\t\t\t\t\"remove 4662 4662 1 ed_port\" remove port forwarding intPort extPort isTcp notes\n"
4346        ^"\t\t\t\t\t\"clear\" clear all port forwarding\n"
4347        ^"\t\t\t\t\t\"show\" show all port forwarding info $n";
4348
4349   ]