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 share_scan_interval;
2092                         strings_of_option hdd_temp_minfree;
2093                         strings_of_option hdd_temp_stop_core;
2094                         strings_of_option hdd_coredir_minfree;
2095                         strings_of_option hdd_coredir_stop_core;
2096                         strings_of_option hdd_send_warning_interval;
2097                         strings_of_option file_started_cmd;
2098                         strings_of_option file_completed_cmd;
2099                         strings_of_option allow_browse_share;
2100                         strings_of_option auto_commit;
2101                         strings_of_option pause_new_downloads;
2102                         strings_of_option release_new_downloads;
2103                         strings_of_option create_file_mode;
2104                         strings_of_option create_dir_mode;
2105                         strings_of_option create_file_sparse;
2106                         strings_of_option log_file;
2107                         strings_of_option log_file_size;
2108                         strings_of_option log_size;
2109                       ]
2110                   | 6 ->
2111                       [
2112                         strings_of_option mail;
2113                         strings_of_option smtp_port;
2114                         strings_of_option smtp_server;
2115                         strings_of_option smtp_login;
2116                         strings_of_option smtp_password;
2117                         strings_of_option add_mail_brackets;
2118                         strings_of_option filename_in_subject;
2119                         strings_of_option url_in_mail;
2120                       ]
2121                   | 7 ->
2122                       ( (if Autoconf.donkey = "yes" then [(strings_of_option enable_overnet)] else [])
2123                         @ [
2124                         ] @
2125                         (if Autoconf.donkey = "yes" then [(strings_of_option enable_kademlia)] else [])
2126                         @ [
2127                         ] @
2128                         (if Autoconf.donkey = "yes" then [(strings_of_option enable_donkey)] else [])
2129                         @ [
2130                         ] @
2131                         (if Autoconf.bittorrent = "yes" then [(strings_of_option enable_bittorrent)] else [])
2132                         @ [
2133                         ] @
2134                         (if Autoconf.fasttrack = "yes" then [(strings_of_option enable_fasttrack)] else [])
2135                         @ [
2136                         ] @
2137                         (if Autoconf.opennapster = "yes" then [(strings_of_option enable_opennap)] else [])
2138                         @ [
2139                         ] @
2140                         (if Autoconf.soulseek = "yes" then [(strings_of_option enable_soulseek)] else [])
2141                         @ [
2142                         ] @
2143                         (if Autoconf.gnutella = "yes" then [(strings_of_option enable_gnutella)] else [])
2144                         @ [
2145                         ] @
2146                         (if Autoconf.gnutella2 = "yes" then [(strings_of_option enable_gnutella2)] else [])
2147                         @ [
2148                         ] @
2149                         (if Autoconf.direct_connect = "yes" then [(strings_of_option enable_directconnect)] else [])
2150                         @ [
2151                         ] @
2152                         (if Autoconf.openft = "yes" then [(strings_of_option enable_openft)] else [])
2153                         @ [
2154                         ] @
2155                         (if Autoconf.filetp = "yes" then [(strings_of_option enable_fileTP)] else [])
2156                         @ [
2157                         ] @
2158                         (if Autoconf.upnp_natpmp then [(strings_of_option upnp_port_forwarding)] else [])
2159                         @ [
2160                         ] @
2161                         (if Autoconf.upnp_natpmp then [(strings_of_option clear_upnp_port_at_exit)] else [])
2162                         @ [
2163                         strings_of_option tcpip_packet_size;
2164                         strings_of_option mtu_packet_size;
2165                         strings_of_option minimal_packet_size;
2166                         strings_of_option ip_blocking;
2167                         strings_of_option ip_blocking_descriptions;
2168                         strings_of_option ip_blocking_countries;
2169                         strings_of_option ip_blocking_countries_block;
2170                       ])
2171                   | 8 ->
2172                       [
2173                         strings_of_option term_ansi;
2174                         strings_of_option run_as_user;
2175                         strings_of_option run_as_useruid;
2176                         strings_of_option messages_filter;
2177                         strings_of_option comments_filter;
2178                         strings_of_option max_displayed_results;
2179                         strings_of_option max_name_len;
2180                         strings_of_option max_result_name_len;
2181                         strings_of_option max_filenames;
2182                         strings_of_option max_client_name_len;
2183                         strings_of_option emule_mods_count;
2184                         strings_of_option emule_mods_showall;
2185                         strings_of_option backup_options_format;
2186                         strings_of_option backup_options_delay;
2187                         strings_of_option backup_options_generations;
2188                         strings_of_option small_files_slot_limit;
2189                       ]
2190                   | 9 ->
2191                       changed_list
2192
2193                   | _ ->
2194                       let v = CommonInteractive.some_simple_options (tab - !mtabs) in
2195                       List.sort (fun d1 d2 -> compare d1 d2) v;
2196               with _ ->
2197                     let v = CommonInteractive.parse_simple_options args in
2198                     List.sort (fun d1 d2 -> compare d1 d2) v;
2199
2200
2201             );
2202             put "\\</td\\>\\</tr\\>";
2203             put "\\<tr\\>\\<td\\>";
2204
2205             put "\\<table cellspacing=0 cellpadding=0 class='hcenter'\\>\\<tr\\>";
2206
2207             button ~title:"Show shares Tab (also related for incoming directory)" ~cls:"fbig fbigb" ~cmd:"shares" "Shares";
2208             if (user2_is_admin o.conn_user.ui_user) then
2209               button ~title:"Show users Tab where you can add/remove Users" ~cls:"fbig fbigb" ~cmd:"users" "Users";
2210
2211             button ~title:"Show Web_infos Tab where you can add/remove automatic downloads like serverlists" ~cls:"fbig fbigb" ~cmd:"vwi" "Web infos";
2212             button ~title:"Show Calendar Tab, there are information about automatically jobs" ~cls:"fbig fbigb" ~cmd:"vcal" "Calendar";
2213             put "\\<td nowrap class=\\\"fbig fbigb pr\\\"\\>
2214 \\<form style=\\\"margin: 0px;\\\" name=\\\"htmlModsStyleForm\\\" id=\\\"htmlModsStyleForm\\\"
2215 action=\\\"javascript:submitHtmlModsStyle();\\\"\\>";
2216
2217             let options =
2218               ("0", "style/theme")
2219               ::
2220               Array.to_list (Array.mapi (fun i style -> string_of_int i, style.style_name) CommonMessages.styles)
2221               @
2222               if Sys.file_exists html_themes_dir then begin
2223                 let list = Unix2.list_directory html_themes_dir in
2224                 List.fold_left (fun acc d ->
2225                   if Unix2.is_directory (Filename.concat html_themes_dir d) then
2226                     let sd = (if String.length d > 11 then String.sub d 0 11 else d) in
2227                     (d,sd) :: acc
2228                   else
2229                     acc
2230                 ) [] (List.sort (fun d1 d2 -> compare d1 d2) list);
2231               end
2232               else []
2233             in
2234
2235             select "modsStyle" options;
2236
2237             put "\\</form\\>\\</td\\>\\</tr\\>\\</table\\>";
2238             put "\\</td\\>\\</tr\\>";
2239             put "\\<tr\\>\\<td\\>";
2240             put "\\<table cellspacing=0 cellpadding=0 class='hcenter'\\>\\<tr\\>";
2241             button ~title:"Change to simple Webinterface without html_mods" ~cls:"fbig fbigb fbigpad" ~cmd:"html_mods" "toggle html_mods";
2242             put "\\<td nowrap title=\\\"Toggle option helptext from javascript popup to html table\\\" class=\\\"fbig fbigb pr fbigpad\\\"\\>
2243 \\<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");
2244             put "\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\</table\\>\\</div\\>\\</br\\>";
2245
2246           html_mods_table_one_row buf "downloaderTable" "downloaders" [
2247           ("", "srh", "!! press ENTER to send changes to core !!"); ];
2248           end
2249
2250         else begin
2251           match args with
2252             | [] | _ :: _ :: _ -> list_options o (CommonInteractive.all_simple_options ())
2253             | ["9"] | ["changed"] -> list_options o changed_list
2254             | [_] -> list_options o (CommonInteractive.parse_simple_options args);
2255           end;
2256         ""
2257     ), "[<option>|changed]:\t\t\tprint options (use * as wildcard), 'changed' prints all changed options, leave empty to print all options";
2258
2259     "vwi", Arg_none (fun o ->
2260         let buf = o.conn_buf in
2261         if use_html_mods o then begin
2262             Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
2263 \\<tr\\>\\<td\\>
2264 \\<table cellspacing=0 cellpadding=0  width='100%%'\\>\\<tr\\>
2265 \\<td class=downloaded width='100%%'\\>\\</td\\>
2266 \\<td nowrap title=\\\"force downloading all web_infos files\\\" class=\\\"fbig\\\"\\>
2267 \\<a onclick=\\\"javascript: {parent.fstatus.location.href='submit?q=force_web_infos';}\\\"\\>Re-download all\\</a\\>
2268 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript: {
2269                    var getdir = prompt('Input: <kind> <URL> [<period>]','server.met URL')
2270                    parent.fstatus.location.href='submit?q=urladd+' + encodeURIComponent(getdir);
2271                    setTimeout('window.location.reload()',1000);
2272                     }\\\"\\>Add URL\\</a\\>
2273 \\</td\\>
2274 \\</tr\\>\\</table\\>
2275 \\</td\\>\\</tr\\>
2276 \\<tr\\>\\<td\\>";
2277
2278             if Hashtbl.length web_infos_table = 0 then
2279               html_mods_table_one_row buf "serversTable" "servers" [
2280                 ("", "srh", "no jobs defined"); ]
2281             else begin
2282
2283               html_mods_table_header buf "web_infoTable" "vo" [
2284                 ( Str, "srh ac", "Click to remove URL", "Remove" ) ;
2285                 ( Str, "srh", "Download now", "DL" ) ;
2286                 ( Str, "srh", "Filetype", "Type" ) ;
2287                 ( Num, "srh", "Interval in hours", "Interval" ) ;
2288                 ( Str, "srh", "URL", "URL" ) ;
2289                 ( Str, "srh", "URL state", "State" ) ;
2290               ] ;
2291
2292               html_mods_cntr_init ();
2293               Hashtbl.iter (fun key w ->
2294                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
2295                 Printf.bprintf buf "
2296         \\<td title=\\\"Click to remove URL\\\"
2297         onMouseOver=\\\"mOvr(this);\\\"
2298         onMouseOut=\\\"mOut(this);\\\"
2299         onClick=\\\'javascript:{
2300         parent.fstatus.location.href=\\\"submit?q=urlremove+\\\\\\\"%s\\\\\\\"\\\"
2301         setTimeout(\\\"window.location.reload()\\\",1000);}'
2302         class=\\\"srb\\\"\\>Remove\\</td\\>" (Url.encode w.url);
2303                 Printf.bprintf buf "
2304         \\<td title=\\\"Download now\\\"
2305         onMouseOver=\\\"mOvr(this);\\\"
2306         onMouseOut=\\\"mOut(this);\\\"
2307         onClick=\\\'javascript:{
2308         parent.fstatus.location.href=\\\"submit?q=force_web_infos+\\\\\\\"%s\\\\\\\"\\\";}'
2309         class=\\\"srb\\\"\\>DL\\</td\\>" (Url.encode w.url);
2310           Printf.bprintf buf "
2311               \\<td title=\\\"%s\\\" class=\\\"sr\\\"\\>%s\\</td\\>
2312               \\<td class=\\\"sr\\\"\\>%d\\</td\\>"  w.url w.kind w.period;
2313           Printf.bprintf buf "
2314               \\<td class=\\\"sr\\\"\\>%s\\</td\\>" w.url;
2315           Printf.bprintf buf "
2316               \\<td class=\\\"sr\\\"\\>%s\\</td\\>
2317               \\</tr\\>" (string_of_web_infos_state w.state);
2318               ) web_infos_table;
2319             end;
2320             Printf.bprintf buf "\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
2321
2322             html_mods_table_header buf "web_infoTable" "vo" [
2323               ( Str, "srh", "Web kind", "Kind" );
2324               ( Str, "srh", "Description", "Type" ) ];
2325
2326             html_mods_cntr_init ();
2327             List.iter (fun (kind, data) ->
2328                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
2329                 Printf.bprintf buf "
2330               \\<td class=\\\"sr\\\"\\>%s\\</td\\>
2331               \\<td class=\\\"sr\\\"\\>%s\\</td\\>" kind data.description
2332             ) !CommonWeb.file_kinds;
2333
2334             Printf.bprintf buf "\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
2335             print_option_help o web_infos
2336
2337           end
2338         else
2339             begin
2340               Printf.bprintf buf "kind / period / url / state :\n";
2341               Hashtbl.iter (fun key w ->
2342                   Printf.bprintf buf "%s ; %d ; %s; %s\n"
2343                     w.kind w.period w.url (string_of_web_infos_state w.state)
2344               ) web_infos_table;
2345               Printf.bprintf buf "\nAllowed values for kind:\n";
2346               List.iter (fun (kind, data) ->
2347                   Printf.bprintf buf "%s - %s\n" kind data.description
2348               ) !CommonWeb.file_kinds
2349             end;
2350         ""
2351     ), ":\t\t\t\t\tprint web_infos options";
2352
2353     "options", Arg_multiple (fun args o ->
2354         let buf = o.conn_buf in
2355         match args with
2356           [] ->
2357             Printf.bprintf buf "Available sections for options: \n";
2358
2359             List.iter (fun s ->
2360                 Printf.bprintf buf "  $b%s$n\n" (section_name s);
2361             ) (sections downloads_ini);
2362
2363             networks_iter (fun r ->
2364                 List.iter (fun file ->
2365                     List.iter (fun s ->
2366                         Printf.bprintf buf "  $b%s::%s$n\n"
2367                           r.network_name
2368                           (section_name s);
2369                     ) (sections file)
2370                 ) r.network_config_file
2371             );
2372             "\n\nUse 'options section' to see options in this section"
2373
2374         | ss ->
2375
2376             let print_section name prefix (s: options_section) =
2377               if List.mem name ss then
2378                 Printf.bprintf buf "Options in section $b%s$n:\n" name;
2379               List.iter (fun o ->
2380                   Printf.bprintf buf "  %s [$r%s%s$n]= $b%s$n\n"
2381                     (if o.option_desc = "" then
2382                       o.option_name else o.option_desc)
2383                   prefix o.option_name o.option_value
2384               ) (strings_of_section_options "" s)
2385             in
2386             List.iter (fun s ->
2387                 print_section (section_name s) "" s
2388             ) (sections downloads_ini);
2389
2390             networks_iter (fun r ->
2391                 List.iter (fun file ->
2392                     List.iter (fun s ->
2393                         print_section
2394                           (Printf.sprintf "%s::%s" r.network_name
2395                             (section_name s)) (r.network_shortname ^ "-") s
2396                     ) (sections file)
2397                 ) r.network_config_file
2398             );
2399
2400             "\nUse '$rset option \"value\"$n' to change a value where options is
2401 the name between []"
2402     ), ":\t\t\t\t$bprint options values by section$n";
2403
2404   ]
2405
2406 (*************************************************************************)
2407 (*                                                                       *)
2408 (*                         Driver/Sharing                                *)
2409 (*                                                                       *)
2410 (*************************************************************************)
2411
2412 let _ =
2413   register_commands "Driver/Sharing"
2414     [
2415
2416     "reshare", Arg_none (fun o ->
2417         let buf = o.conn_buf in
2418         shared_check_files ();
2419         if o.conn_output = HTML then
2420           html_mods_table_one_row buf "serversTable" "servers" [
2421             ("", "srh", "Reshare check done"); ]
2422         else
2423           Printf.bprintf buf "Reshare check done";
2424         _s ""
2425     ), ":\t\t\t\tcheck shared files for removal";
2426
2427      "debug_disk", Arg_one (fun arg o ->
2428          let buf = o.conn_buf in
2429          let print_i64o = function
2430            | None -> "Unknown"
2431            | Some v -> Printf.sprintf "%Ld" v in
2432          let print_io = function
2433            | None -> "Unknown"
2434            | Some v -> Printf.sprintf "%d" v in
2435          Printf.bprintf buf "working on dir %s\n" arg;
2436          Printf.bprintf buf "bsize %s\n" (print_i64o (Unix32.bsize arg));
2437          Printf.bprintf buf "blocks %s\n" (print_i64o (Unix32.blocks arg));
2438          Printf.bprintf buf "bfree %s\n" (print_i64o (Unix32.bfree arg));
2439          Printf.bprintf buf "bavail %s\n" (print_i64o (Unix32.bavail arg));
2440          Printf.bprintf buf "fnamelen %s\n" (print_io (Unix32.fnamelen arg));
2441          Printf.bprintf buf "filesystem %s\n" (Unix32.filesystem arg);
2442          let print_i64o_amount = function
2443            | None -> "Unknown"
2444            | Some v -> Printf.sprintf "%Ld - %s" v (size_of_int64 v) in
2445          Printf.bprintf buf "disktotal %s\n" (print_i64o_amount (Unix32.disktotal arg));
2446          Printf.bprintf buf "diskfree %s\n" (print_i64o_amount (Unix32.diskfree arg));
2447          Printf.bprintf buf "diskused %s\n" (print_i64o_amount (Unix32.diskused arg));
2448          let print_percento = function
2449            | None -> "Unknown"
2450            | Some p -> Printf.sprintf "%d%%" p in
2451          Printf.bprintf buf "percentused %s\n" (print_percento (Unix32.percentused arg));
2452          Printf.bprintf buf "percentfree %s\n" (print_percento (Unix32.percentfree arg));
2453          let stat = Unix.LargeFile.stat arg in
2454          Printf.bprintf buf "\nstat_device %d\n" stat.Unix.LargeFile.st_dev;
2455          Printf.bprintf buf "stat_inode %d\n" stat.Unix.LargeFile.st_ino;
2456
2457          _s ""
2458      ), "debug command (example: disk .)";
2459
2460      "debug_dir", Arg_one (fun arg o ->
2461          let buf = o.conn_buf in
2462          let filelist = Unix2.list_directory arg in
2463          Printf.bprintf buf "%d entries in dir %s\n" (List.length filelist) arg;
2464          List.iter (fun file ->
2465            Printf.bprintf buf "%s\n     %s\nMime %s\n\n"
2466              file
2467              (match Magic.M.magic_fileinfo (Filename.concat arg file) false with
2468                 None -> "unknown"
2469               | Some fileinfo -> fileinfo)
2470              (match Magic.M.magic_fileinfo (Filename.concat arg file) true with
2471                 None -> "unknown"
2472               | Some fileinfo -> fileinfo)
2473          ) filelist;
2474          _s ""
2475      ), "debug command (example: disk .)";
2476
2477      "debug_fileinfo", Arg_one (fun arg o ->
2478          let buf = o.conn_buf in
2479          (try
2480             let module U = Unix.LargeFile in
2481             let s = U.stat arg in
2482             Printf.bprintf buf "st_dev %d\n" s.U.st_dev;
2483             Printf.bprintf buf "st_ino %d\n" s.U.st_ino;
2484             Printf.bprintf buf "st_uid %d\n" s.U.st_uid;
2485             Printf.bprintf buf "st_gid %d\n" s.U.st_gid;
2486             Printf.bprintf buf "st_size %Ld\n" s.U.st_size;
2487             Printf.bprintf buf "st_atime %s\n" (Date.to_full_string s.U.st_atime);
2488             Printf.bprintf buf "st_mtime %s\n" (Date.to_full_string s.U.st_mtime);
2489             Printf.bprintf buf "st_ctime %s\n" (Date.to_full_string s.U.st_ctime);
2490             let user,group = Unix32.owner arg in
2491             Printf.bprintf buf "username %s\n" user;
2492             Printf.bprintf buf "groupname %s\n" group;
2493           with e -> Printf.bprintf buf "Error %s when opening %s\n" (Printexc2.to_string e) arg);
2494          _s ""
2495      ), "debug command (example: file .)";
2496
2497      "debug_rlimit", Arg_none (fun o ->
2498          let buf = o.conn_buf in
2499          let cpu = Unix2.ml_getrlimit Unix2.RLIMIT_CPU in
2500          let fsize = Unix2.ml_getrlimit Unix2.RLIMIT_FSIZE in
2501          let data = Unix2.ml_getrlimit Unix2.RLIMIT_DATA in
2502          let stack = Unix2.ml_getrlimit Unix2.RLIMIT_STACK in
2503          let core = Unix2.ml_getrlimit Unix2.RLIMIT_CORE in
2504          let rss = Unix2.ml_getrlimit Unix2.RLIMIT_RSS in
2505          let nprof = Unix2.ml_getrlimit Unix2.RLIMIT_NPROF in
2506          let nofile = Unix2.ml_getrlimit Unix2.RLIMIT_NOFILE in
2507          let memlock = Unix2.ml_getrlimit Unix2.RLIMIT_MEMLOCK in
2508          let rlimit_as = Unix2.ml_getrlimit Unix2.RLIMIT_AS in
2509          Printf.bprintf buf "cpu %d %d\n" cpu.Unix2.rlim_cur cpu.Unix2.rlim_max;
2510          Printf.bprintf buf "fsize %d %d\n" fsize.Unix2.rlim_cur fsize.Unix2.rlim_max;
2511          Printf.bprintf buf "data %d %d\n" data.Unix2.rlim_cur data.Unix2.rlim_max;
2512          Printf.bprintf buf "stack %d %d\n" stack.Unix2.rlim_cur stack.Unix2.rlim_max;
2513          Printf.bprintf buf "core %d %d\n" core.Unix2.rlim_cur core.Unix2.rlim_max;
2514          Printf.bprintf buf "rss %d %d\n" rss.Unix2.rlim_cur rss.Unix2.rlim_max;
2515          Printf.bprintf buf "nprof %d %d\n" nprof.Unix2.rlim_cur nprof.Unix2.rlim_max;
2516          Printf.bprintf buf "nofile %d %d\n" nofile.Unix2.rlim_cur nofile.Unix2.rlim_max;
2517          Printf.bprintf buf "memlock %d %d\n" memlock.Unix2.rlim_cur memlock.Unix2.rlim_max;
2518          Printf.bprintf buf "as %d %d\n" rlimit_as.Unix2.rlim_cur rlimit_as.Unix2.rlim_max;
2519          _s ""
2520      ), "debug command";
2521
2522     "shares", Arg_none (fun o ->
2523         if user2_is_admin o.conn_user.ui_user then begin
2524         let buf = o.conn_buf in
2525
2526         if use_html_mods o then begin
2527             Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
2528 \\<tr\\>\\<td\\>
2529 \\<table cellspacing=0 cellpadding=0  width='100%%'\\>\\<tr\\>
2530 \\<td class=downloaded width=100%%\\>\\</td\\>
2531 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript: {
2532                    var getdir = prompt('Input: <priority#> <directory> [<strategy>] (surround dir with quotes if necessary)','0 /home/mldonkey/share')
2533                    parent.fstatus.location.href='submit?q=share+' + encodeURIComponent(getdir);
2534                    setTimeout('window.location.reload()',1000);
2535                     }\\\"\\>Add Share\\</a\\>
2536 \\</td\\>
2537 \\</tr\\>\\</table\\>
2538 \\</td\\>\\</tr\\>
2539 \\<tr\\>\\<td\\>";
2540
2541             html_mods_table_header buf "sharesTable" "shares" [
2542                ( Str, "srh ac", "Click to unshare directory", "Unshare" ) ;
2543                ( Num, "srh ar", "Priority", "P" ) ;
2544                ( Str, "srh", "Directory", "Directory" ) ;
2545                ( Str, "srh", "Strategy", "Strategy" ) ;
2546                ( Num, "srh ar", "HDD used", "used" ) ;
2547                ( Num, "srh ar", "HDD free", "free" ) ;
2548                ( Num, "srh ar", "% free", "% free" ) ;
2549                ( Str, "srh", "Filesystem", "FS" ) ];
2550
2551             html_mods_cntr_init ();
2552             List.iter (fun shared_dir ->
2553                 let dir = shared_dir.shdir_dirname in
2554                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>
2555         \\<td title=\\\"Click to unshare this directory\\\"
2556         onMouseOver=\\\"mOvr(this);\\\"
2557         onMouseOut=\\\"mOut(this);\\\"
2558         onClick=\\\'javascript:{
2559         parent.fstatus.location.href=\\\"submit?q=unshare+\\\\\\\"%s\\\\\\\"\\\"
2560         setTimeout(\\\"window.location.reload()\\\",1000);}'
2561         class=\\\"srb\\\"\\>Unshare\\</td\\>
2562         \\<td class=\\\"sr ar\\\"\\>%d\\</td\\>
2563         \\<td class=\\\"sr\\\"\\>%s\\</td\\>
2564         \\<td class=\\\"sr\\\"\\>%s\\</td\\>
2565         \\<td class=\\\"sr ar\\\"\\>%s\\</td\\>
2566         \\<td class=\\\"sr ar\\\"\\>%s\\</td\\>
2567         \\<td class=\\\"sr ar\\\"\\>%s\\</td\\>
2568         \\<td class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>"
2569                 (html_mods_cntr ())
2570                 (Url.encode dir)
2571                 shared_dir.shdir_priority
2572                 dir
2573                 shared_dir.shdir_strategy
2574                 (match Unix32.diskused dir with
2575                 | None -> "---"
2576                 | Some du -> size_of_int64 du)
2577                 (match Unix32.diskfree dir with
2578                 | None -> "---"
2579                 | Some df -> size_of_int64 df)
2580                 (match Unix32.percentfree dir with
2581                 | None -> "---"
2582                 | Some p -> Printf.sprintf "%d%%" p)
2583                 (Unix32.filesystem dir);
2584             )
2585             !!shared_directories;
2586
2587             Printf.bprintf buf "\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
2588             print_option_help o shared_directories;
2589             Printf.bprintf buf "\\<P\\>";
2590
2591             html_mods_big_header_start buf "sharesTable" ["Share strategies"];
2592             html_mods_table_header buf "sharesTable" "shares" [
2593                ( Str, "srh", "Name", "Name" ) ;
2594                ( Str, "srh", "Incoming", "Incoming" ) ;
2595                ( Str, "srh", "Directories", "Directories" ) ;
2596                ( Str, "srh", "Recursive", "Recursive" ) ;
2597                ( Num, "srh", "Minsize", "Minsize" ) ;
2598                ( Num, "srh", "Maxsize", "Maxsize" ) ;
2599                ( Str, "srh", "Extensions", "Extensions" ) ];
2600
2601             html_mods_cntr_init ();
2602
2603             let int64_print v =
2604               if v = Int64.max_int then "unlimited" else Int64ops.int64_to_human_readable v in
2605
2606             List.iter (fun (s,t) ->
2607                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
2608                 html_mods_td buf [
2609                     ("", "sr", s);
2610                     ("", "sr", string_of_bool t.sharing_incoming);
2611                     ("", "sr", string_of_bool t.sharing_directories);
2612                     ("", "sr", string_of_bool t.sharing_recursive);
2613                     ("", "sr", (int64_print t.sharing_minsize));
2614                     ("", "sr", (int64_print t.sharing_maxsize));
2615                     ("", "sr", (String.concat " " t.sharing_extensions));
2616                     ];
2617                 Printf.bprintf buf "\\</tr\\>\n"
2618               ) !!sharing_strategies;
2619
2620           end
2621         else
2622           begin
2623
2624             Printf.bprintf buf "Shared directories:\n";
2625             List.iter (fun sd ->
2626                 Printf.bprintf buf "  %d %s %s\n"
2627                 sd.shdir_priority sd.shdir_dirname sd.shdir_strategy)
2628             !!shared_directories;
2629
2630           end;
2631         ""
2632           end
2633         else
2634           _s "You are not allowed to list shared directories"
2635     ), ":\t\t\t\tprint shared directories";
2636
2637     "share", Arg_multiple (fun args o ->
2638         if user2_is_admin o.conn_user.ui_user then begin
2639         let (prio, arg, strategy) = match args with
2640           | [prio; arg; strategy] -> int_of_string prio, arg, strategy
2641           | [prio; arg] -> int_of_string prio, arg, "only_directory"
2642           | [arg] -> 0, arg, "only_directory"
2643           | _  -> failwith "Bad number of arguments"
2644         in
2645
2646         let shdir = {
2647             shdir_dirname = arg;
2648             shdir_priority = prio;
2649             shdir_networks = [];
2650             shdir_strategy = strategy;
2651           } in
2652
2653         if Unix2.is_directory arg then
2654           begin
2655             try
2656               let d = List.find (fun d -> d.shdir_dirname = arg) !!shared_directories in
2657               let old_prio = d.shdir_priority in
2658               d.shdir_priority <- prio;
2659               Printf.sprintf "prio of %s changed from %d to %d"
2660                 d.shdir_dirname old_prio d.shdir_priority
2661             with Not_found ->
2662               shared_directories =:= shdir :: !!shared_directories;
2663               shared_add_directory shdir;
2664               Printf.sprintf "directory %s added%s"
2665                 shdir.shdir_dirname
2666                 (if shdir.shdir_priority <> 0 then
2667                     Printf.sprintf " with prio %d" shdir.shdir_priority
2668                  else "")
2669           end
2670         else
2671           "no such directory"
2672           end
2673         else
2674           _s "You are not allowed to share directories"
2675     ), "<priority> <dir> [<strategy>] :\tshare directory <dir> with <priority> [and sharing strategy <strategy>]";
2676
2677     "unshare", Arg_one (fun arg o ->
2678
2679         if user2_is_admin o.conn_user.ui_user then begin
2680         let found = ref false in
2681         shared_directories =:= List.filter (fun sd ->
2682             let diff = sd.shdir_dirname <> arg in
2683             if not diff then begin
2684               found := true;
2685               shared_iter (fun s ->
2686                 let impl = as_shared_impl s in
2687                   if (Filename.dirname impl.impl_shared_fullname) = arg
2688                     then shared_unshare s
2689               )
2690             end;
2691             diff
2692         ) !!shared_directories;
2693         if !found then begin
2694             CommonShared.shared_check_files ();
2695             _s "directory removed"
2696           end else
2697           _s "directory already unshared"
2698           end
2699         else
2700           _s "You are not allowed to unshare directories"
2701     ), "<dir> :\t\t\t\tunshare directory <dir>";
2702
2703     "upstats", Arg_none (fun o ->
2704         if not (user2_can_view_uploads o.conn_user.ui_user) then
2705           print_command_result o "You are not allowed to see upload statistics"
2706         else
2707           begin
2708             let list = ref [] in
2709             shared_iter (fun s ->
2710               let impl = as_shared_impl s in
2711               list := impl :: !list
2712             );
2713             print_upstats o !list None;
2714           end;
2715         _s ""
2716     ), ":\t\t\t\tstatistics on upload";
2717
2718     "links", Arg_multiple (fun args o ->
2719         let buf = o.conn_buf in
2720         if not (user2_can_view_uploads o.conn_user.ui_user) then
2721           print_command_result o "You are not allowed to see shared files list"
2722         else begin
2723
2724         let list = Hashtbl.create !shared_counter in
2725
2726         let compute_shares () =
2727           shared_iter (fun s ->
2728             let impl = as_shared_impl s in
2729             try
2730               ignore (Hashtbl.find list impl.impl_shared_id)
2731             with Not_found ->
2732                 Hashtbl.add list impl.impl_shared_id {
2733                     filename = impl.impl_shared_codedname;
2734                     filesize = impl.impl_shared_size;
2735                     fileid = impl.impl_shared_id;
2736                 })
2737         in
2738
2739         let compute_downloads () =
2740           List.iter (fun f ->
2741             try
2742               ignore (Hashtbl.find list f.file_md4)
2743             with Not_found ->
2744                 Hashtbl.add list f.file_md4 {
2745                     filename = f.file_name;
2746                     filesize = f.file_size;
2747                     fileid = f.file_md4;
2748                 }) (List2.tail_map file_info
2749                       (user2_filter_files !!files o.conn_user.ui_user))
2750         in
2751
2752         let list =
2753           List.sort ( fun f1 f2 ->
2754             String.compare
2755               (Filename.basename f1.filename)
2756               (Filename.basename f2.filename)
2757         )
2758         (match args with
2759          | ["downloading"] -> compute_downloads (); Hashtbl2.to_list list
2760          | ["shared"] -> compute_shares (); Hashtbl2.to_list list
2761          | _ -> compute_shares (); compute_downloads (); Hashtbl2.to_list list)
2762         in
2763
2764         List.iter (fun f ->
2765           if (f.fileid <> Md4.null) then
2766             Printf.bprintf buf "%s\n" (file_print_ed2k_link
2767               (Filename.basename f.filename) f.filesize f.fileid);
2768         ) list;
2769         end;
2770         "Done"
2771     ), "[downloading|shared|empty for all]: list links of shared files";
2772
2773     "uploaders", Arg_none (fun o ->
2774         let buf = o.conn_buf in
2775
2776         if not (user2_can_view_uploads o.conn_user.ui_user) then
2777           print_command_result o "You are not allowed to see uploaders list"
2778         else begin
2779
2780         let nuploaders = Intmap.length !uploaders in
2781         if use_html_mods o then
2782           begin
2783             html_mods_cntr_init ();
2784             Printf.bprintf buf "\\<div class=\\\"uploaders\\\"\\>";
2785             html_mods_table_one_row buf "uploadersTable" "uploaders" [
2786               ("", "srh", Printf.sprintf "Total upload slots: %d (%d) | Pending slots: %d\n" nuploaders
2787                 (Fifo.length CommonUploads.upload_clients)
2788                 (Intmap.length !CommonUploads.pending_slots_map)); ];
2789             if nuploaders > 0 then
2790
2791               begin
2792
2793                 html_mods_table_header buf "uploadersTable" "uploaders" ([
2794                   ( Num, "srh ac", "Client number", "Num" ) ;
2795                   ( Str, "srh", "Network", "Network" ) ;
2796                   ( Str, "srh", "Connection type [I]ndirect [D]irect", "C" ) ;
2797                   ( Str, "srh", "Client name", "Client name" ) ;
2798                   ( Str, "srh", "Secure User Identification [N]one, [P]assed, [F]ailed", "S" ) ;
2799                   ( Str, "srh", "IP address", "IP address" ) ;
2800                   ] @ (if Geoip.active () then [( Str, "srh", "Country Code/Name", "CC" )] else []) @ [
2801                   ( Str, "srh", "Connected time (minutes)", "CT" ) ;
2802                   ( Str, "srh", "Client brand", "CB" ) ;
2803                   ( Str, "srh", "Client release", "CR" ) ;
2804                   ] @
2805                   (if !!emule_mods_count then [( Str, "srh", "eMule MOD", "EM" )] else [])
2806                   @ [
2807                   ( Num, "srh ar", "Total DL bytes from this client for all files", "tDL" ) ;
2808                   ( Num, "srh ar", "Total UL bytes to this client for all files", "tUL" ) ;
2809                   ( Num, "srh ar", "Session DL bytes from this client for all files", "sDL" ) ;
2810                   ( Num, "srh ar", "Session UL bytes to this client for all files", "sUL" ) ;
2811                   ( Str, "srh ar", "Slot kind", "Slot" ) ;
2812                   ( Str, "srh", "Filename", "Filename" ) ]);
2813
2814                 List.iter (fun c ->
2815                     try
2816                       let i = client_info c in
2817                       if is_connected i.client_state then begin
2818
2819                           Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"
2820                         title=\\\"[%d] Add as friend (avg: %.1f KB/s)\\\"
2821                         onMouseOver=\\\"mOvr(this);\\\"
2822                         onMouseOut=\\\"mOut(this);\\\"
2823                         onClick=\\\"parent.fstatus.location.href='submit?q=friend_add+%d'\\\"\\>"
2824                             (html_mods_cntr ()) (client_num c)
2825                           (Int64.to_float i.client_session_uploaded /. 1024. /.
2826                               float_of_int (max 1 ((last_time ()) - i.client_connect_time)))
2827                           (client_num c);
2828
2829                           html_mods_td buf [
2830                             ("", "sr", Printf.sprintf "%d" (client_num c)); ];
2831
2832                           let ips,cc,cn = string_of_kind_geo i.client_kind i.client_country_code in
2833
2834                           client_print_html c o;
2835                           html_mods_td buf ([
2836                             ("", "sr", (match i.client_sui_verified with
2837                               | None -> "N"
2838                                | Some b -> if b then "P" else "F"
2839                             ));
2840                             ("", "sr", ips);
2841                             ] @ (if Geoip.active () then [(cn, "sr", CommonPictures.flag_html cc)] else []) @ [
2842                             ("", "sr", Printf.sprintf "%d" (((last_time ()) - i.client_connect_time) / 60));
2843                             (client_software i.client_software i.client_os, "sr", client_software_short i.client_software i.client_os);
2844                             ("", "sr", i.client_release);
2845                             ] @
2846                             (if !!emule_mods_count then [("", "sr", i.client_emulemod)] else [])
2847                             @ [
2848                             ("", "sr ar", size_of_int64 i.client_total_downloaded);
2849                             ("", "sr ar", size_of_int64 i.client_total_uploaded);
2850                             ("", "sr ar", size_of_int64 i.client_session_downloaded);
2851                             ("", "sr ar", size_of_int64 i.client_session_uploaded);
2852                             (let text1, text2 =
2853                                 match client_slot c with
2854                                 | FriendSlot -> "Friend", "F"
2855                                 | ReleaseSlot -> "Release", "R"
2856                                 | SmallFileSlot -> "Small file", "S"
2857                                 | PrioSlot dir -> "Prio dir: " ^ dir, "P"
2858                                 | _ -> "", "" in text1, "sr ar", text2);
2859                             ("", "sr", (match i.client_upload with
2860                                   Some f -> shorten f !!max_name_len
2861                                 | None -> "") ) ]);
2862
2863                           Printf.bprintf buf "\\</tr\\>"
2864                         end
2865                     with _ -> ()
2866                 ) (List.sort
2867                     (fun c1 c2 -> compare (client_num c1) (client_num c2))
2868                   (Intmap.to_list !uploaders));
2869                 Printf.bprintf buf "\\</table\\>\\</div\\>";
2870               end;
2871
2872             if !!html_mods_show_pending && Intmap.length !CommonUploads.pending_slots_map > 0 then
2873
2874               begin
2875                 Printf.bprintf buf "\\<br\\>\\<br\\>";
2876                 html_mods_table_header buf "uploadersTable" "uploaders" ([
2877                   ( Num, "srh ac", "Client number", "Num" ) ;
2878                   ( Str, "srh", "Network", "Network" ) ;
2879                   ( Str, "srh", "Connection type [I]ndirect [D]irect", "C" ) ;
2880                   ( Str, "srh", "Client name", "Client name" ) ;
2881                   ( Str, "srh", "Secure User Identification [N]one, [P]assed, [F]ailed", "S" ) ;
2882                   ( Str, "srh", "IP address", "IP address" ) ;
2883                   ] @ (if Geoip.active () then [( Str, "srh", "Country Code/Name", "CC" )] else []) @ [
2884                   ( Str, "srh", "Client brand", "CB" ) ;
2885                   ( Str, "srh", "Client release", "CR" ) ;
2886                   ] @
2887                   (if !!emule_mods_count then [( Str, "srh", "eMule MOD", "EM" )] else [])
2888                   @ [
2889                   ( Num, "srh ar", "Total DL bytes from this client for all files", "tDL" ) ;
2890                   ( Num, "srh ar", "Total UL bytes to this client for all files", "tUL" ) ;
2891                   ( Num, "srh ar", "Session DL bytes from this client for all files", "sDL" ) ;
2892                   ( Num, "srh ar", "Session UL bytes to this client for all files", "sUL" ) ;
2893                   ( Str, "srh", "Filename", "Filename" ) ]);
2894
2895                 Intmap.iter (fun cnum c ->
2896
2897                     try
2898                       let i = client_info c in
2899                       let ips,cc,cn = string_of_kind_geo i.client_kind i.client_country_code in
2900
2901                       Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"
2902                                         title=\\\"Add as Friend\\\" onMouseOver=\\\"mOvr(this);\\\" onMouseOut=\\\"mOut(this);\\\"
2903                                         onClick=\\\"parent.fstatus.location.href='submit?q=friend_add+%d'\\\"\\>"
2904                         (html_mods_cntr ()) cnum;
2905
2906                       html_mods_td buf [
2907                         ("", "sr", Printf.sprintf "%d" (client_num c)); ];
2908
2909                       client_print_html c o;
2910
2911                       html_mods_td buf ([
2912                         ("", "sr", (match i.client_sui_verified with
2913                           | None -> "N"
2914                           | Some b -> if b then "P" else "F"
2915                         ));
2916                         ("", "sr", ips);
2917                         ] @ (if Geoip.active () then [(cn, "sr", CommonPictures.flag_html cc)] else []) @ [
2918                         (client_software i.client_software i.client_os, "sr", client_software_short i.client_software i.client_os);
2919                         ("", "sr", i.client_release);
2920                         ] @
2921                         (if !!emule_mods_count then [("", "sr", i.client_emulemod )] else [])
2922                         @ [
2923                         ("", "sr ar", size_of_int64 i.client_total_downloaded);
2924                         ("", "sr ar", size_of_int64 i.client_total_uploaded);
2925                         ("", "sr ar", size_of_int64 i.client_session_downloaded);
2926                         ("", "sr ar", size_of_int64 i.client_session_uploaded);
2927                         ("", "sr", (match i.client_upload with
2928                               Some f -> shorten f !!max_name_len
2929                             | None -> "") ) ]);
2930
2931                       Printf.bprintf buf "\\</tr\\>";
2932                     with _ -> ();
2933
2934                 ) !CommonUploads.pending_slots_map;
2935                 Printf.bprintf buf "\\</table\\>\\</div\\>";
2936               end;
2937             Printf.bprintf buf "\\</div\\>"
2938           end
2939         else
2940           begin
2941             Intmap.iter (fun _ c ->
2942                 try
2943                   let i = client_info c in
2944                   client_print c o;
2945                   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);
2946                   match i.client_upload with
2947                     Some cu ->
2948                       Printf.bprintf buf "      filename: %s\n" cu
2949                   | None -> ()
2950                 with _ ->
2951                     Printf.bprintf buf "no info on client %d\n" (client_num c )
2952             ) !uploaders;
2953
2954             Printf.bprintf buf "Total upload slots: %d (%d) | Pending slots: %d\n" nuploaders
2955               (Fifo.length CommonUploads.upload_clients)
2956             (Intmap.length !CommonUploads.pending_slots_map);
2957           end
2958       end;
2959       ""
2960     ), ":\t\t\t\tshow users currently uploading";
2961
2962
2963   ]
2964
2965 (*************************************************************************)
2966 (*                                                                       *)
2967 (*                         Driver/Downloads                              *)
2968 (*                                                                       *)
2969 (*************************************************************************)
2970
2971 let _ =
2972   let resume_alias s = s, Arg_multiple (fun args o ->
2973         if args = ["all"] && user2_is_admin o.conn_user.ui_user then
2974           List.iter (fun file ->
2975               file_resume file (admin_user ())
2976           ) !!files
2977         else
2978           List.iter (fun num ->
2979               let num = int_of_string num in
2980               List.iter (fun file ->
2981                   if (as_file_impl file).impl_file_num = num then
2982                       file_resume file o.conn_user.ui_user
2983               ) !!files) args; ""
2984     ), "<num|all> :\t\t\tresume a paused download (use arg 'all' for all files)"
2985   in
2986   register_commands "Driver/Downloads"
2987     [
2988
2989     "priority", Arg_multiple (fun args o ->
2990         let buf = o.conn_buf in
2991         match args with
2992           p :: files ->
2993             let absolute, p = if String2.check_prefix p "=" then
2994                 true, int_of_string (String2.after p 1)
2995               else false, int_of_string p in
2996             List.iter (fun arg ->
2997                 try
2998                   let file = file_find (int_of_string arg) in
2999                   let priority = if absolute then p
3000                     else (file_priority file) + p in
3001                   let priority = if priority < -100 then -100 else
3002                     if priority > 100 then 100 else priority in
3003                   set_file_priority file priority;
3004                   Printf.bprintf buf "Setting priority of %s to %d\n"
3005                     (file_best_name file) (file_priority file);
3006                 with _ -> failwith (Printf.sprintf "No file number %s" arg)
3007             ) files;
3008             force_download_quotas ();
3009             _s "done"
3010         | [] -> "Bad number of args"
3011
3012     ), "<priority> <files numbers> :\tchange file priorities";
3013
3014     "download_order", Arg_two (fun num v o ->
3015         try
3016           let file = file_find (int_of_string num) in
3017           (match v with
3018           | "linear" -> ignore (CommonFile.file_download_order file (Some CommonTypes.LinearStrategy))
3019           | _ -> ignore (CommonFile.file_download_order file (Some CommonTypes.AdvancedStrategy)));
3020           _s (Printf.sprintf "Changed download order of %s to %s"
3021                 (file_best_name file) (file_print_download_order file))
3022         with e -> Printf.sprintf "Exception %s" (Printexc2.to_string e)
3023     ), "<file number> <random|linear> :\tchange download order of file blocks (default random, with first and last block first)";
3024
3025     "confirm", Arg_one (fun arg o ->
3026         match String.lowercase arg with
3027           "yes" | "y" | "true" ->
3028             List.iter (fun file ->
3029                 try
3030                   file_cancel file o.conn_user.ui_user
3031                 with e ->
3032                     lprintf "Exception %s in cancel file %d\n"
3033                       (Printexc2.to_string e) (file_num file)
3034             ) !to_cancel;
3035             to_cancel := [];
3036             _s "Files cancelled"
3037         | "no" | "n" | "false" ->
3038             to_cancel := [];
3039             _s "cancel aborted"
3040         | "what" | "w" ->
3041             files_to_cancel o
3042         | _ -> failwith "Invalid argument"
3043     ), "<yes|no|what> :\t\t\tconfirm cancellation";
3044
3045     "test_recover", Arg_one (fun num o ->
3046
3047         let num = int_of_string num in
3048         let file = file_find num in
3049         let segments = CommonFile.recover_bytes file in
3050         let buf = o.conn_buf in
3051         Printf.bprintf buf "Segments:\n";
3052         let downloaded = ref zero in
3053         List.iter (fun (begin_pos, end_pos) ->
3054             Printf.bprintf buf "   %Ld - %Ld\n" begin_pos end_pos;
3055             downloaded := !downloaded ++ (end_pos -- begin_pos);
3056         ) segments;
3057         Printf.sprintf "Downloaded: %Ld\n" !downloaded
3058     ), "<num> :\t\t\tprint the segments downloaded in file";
3059
3060
3061     "cancel", Arg_multiple (fun args o ->
3062
3063         let file_cancel num =
3064           if not (List.memq num !to_cancel) then
3065             to_cancel := num :: !to_cancel
3066         in
3067         if args = ["all"] && user2_is_admin o.conn_user.ui_user then
3068           List.iter (fun file ->
3069               file_cancel file
3070           ) !!files
3071         else
3072           List.iter (fun num ->
3073               let num = int_of_string num in
3074               List.iter (fun file ->
3075                   if (as_file_impl file).impl_file_num = num then begin
3076                       lprintf "TRY TO CANCEL FILE\n";
3077                       file_cancel file
3078                     end
3079               ) !!files) args;
3080         files_to_cancel o
3081     ), "<num|all> :\t\t\tcancel download (use arg 'all' for all files)";
3082
3083     "downloaders", Arg_none (fun o ->
3084         let buf = o.conn_buf in
3085
3086         if use_html_mods o then
3087           html_mods_table_header buf "downloadersTable" "downloaders" ([
3088               ( Num, "srh ac", "Client number (click to add as friend)", "Num" ) ;
3089               ( Str, "srh", "Client state", "CS" ) ;
3090               ( Str, "srh", "Client name", "Name" ) ;
3091               ( Str, "srh", "Client brand", "CB" ) ;
3092               ( Str, "srh", "Client release", "CR" ) ;
3093             ] @
3094               (if !!emule_mods_count then [( Str, "srh", "eMule MOD", "EM" )] else [])
3095             @ [
3096               ( Str, "srh", "Overnet [T]rue, [F]alse", "O" ) ;
3097               ( Num, "srh ar", "Connected time (minutes)", "CT" ) ;
3098               ( Str, "srh", "Connection [I]ndirect, [D]irect", "C" ) ;
3099               ( Str, "srh", "Secure User Identification [N]one, [P]assed, [F]ailed", "S" ) ;
3100               ( Str, "srh", "IP address", "IP address" ) ;
3101               ] @ (if Geoip.active () then [( Str, "srh", "Country Code/Name", "CC" )] else []) @ [
3102               ( Num, "srh ar", "Total UL bytes to this client for all files", "tUL");
3103               ( Num, "srh ar", "Total DL bytes from this client for all files", "tDL");
3104               ( Num, "srh ar", "Session UL bytes to this client for all files", "sUL");
3105               ( Num, "srh ar", "Session DL bytes from this client for all files", "sDL");
3106               ( Str, "srh", "Filename", "Filename" ) ]);
3107
3108         let counter = ref 0 in
3109
3110         List.iter
3111           (fun file ->
3112             if (CommonFile.file_downloaders file o !counter) then counter := 0 else counter := 1;
3113         ) (user2_filter_files !!files o.conn_user.ui_user);
3114
3115         if use_html_mods o then Printf.bprintf buf "\\</table\\>\\</div\\>";
3116
3117         ""
3118     ) , ":\t\t\t\tdisplay downloaders list";
3119
3120     "verify_chunks", Arg_multiple (fun args o ->
3121         let buf = o.conn_buf in
3122         match args with
3123           [arg] ->
3124             let num = int_of_string arg in
3125               List.iter
3126                 (fun file -> if (as_file_impl file).impl_file_num = num then
3127                     begin
3128                       Printf.bprintf  buf "Verifying Chunks of file %d" num;
3129                       file_check file;
3130                     end
3131               )
3132               !!files;
3133             ""
3134         | _ -> ();
3135             _s "done"
3136     ), "<num> :\t\t\tverify chunks of file <num>";
3137
3138     "pause", Arg_multiple (fun args o ->
3139         if args = ["all"] && user2_is_admin o.conn_user.ui_user then
3140           List.iter (fun file ->
3141               file_pause file (admin_user ())
3142           ) !!files
3143         else
3144           List.iter (fun num ->
3145               let num = int_of_string num in
3146               List.iter (fun file ->
3147                   if (as_file_impl file).impl_file_num = num then
3148                       file_pause file o.conn_user.ui_user
3149               ) !!files) args; ""
3150     ), "<num|all> :\t\t\tpause a download (use arg 'all' for all files)";
3151
3152     resume_alias "resume";
3153     resume_alias "unpause";
3154     resume_alias "continue";
3155
3156     "release", Arg_one (fun arg o ->
3157         let num = int_of_string arg in
3158         let file = file_find num in
3159         let old_state = file_release file in
3160         set_file_release file (not (file_release file)) o.conn_user.ui_user;
3161         Printf.sprintf "%s, file: %s"
3162           (match old_state, file_release file with
3163               true, false -> "deactivated release state"
3164             | false, true -> "activated release state"
3165             | _ -> "unchanged status, enough rights?")
3166           (shorten (file_best_name file) !!max_name_len)
3167     ), "<num> :\t\t\t\tchange release state of a download";
3168
3169     "commit", Arg_none (fun o ->
3170         List.iter (fun file ->
3171             file_commit file
3172         ) !!done_files;
3173         let buf = o.conn_buf in
3174         if o.conn_output = HTML then
3175           html_mods_table_one_row buf "serversTable" "servers" [
3176             ("", "srh", "Committed"); ]
3177         else
3178           Printf.bprintf buf "Committed";
3179         ""
3180     ) , ":\t\t\t\t$bmove downloaded files to incoming directory$n";
3181
3182     "vd", Arg_multiple (fun args o ->
3183         let buf = o.conn_buf in
3184         let list = user2_filter_files !!files o.conn_user.ui_user in
3185         let filelist = List2.tail_map file_info list in
3186         match args with
3187           | ["queued"] ->
3188               let list = List.filter ( fun f -> f.file_state = FileQueued ) filelist in
3189               DriverInteractive.display_active_file_list buf o list;
3190               ""
3191           | ["paused"] ->
3192               let list = List.filter ( fun f -> f.file_state = FilePaused ) filelist in
3193               DriverInteractive.display_active_file_list buf o list;
3194               ""
3195           | ["downloading"] ->
3196               let list = List.filter ( fun f -> f.file_state = FileDownloading ) filelist in
3197               DriverInteractive.display_file_list buf o list;
3198               ""
3199           | [arg] ->
3200             let num = int_of_string arg in
3201             if o.conn_output = HTML then
3202               begin
3203                 if use_html_mods o then
3204                   Printf.bprintf buf "\\<div class=\\\"sourcesTable al\\\"\\>\\<table cellspacing=0 cellpadding=0\\>
3205                                 \\<tr\\>\\<td\\>
3206                                 \\<table cellspacing=0 cellpadding=0 width=100%%\\>\\<tr\\>
3207                                 \\<td nowrap class=\\\"fbig\\\"\\>\\<a onclick=\\\"javascript:window.location.href='files'\\\"\\>Display all files\\</a\\>\\</td\\>
3208                                 \\<td nowrap class=\\\"fbig\\\"\\>\\<a onClick=\\\"javascript:parent.fstatus.location.href='submit?q=verify_chunks+%d'\\\"\\>Verify chunks\\</a\\>\\</td\\>
3209                                 \\<td nowrap class=\\\"fbig\\\"\\>\\<a onClick=\\\"javascript:window.location.href='preview_download?q=%d'\\\"\\>Preview\\</a\\>\\</td\\>
3210                                 \\<td nowrap class=\\\"fbig\\\"\\>\\<a onClick=\\\"javascript:window.location.href='submit?q=debug_get_download_prio+%d'\\\"\\>Debug\\</a\\>\\</td\\>
3211                                 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript:window.location.reload()\\\"\\>Reload\\</a\\>\\</td\\>
3212                                 \\<td class=downloaded width=100%%\\>\\</td\\>
3213                                 \\</tr\\>\\</table\\>
3214                                 \\</td\\>\\</tr\\>
3215                                 \\<tr\\>\\<td\\>" num num num
3216                 else begin
3217                     Printf.bprintf  buf "\\<a href=\\\"files\\\"\\>Display all files\\</a\\>  ";
3218                     Printf.bprintf  buf "\\<a href=\\\"submit?q=verify_chunks+%d\\\"\\>Verify chunks\\</a\\>  " num;
3219                     Printf.bprintf  buf "\\<a href=\\\"submit?q=preview+%d\\\"\\>Preview\\</a\\> \n " num;
3220                   end
3221               end;
3222             List.iter
3223               (fun file -> if (as_file_impl file).impl_file_num = num then
3224                   CommonFile.file_print file o)
3225             list;
3226             List.iter
3227               (fun file -> if (as_file_impl file).impl_file_num = num then
3228                   CommonFile.file_print file o)
3229             !!done_files;
3230             ""
3231         | _ ->
3232             DriverInteractive.display_file_list buf o filelist;
3233             ""
3234     ), "[<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";
3235
3236     "preview", Arg_one (fun arg o ->
3237
3238         let num = int_of_string arg in
3239         let file = file_find num in
3240         file_preview file;
3241         _s "done"
3242     ), "<file number> :\t\t\tstart previewer for file <file number>";
3243
3244     "rename", Arg_two (fun arg new_name o ->
3245         let num = int_of_string arg in
3246         try
3247           let file = file_find num in
3248           set_file_best_name file new_name "" 0;
3249           Printf.sprintf (_b "Download %d renamed to %s") num (file_best_name file)
3250         with e -> Printf.sprintf (_b "No file number %d, error %s") num (Printexc2.to_string e)
3251     ), "<num> \"<new name>\" :\t\tchange name of download <num> to <new name>";
3252
3253     "filenames_variability", Arg_none (fun o ->
3254       let list = List2.tail_map file_info
3255         (user2_filter_files !!files o.conn_user.ui_user) in
3256       DriverInteractive.filenames_variability o list;
3257       _s "done"
3258     ), ":\t\t\ttell which files have several very different names";
3259
3260     "dllink", Arg_multiple (fun args o ->
3261         let url = String2.unsplit args ' ' in
3262         dllink_parse (o.conn_output = HTML) url o.conn_user.ui_user
3263         ), "<link> :\t\t\t\tdownload ed2k, sig2dat, torrent or other link";
3264
3265     "dllinks", Arg_one (fun arg o ->
3266         let result = Buffer.create 100 in
3267         let file = File.to_string arg in
3268         let lines = String2.split_simplify file '\n' in
3269         List.iter (fun line ->
3270           Buffer.add_string result (dllink_parse (o.conn_output = HTML) line o.conn_user.ui_user);
3271           Buffer.add_string result (if o.conn_output = HTML then "\\<P\\>" else "\n")
3272         ) lines;
3273         (Buffer.contents result)
3274     ), "<file> :\t\t\tdownload all the links contained in the file";
3275
3276   ]
3277
3278 (*************************************************************************)
3279 (*                                                                       *)
3280 (*                         Driver/Users                                  *)
3281 (*                                                                       *)
3282 (*************************************************************************)
3283
3284 let _ =
3285   register_commands "Driver/Users" [
3286
3287     "useradd", Arg_multiple (fun args o ->
3288         let group_convert g =
3289           try
3290             if String.lowercase g = "none" || g = "" then None
3291             else Some (user2_group_find g).group_name
3292           with Not_found -> None
3293         in
3294         let (user, pass, group, cdir, mail, mdl) =
3295           match args with
3296           | [user; pass; group; cdir; mail; mdl] ->
3297               user, pass, (group_convert group), cdir, mail, (try int_of_string mdl with _ -> 0)
3298           | [user; pass; group; cdir; mail] -> user, pass, (group_convert group), cdir, mail, 0
3299           | [user; pass; group; cdir] -> user, pass, (group_convert group), cdir, "", 0
3300           | [user; pass; group] -> user, pass, (group_convert group), "", "", 0
3301           | [user; pass] -> user, pass, Some admin_group_name, "", "", 0
3302           | _ -> failwith "wrong parameters"
3303         in
3304         if user2_is_admin o.conn_user.ui_user
3305           || o.conn_user.ui_user.user_name = user then
3306           if user2_user_exists user then
3307             begin
3308               user2_user_set_password (user2_user_find user) pass;
3309               print_command_result o (Printf.sprintf "Password of user %s changed" user)
3310             end
3311           else
3312             begin
3313               match group with
3314               | None -> user2_user_add user (Md4.string pass)
3315                           ~groups:[] ~default_group:None ~commit_dir:cdir ~mail:mail ~max_dl:mdl ();
3316                         print_command_result o (Printf.sprintf "User %s added" user)
3317               | Some g -> user2_user_add user (Md4.string pass)
3318                             ~groups:[g] ~default_group:group ~commit_dir:cdir ~mail:mail ~max_dl:mdl ();
3319                           print_command_result o (Printf.sprintf "User %s added, group %s" user g)
3320             end
3321         else
3322           print_command_result o "You are not allowed to add users";
3323         _s ""
3324     ), "<user> <passwd> [<group>] [<commit_dir>] [<mail>] [<max_downloads>]: add new mldonkey user/change user password";
3325
3326     "userdel", Arg_one (fun user o ->
3327         if user <> o.conn_user.ui_user.user_name then
3328           if user2_is_admin o.conn_user.ui_user then
3329             if user = (admin_user ()).user_name then
3330               print_command_result o "User 'admin' can not be removed"
3331             else
3332               try
3333                 let u = user2_user_find user in
3334                 let n = user2_num_user_dls u in
3335                 if n <> 0 then print_command_result o
3336                   (Printf.sprintf "User %s has %d downloads, can not delete" user n)
3337                 else
3338                   user2_user_remove user;
3339                   print_command_result o (Printf.sprintf "User %s removed" user)
3340               with
3341                 Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3342           else
3343             print_command_result o "You are not allowed to remove users"
3344         else
3345           print_command_result o "You can not remove yourself";
3346         _s ""
3347     ), "<user> :\t\t\tremove a mldonkey user";
3348
3349     "usergroupadd", Arg_two (fun user group o ->
3350         if user2_is_admin o.conn_user.ui_user then
3351           begin
3352             try
3353               let u = user2_user_find user in
3354                 begin
3355                   try
3356                     let g = user2_group_find group in
3357                     if List.mem g u.user_groups then
3358                       print_command_result o
3359                         (Printf.sprintf "User %s already member of group %s" u.user_name g.group_name)
3360                     else
3361                       begin
3362                         user2_user_add_group u g;
3363                         print_command_result o
3364                           (Printf.sprintf "Added group %s to user %s" g.group_name u.user_name)
3365                       end
3366                   with Not_found -> print_command_result o (Printf.sprintf "Group %s does not exist" group)
3367                 end
3368             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3369           end
3370         else
3371           print_command_result o "You are not allowed to add groups to a user";
3372         _s ""
3373     ), "<user> <group> :\t\tadd a group to a mldonkey user";
3374
3375     "usergroupdel", Arg_two (fun user group o ->
3376         if user2_is_admin o.conn_user.ui_user
3377           || o.conn_user.ui_user.user_name = user then
3378           begin
3379             try
3380               let u = user2_user_find user in
3381                 begin
3382                   try
3383                     let g = user2_group_find group in
3384                     if not (List.mem g u.user_groups) then
3385                       print_command_result o (Printf.sprintf "User %s is not member of group %s" user group)
3386                     else
3387                       if Some g = u.user_default_group then
3388                         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)
3389                       else
3390                         begin
3391                           let counter = ref 0 in
3392                           List.iter (fun f ->
3393                             if file_owner f = u && file_group f = Some g then
3394                               begin
3395                                 incr counter;
3396                                 set_file_group f u.user_default_group
3397                               end
3398                           ) !!files;
3399                           user2_user_remove_group (user2_user_find user) (user2_group_find group);
3400                           print_command_result o (Printf.sprintf "Removed group %s from user %s%s"
3401                             group user
3402                             (if !counter = 0 then "" else Printf.sprintf ", changed file_group of %d file%s to default_group %s"
3403                                !counter (Printf2.print_plural_s !counter) (user2_print_group u.user_default_group)))
3404                         end
3405                   with Not_found -> print_command_result o (Printf.sprintf "Group %s does not exist" group)
3406                 end
3407             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3408           end
3409
3410         else
3411           print_command_result o "You are not allowed to remove groups from a user";
3412         _s ""
3413     ), "<user> <group> :\t\tremove a group from a mldonkey user";
3414
3415     "userdgroup", Arg_two (fun user group o ->
3416         if user2_is_admin o.conn_user.ui_user
3417           || o.conn_user.ui_user.user_name = user then
3418           begin
3419             try
3420               let u = user2_user_find user in
3421                 begin
3422                   try
3423                     let g = if String.lowercase group = "none" then None else Some (user2_group_find group) in
3424                     let update_dgroup () =
3425                       match g with
3426                         None -> true
3427                       | Some g1 when List.mem g1 u.user_groups -> true
3428                       | _ -> false
3429                     in
3430                     if update_dgroup () then
3431                       begin
3432                         user2_user_set_default_group u g;
3433                         print_command_result o (Printf.sprintf "Changed default group of user %s to group %s" u.user_name (user2_print_user_default_group u))
3434                       end
3435                     else print_command_result o (Printf.sprintf "User %s is not member of group %s" u.user_name group)
3436                   with Not_found -> print_command_result o (Printf.sprintf "Group %s does not exist" group)
3437                 end
3438             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3439           end
3440         else
3441           print_command_result o "You are not allowed to change default group";
3442         _s ""
3443     ), "<user> <group|None> :\tchange user default group";
3444
3445     "passwd", Arg_one (fun passwd o ->
3446         begin
3447           try
3448             let u = user2_user_find o.conn_user.ui_user.user_name in
3449             user2_user_set_password u passwd;
3450             print_command_result o (Printf.sprintf "Password of user %s changed" u.user_name)
3451           with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" o.conn_user.ui_user.user_name)
3452         end;
3453         _s ""
3454     ), "<passwd> :\t\t\tchange own password";
3455
3456     "usermail", Arg_two (fun user mail o ->
3457         if user2_is_admin o.conn_user.ui_user
3458           || o.conn_user.ui_user.user_name = user then
3459           begin
3460             try
3461               let u = user2_user_find user in
3462               user2_user_set_mail u mail;
3463               print_command_result o (Printf.sprintf "User %s has new mail %s" user mail)
3464             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3465           end
3466         else print_command_result o "You are not allowed to change mail addresses";
3467         _s ""
3468     ), "<user> <mail> :\t\tchange user mail address";
3469
3470     "userdls", Arg_two (fun user dls o ->
3471         if user2_is_admin o.conn_user.ui_user then
3472           begin
3473             try
3474               let u = user2_user_find user in
3475               user2_user_set_dls u (int_of_string dls);
3476               print_command_result o (Printf.sprintf "User %s has now %s downloads allowed" user (user2_print_user_dls (user2_user_find user)))
3477             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3478           end
3479         else print_command_result o "You are not allowed to change this value";
3480         _s ""
3481     ), "<user> <num> :\t\t\tchange number of allowed concurrent downloads";
3482
3483     "usercommit", Arg_two (fun user dir o ->
3484         if user2_is_admin o.conn_user.ui_user
3485           || o.conn_user.ui_user.user_name = user then
3486           begin
3487             try
3488               let u = user2_user_find user in
3489               user2_user_set_commit_dir u dir;
3490               print_command_result o (Printf.sprintf "User %s has new commit dir %s" u.user_name u.user_commit_dir)
3491             with Not_found -> print_command_result o (Printf.sprintf "User %s does not exist" user)
3492           end
3493         else print_command_result o "You are not allowed to change this value";
3494         _s ""
3495     ), "<user> <dir> :\t\tchange user specific commit directory";
3496
3497     "groupadd", Arg_two (fun group admin o ->
3498         let g_admin =
3499           try
3500             bool_of_string admin
3501           with _ -> false
3502         in
3503         if user2_is_admin o.conn_user.ui_user then
3504           if user2_group_exists group then
3505             print_command_result o (Printf.sprintf "Group %s already exists" group)
3506           else
3507             begin
3508               user2_group_add group g_admin;
3509               print_command_result o (Printf.sprintf "Group %s added" group)
3510             end
3511         else
3512           print_command_result o "You are not allowed to add a group";
3513         _s ""
3514     ), "<group> <admin: true|false> :\tadd new mldonkey group";
3515
3516     "groupdel", Arg_one (fun group o ->
3517         if user2_is_admin o.conn_user.ui_user then
3518           begin
3519             try
3520               let g = user2_group_find group in
3521               let g_dls = user2_num_group_dls g in
3522               let g_mem = user2_num_group_members g in
3523               if g_dls <> 0 then
3524                 print_command_result o
3525                   (Printf.sprintf "Can not remove group %s, it has %d download%s"
3526                     group g_dls (Printf2.print_plural_s g_dls))
3527               else
3528                 if g_mem <> 0 then
3529                   print_command_result o
3530                     (Printf.sprintf "Can not remove group %s, it has %d member%s"
3531                       group g_mem (Printf2.print_plural_s g_mem))
3532                 else
3533                   if g = admin_group () then
3534                     print_command_result o (Printf.sprintf "Can not remove system group %s" group)
3535                   else
3536                     begin
3537                       user2_group_remove g;
3538                       print_command_result o (Printf.sprintf "Removed group %s" group)
3539                     end
3540             with Not_found -> print_command_result o (Printf.sprintf "Group %s does not exist" group)
3541           end
3542         else
3543           print_command_result o "You are not allowed to remove users";
3544           _s ""
3545     ), "<group> :\t\t\tremove an unused mldonkey group";
3546
3547     "groupadmin", Arg_two (fun group admin o ->
3548         if user2_is_admin o.conn_user.ui_user then
3549           begin
3550             try
3551               let g = user2_group_find group in
3552               if g = admin_group () then
3553                 print_command_result o (Printf.sprintf "Can not change state of system group %s" group)
3554               else
3555                 begin
3556                   user2_group_admin g (bool_of_string admin);
3557                   print_command_result o (Printf.sprintf "Changed admin status of group %s to %b" g.group_name g.group_admin)
3558                 end
3559             with Not_found -> print_command_result o (Printf.sprintf "Group %s does not exist" group)
3560           end
3561         else
3562           print_command_result o "You are not allowed to change group admin status";
3563         _s ""
3564     ), "<group> <true|false> :\tchange group admin status";
3565
3566     "users", Arg_none (fun o ->
3567         let buf = o.conn_buf in
3568         if user2_is_admin o.conn_user.ui_user then begin
3569
3570         if use_html_mods o then begin
3571             Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
3572 \\<tr\\>\\<td\\>
3573 \\<table cellspacing=0 cellpadding=0  width=100%%\\>\\<tr\\>
3574 \\<td class=downloaded width=100%%\\>\\</td\\>
3575 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript: {
3576                    var getdir = prompt('Input: <user> <pass>','user pass <group> <commit_dir>')
3577                    var reg = new RegExp (' ', 'gi') ;
3578                    var outstr = getdir.replace(reg, '+');
3579                    parent.fstatus.location.href='submit?q=useradd+' + outstr;
3580                    setTimeout('window.location.reload()',1000);
3581                     }\\\"\\>Add user\\</a\\>
3582 \\</td\\>\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\<tr\\>\\<td\\>";
3583
3584             html_mods_table_header buf "sharesTable" "shares" [
3585               ( Str, "srh ac", "Click to remove user", "Remove" ) ;
3586               ( Str, "srh", "Username", "User" ) ;
3587               ( Str, "srh ac", "Only member of admin groups have admin rights", "Admin" ) ;
3588               ( Str, "srh", "Member of groups", "Groups" ) ;
3589               ( Str, "srh", "Default group", "Default group" ) ;
3590               ( Str, "srh", "Mail address", "Email" ) ;
3591               ( Str, "srh", "Commit dir", "Commit dir" ) ;
3592               ( Num, "srh ar", "Download quota", "Max DLs" ) ;
3593               ( Num, "srh ar", "Download count", "DLs" ) ];
3594
3595             html_mods_cntr_init ();
3596             user2_users_iter (fun user ->
3597                 let u_dls = user2_num_user_dls user in
3598                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>"
3599                 (html_mods_cntr ());
3600                 if user <> (admin_user ()) && (u_dls = 0) then Printf.bprintf buf
3601 "\\<td title=\\\"Click to remove user\\\"
3602 onMouseOver=\\\"mOvr(this);\\\"
3603 onMouseOut=\\\"mOut(this);\\\"
3604 onClick=\\\'javascript:{
3605 parent.fstatus.location.href=\\\"submit?q=userdel+\\\\\\\"%s\\\\\\\"\\\";
3606 setTimeout(\\\"window.location.reload()\\\",1000);}'
3607 class=\\\"srb\\\"\\>Remove\\</td\\>" user.user_name
3608                 else Printf.bprintf buf
3609 "\\<td title=\\\"%s\\\"
3610 class=\\\"srb\\\"\\>------\\</td\\>"
3611   (if user.user_name = (admin_user ()).user_name then "Admin user can not be removed" else
3612      if u_dls <> 0 then Printf.sprintf "User has %d download%s" u_dls
3613      (Printf2.print_plural_s u_dls) else "");
3614                 html_mods_td buf [
3615                   ("", "sr", user.user_name);
3616                   ("", "sr ac", Printf.sprintf "%b" (user2_is_admin user));
3617                   ("Click to remove group", "sr",
3618                       let buf1 = Buffer.create 100 in
3619                       user2_user_groups_iter user (fun group ->
3620                         if user2_default_group_matches_group user.user_default_group group then
3621                           Printf.bprintf buf1 "%s " group.group_name
3622                         else
3623                           Printf.bprintf buf1
3624 "\\<a onMouseOver=\\\"mOvr(this);\\\"
3625 onMouseOut=\\\"mOut(this);\\\"
3626 onClick=\\\'javascript:{
3627 parent.fstatus.location.href=\\\"submit?q=usergroupdel+\\\\\\\"%s\\\\\\\"+\\\\\\\"%s\\\\\\\"\\\";
3628 setTimeout(\\\"window.location.reload()\\\",1000);}'
3629 class=\\\"srb\\\"\\>%s\\</a\\> " user.user_name group.group_name group.group_name
3630                       );
3631                       Buffer.contents buf1);
3632                   ("", "sr", user2_print_user_default_group user);
3633                   ("", "sr", user.user_mail);
3634                   ("", "sr", user.user_commit_dir);
3635                   ("", "sr ar", user2_print_user_dls user);
3636                   ("", "sr ar", string_of_int u_dls)];
3637             );
3638             Printf.bprintf buf "\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
3639             print_option_help o userlist;
3640             Printf.bprintf buf "\\<P\\>";
3641
3642             Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table class=main cellspacing=0 cellpadding=0\\>
3643 \\<tr\\>\\<td\\>
3644 \\<table cellspacing=0 cellpadding=0  width=100%%\\>\\<tr\\>
3645 \\<td class=downloaded width=100%%\\>\\</td\\>
3646 \\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript: {
3647                    var getdir = prompt('Input: <group> <admin: true|false>','group true')
3648                    var reg = new RegExp (' ', 'gi') ;
3649                    var outstr = getdir.replace(reg, '+');
3650                    parent.fstatus.location.href='submit?q=groupadd+' + outstr;
3651                    setTimeout('window.location.reload()',1000);
3652                     }\\\"\\>Add group\\</a\\>
3653 \\</td\\>\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\<tr\\>\\<td\\>";
3654
3655             html_mods_table_header buf "sharesTable" "shares" [
3656               ( Str, "srh ac", "Click to remove group", "Remove" );
3657               ( Str, "srh", "Groupname", "Group" );
3658               ( Str, "srh ac", "Click to change status", "Admin" );
3659               ( Num, "srh ar", "Member count", "Mem" );
3660               ( Num, "srh ar", "Download count", "DLs" ) ];
3661
3662             html_mods_cntr_init ();
3663             user2_groups_iter (fun group ->
3664                 let g_dls = user2_num_group_dls group in
3665                 let g_mem = user2_num_group_members group in
3666                 let is_sys_group = group = admin_group () in
3667                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
3668                 if g_dls = 0 && g_mem = 0 && not is_sys_group then Printf.bprintf buf
3669 "\\<td title=\\\"Click to remove group\\\"
3670 onMouseOver=\\\"mOvr(this);\\\" onMouseOut=\\\"mOut(this);\\\" onClick=\\\'javascript:{
3671 parent.fstatus.location.href=\\\"submit?q=groupdel+\\\\\\\"%s\\\\\\\"\\\";
3672 setTimeout(\\\"window.location.reload()\\\",1000);}'
3673 class=\\\"srb\\\"\\>Remove\\</td\\>" group.group_name
3674                 else
3675                     Printf.bprintf buf "\\<td title=\\\"%s\\\" class=\\\"srb\\\"\\>------\\</td\\>"
3676                       (if g_dls <> 0 then Printf.sprintf "Group is assigned to %d download%s"
3677                                             g_dls (Printf2.print_plural_s g_dls) else
3678                         if g_mem <> 0 then Printf.sprintf "Group has %d member%s"
3679                                             g_mem (Printf2.print_plural_s g_mem) else
3680                         if is_sys_group then "System group can not be removed" else "");
3681
3682                 html_mods_td buf [("", "sr", group.group_name)];
3683
3684                 if is_sys_group then
3685                   html_mods_td buf [("System group, can not change state", "sr ac", Printf.sprintf "%b" group.group_admin)]
3686                 else Printf.bprintf buf
3687 "\\<td title=\\\"Change admin status\\\"
3688 onMouseOver=\\\"mOvr(this);\\\" onMouseOut=\\\"mOut(this);\\\" onClick=\\\'javascript:{
3689 parent.fstatus.location.href=\\\"submit?q=groupadmin+\\\\\\\"%s\\\\\\\"+\\\\\\\"%s\\\\\\\"\\\";
3690 setTimeout(\\\"window.location.reload()\\\",1000);}'
3691 class=\\\"sr ac\\\"\\>%s\\</td\\>"
3692   group.group_name
3693   (if group.group_admin then "false" else "true")
3694   (if group.group_admin then "true" else "false");
3695
3696                 html_mods_td buf [
3697                   ("", "sr ar", Printf.sprintf "%d" (user2_num_group_members group));
3698                   ("", "sr ar", Printf.sprintf "%d" g_dls);
3699                   ]);
3700
3701             Printf.bprintf buf "\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
3702             print_option_help o grouplist;
3703             Printf.bprintf buf "\\<P\\>";
3704
3705             Buffer.add_string buf "\\<div class=\\\"cs\\\"\\>";
3706             html_mods_table_header buf "helpTable" "results" [];
3707             Buffer.add_string buf "\\<tr\\>";
3708             html_mods_td buf [
3709               ("", "srh", "");
3710               ("", "srh", "Commands to manipulate user data");
3711               ("", "srh", ""); ];
3712             Buffer.add_string buf "\\</tr\\>";
3713             html_mods_cntr_init ();
3714             let list = Hashtbl2.to_list2 commands_by_kind in
3715             let list = List.sort (fun (s1,_) (s2,_) -> compare s1 s2) list in
3716             List.iter (fun (s,list) ->
3717               if s = "Driver/Users" then
3718               let list = List.sort (fun (s1,_) (s2,_) -> compare s1 s2) !list in
3719               List.iter (fun (cmd, help) ->
3720                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
3721                 html_mods_td buf [
3722                   ("", "sr", "\\<a href=\\\"submit?q=" ^ cmd ^
3723                     "\\\"\\>" ^ cmd ^ "\\</a\\>");
3724                   ("", "srw", Str.global_replace (Str.regexp "\n") "\\<br\\>" help);
3725                   ("", "sr", "\\<a href=\\\"http://mldonkey.sourceforge.net/" ^ (String2.upp_initial cmd) ^
3726                     "\\\"\\>wiki\\</a\\>"); ];
3727                 Printf.bprintf buf "\\</tr\\>\n"
3728               ) list
3729           ) list
3730           end
3731         else begin
3732           let list = ref [] in
3733           user2_users_iter (fun user -> list := [|
3734             user.user_name;
3735             Printf.sprintf "%b" (user2_is_admin user);
3736             (user2_print_user_groups " " user);
3737             (user2_print_user_default_group user);
3738             user.user_mail;
3739             user.user_commit_dir;
3740             (user2_print_user_dls user);
3741             (string_of_int (user2_num_user_dls user));
3742           |] :: !list );
3743           print_table_text buf
3744           [|
3745             Align_Left; Align_Left; Align_Left; Align_Left; Align_Left; Align_Left; Align_Right; Align_Right |]
3746           [|
3747             "User";
3748             "Admin";
3749             "Groups";
3750             "Dgroup";
3751             "Email";
3752             "Commit dir";
3753             "Max dls";
3754             "Dls";
3755           |] (List.rev !list);
3756           Printf.bprintf buf "\n";
3757           let list = ref [] in
3758           user2_groups_iter (fun group -> list := [|
3759             group.group_name;
3760             Printf.sprintf "%b" group.group_admin;
3761             (string_of_int (user2_num_group_members group));
3762             (string_of_int (user2_num_group_dls group));
3763           |] :: !list );
3764           print_table_text buf
3765           [|
3766             Align_Left; Align_Left; Align_Right; Align_Right |]
3767           [|
3768             "Group";
3769             "Admin";
3770             "Members";
3771             "Downloads";
3772           |] (List.rev !list);
3773           end
3774         end else print_command_result o "You are not allowed to list users";
3775           _s ""
3776     ), ":\t\t\t\t\tprint users";
3777
3778     "whoami", Arg_none (fun o ->
3779         print_command_result o o.conn_user.ui_user.user_name;
3780         _s ""
3781     ), ":\t\t\t\tprint logged-in user name";
3782
3783     "groups", Arg_none (fun o ->
3784         print_command_result o (user2_print_user_groups " " o.conn_user.ui_user);
3785         _s ""
3786     ), ":\t\t\t\tprint groups of logged-in user";
3787
3788     "dgroup", Arg_none (fun o ->
3789         print_command_result o (user2_print_user_default_group o.conn_user.ui_user);
3790         _s ""
3791     ), ":\t\t\t\tprint default group of logged-in user";
3792
3793     "chgrp", Arg_two (fun group filenum o ->
3794         let num = int_of_string filenum in
3795         begin try
3796           let file = file_find num in
3797           if String.lowercase group = "none" then
3798             begin
3799               if user2_allow_file_admin file o.conn_user.ui_user then
3800                 begin
3801                   set_file_group file None;
3802                   print_command_result o (Printf.sprintf (_b "Changed group of download %d to %s") num group)
3803                 end
3804               else
3805                 print_command_result o (Printf.sprintf (_b "You are not allowed to change group of download %d to %s") num group)
3806             end
3807           else
3808             begin
3809               try
3810                 let g = user2_group_find group in
3811                 if user2_allow_file_admin file o.conn_user.ui_user &&
3812                    List.mem g (file_owner file).user_groups then
3813                   begin
3814                     set_file_group file (Some g);
3815                     print_command_result o (Printf.sprintf (_b "Changed group of download %d to %s") num group)
3816                   end
3817                 else
3818                   print_command_result o (Printf.sprintf (_b "You are not allowed to change group of download %d to %s") num group)
3819               with Not_found -> print_command_result o (Printf.sprintf (_b "Group %s not found") group)
3820             end
3821         with Not_found -> print_command_result o (Printf.sprintf (_b "File %d not found") num)
3822         end;
3823         _s ""
3824     ), "<group> <num> :\t\t\tchange group of download <num> to <group>, use group = none for private file";
3825
3826     "chown", Arg_two (fun user filenum o ->
3827         let num = int_of_string filenum in
3828         begin
3829           try
3830             let file = file_find num in
3831             begin
3832               try
3833                 let u = user2_user_find user in
3834                 if user2_is_admin o.conn_user.ui_user then
3835                   begin
3836                     set_file_owner file u;
3837                     match file_group file with
3838                     | None ->
3839                         print_command_result o (Printf.sprintf (_b "Changed owner of download %d to %s") num user)
3840                     | Some g ->
3841                         if List.mem g u.user_groups then
3842                           print_command_result o (Printf.sprintf (_b "Changed owner of download %d to %s") num user)
3843                         else
3844                           begin
3845                             set_file_group file u.user_default_group;
3846                             print_command_result o (Printf.sprintf
3847                               (_b "owner %s is not member of file_group %s, changing file_group to user_default_group %s")
3848                               user g.group_name (user2_print_user_default_group u))
3849                           end
3850                   end
3851                 else
3852                   print_command_result o (Printf.sprintf (_b "You are not allowed to change owner of download %d to %s") num user)
3853               with Not_found -> print_command_result o (Printf.sprintf (_b "User %s not found") user)
3854             end
3855           with Not_found -> print_command_result o (Printf.sprintf (_b "File %d not found") num)
3856         end;
3857         _s ""
3858     ), "<user> <num> :\t\t\tchange owner of download <num> to <user>";
3859
3860   ]
3861
3862
3863 (*************************************************************************)
3864 (*                                                                       *)
3865 (*                         Driver/Xpert                                  *)
3866 (*                                                                       *)
3867 (*************************************************************************)
3868
3869 let _ =
3870   register_commands "Driver/Xpert"
3871     [
3872
3873 (*
3874       "debug_set_download_prio", Arg_two
3875         (fun arg priostring  o ->
3876            let num = int_of_string arg in
3877            let file = file_find num in
3878              CommonSwarming.set_swarmer_chunk_priorities file priostring;
3879              "set prio"
3880
3881         ), ":\t\t\t\t\tset block download priorities for a file. 0=never download, >0=download largest prio first";
3882 *)
3883
3884       "debug_get_download_prio", Arg_one
3885         (fun arg o ->
3886            let buf = o.conn_buf in
3887            let pr fmt = Printf.bprintf buf fmt in
3888            let num = int_of_string arg in
3889            let file = file_find num in
3890            let swarmer = CommonSwarming.file_swarmer file in
3891            let prio = CommonSwarming.get_swarmer_block_priorities swarmer in
3892            let downloaded = CommonSwarming.get_swarmer_block_verified swarmer in
3893            pr "\\<code\\>";
3894            pr "priorities: ";
3895            String.iter (fun c ->
3896              let c = max 0 (min 9 (Char.code c)) in
3897              let c = Char.chr (c + Char.code '0') in
3898              Buffer.add_char buf c) prio;
3899            pr "\n";
3900            pr "downloaded: %s\n" (VB.to_string downloaded);
3901
3902            Unix32.subfile_tree_map (file_fd file)
3903            begin fun fname start length current_length ->
3904              let stop = if length <> 0L then (start ++ length -- 1L) else start in
3905              let blockstart = try CommonSwarming.compute_block_num swarmer start with _ -> 0 in
3906              let blockend = try CommonSwarming.compute_block_num swarmer stop with _ -> 0 in
3907              pr "sf:%5Ld ef:%5Ld l:%Ld cl:%Ld > sc:%5d ec:%5d filename:%-30s \n"
3908                       start
3909                       stop
3910                       length
3911                       current_length
3912                       blockstart
3913                       blockend
3914                       fname;
3915              (*make a chunk downloaded status string for a subfile*)
3916              (try
3917                 for i = blockstart to blockend do
3918                   Buffer.add_char buf (VB.state_to_char (VB.get downloaded i));
3919                 done;
3920                 pr "\n";
3921               with _ -> ())
3922            end;
3923            pr "\\</code\\>";
3924            "";
3925     ), ":\t\t\t\t\tget file block priorities for a file, and show subfile completion status";
3926
3927     "set_subfile_prio", Arg_multiple
3928       (fun args o ->
3929         match args with
3930         | filenum :: priochar :: subfilestart :: q ->
3931             let filenum = int_of_string filenum in
3932             let priochar = int_of_string priochar in
3933             let subfilestart = int_of_string subfilestart in
3934             let subfileend =
3935               match q with
3936               | subfileend :: _ -> int_of_string subfileend
3937               | _ -> subfilestart in
3938             let file = file_find filenum in
3939             let swarmer = CommonSwarming.file_swarmer file in
3940 (*
3941             let priostring =
3942               CommonSwarming.get_swarmer_chunk_priorities file in
3943 *)
3944             let subfile1 = Unix32.find_file_index (file_fd file) subfilestart in
3945             let subfile2 = Unix32.find_file_index (file_fd file) subfileend in
3946             let subfile_pos = function (_,y,_) -> y in
3947             let subfile_len = function (_,_,y) -> y in
3948             let start = subfile_pos subfile1 in
3949             let stop =
3950               subfile_pos subfile2 ++ subfile_len subfile2
3951 (*                 -- if subfile_len subfile2 > 0L then 1L else 0L  *)
3952             in
3953 (*
3954             Printf.bprintf buf "file %s\nstart %Ld stop %Ld prio %u\n"
3955               swarmer.CommonSwarming.s_filename start stop priochar;
3956 *)
3957             CommonSwarming.swarmer_set_interval swarmer (start,stop,priochar);
3958             (* show file *)
3959 (*             execute_command !CommonNetwork.network_commands o "vd" [string_of_int filenum]; *)
3960             string_of_int priochar
3961         | _ -> bad_number_of_args "" ""
3962     ), "set_subfile_prio <download id> <prio> <1st subfile (0-based)> <optional last subfile>";
3963
3964     "reload_messages", Arg_none (fun o ->
3965         CommonMessages.load_message_file ();
3966         "\\<script type=\\\"text/javascript\\\"\\>top.window.location.reload();\\</script\\>"
3967     ), ":\t\t\treload messages file";
3968
3969     "log", Arg_none (fun o ->
3970         let buf = o.conn_buf in
3971         log_to_buffer buf;
3972         _s "------------- End of log"
3973     ), ":\t\t\t\t\tdump current log state to console";
3974
3975     "ansi", Arg_one (fun arg o ->
3976         let b = bool_of_string arg in
3977         if b then begin
3978             o.conn_output <- ANSI;
3979           end else
3980           o.conn_output <- TEXT;
3981         _s "$rdone$n"
3982     ), ":\t\t\t\t\ttoggle ansi terminal (devel)";
3983
3984     "term", Arg_two (fun w h o ->
3985         let w = int_of_string w in
3986         let h = int_of_string h in
3987         o.conn_width <- w;
3988         o.conn_height <- h;
3989         "set"),
3990     "<width> <height> :\t\t\tset terminal width and height (devel)";
3991
3992     "stdout", Arg_one (fun arg o ->
3993         if (bool_of_string arg) then
3994           begin
3995             lprintf_nl "Enable logging to stdout...";
3996             log_to_file stdout;
3997             lprintf_nl "Logging to stdout..."
3998           end
3999         else
4000           begin
4001             lprintf_nl "Disable logging to stdout...";
4002             close_log ();
4003             if !!log_file <> "" then
4004               begin
4005                 let oc = open_out_gen [Open_creat; Open_wronly; Open_append] 0o644 !!log_file in
4006                   log_to_file oc;
4007                   lprintf_nl "Reopened %s" !!log_file
4008               end
4009           end;
4010         Printf.sprintf (_b "log to stdout %s")
4011         (if (bool_of_string arg) then _s "enabled" else _s "disabled")
4012     ), "<true|false> :\t\t\treactivate log to stdout";
4013
4014     "debug_client", Arg_multiple (fun args o ->
4015         List.iter (fun arg ->
4016             let num = int_of_string arg in
4017             debug_clients := Intset.add num !debug_clients;
4018             (try let c = client_find num in client_debug c true with _ -> ())
4019         ) args;
4020         _s "done"
4021     ), "<client nums> :\t\tdebug message in communications with these clients";
4022
4023     "debug_file", Arg_multiple (fun args o ->
4024         List.iter (fun arg ->
4025             let num = int_of_string arg in
4026             let file = file_find num in
4027             Printf.bprintf o.conn_buf
4028               "File %d:\n%s" num
4029               (file_debug file);
4030         ) args;
4031         _s "done"
4032     ), "<client nums> :\t\tdebug file state";
4033
4034     "clear_debug", Arg_none (fun o ->
4035
4036         Intset.iter (fun num ->
4037             try let c = client_find num in
4038               client_debug c false with _ -> ()
4039         ) !debug_clients;
4040         debug_clients := Intset.empty;
4041         _s "done"
4042     ), ":\t\t\t\tclear the table of clients being debugged";
4043
4044     "merge", Arg_two (fun f1 f2 o ->
4045         let file1 = file_find (int_of_string f1) in
4046         let file2 = file_find (int_of_string f2) in
4047         CommonSwarming.merge file1 file2;
4048         "The two files are now merged"
4049     ), "<num1> <num2> :\t\t\ttry to swarm downloads from file <num2> (secondary) to file <num1> (primary)";
4050
4051     "open_log", Arg_none (fun o ->
4052         if !!log_file <> "" then
4053           begin
4054             let log = !!log_file in
4055               CommonOptions.log_file =:= log;
4056             Printf.sprintf "opened logfile %s" !!log_file
4057           end
4058         else
4059           Printf.sprintf "works only if log_file is set"
4060     ), ":\t\t\t\tenable logging to file";
4061
4062     "close_log", Arg_none (fun o ->
4063   lprintf_nl "Stopped logging...";
4064         close_log ();
4065         _s "log stopped"
4066     ), ":\t\t\t\tclose logging to file";
4067
4068      "clear_log", Arg_none (fun o ->
4069         if !!log_file <> "" then
4070           begin
4071             close_log ();
4072             let oc = open_out_gen [Open_creat; Open_wronly; Open_trunc] 0o644 !!log_file in
4073               log_to_file oc;
4074               lprintf_nl "Cleared %s" !!log_file;
4075               Printf.sprintf "Logfile %s cleared" !!log_file
4076           end
4077         else
4078           Printf.sprintf "works only if log_file is set"
4079      ), ":\t\t\t\tclear log_file";
4080
4081     "html_mods", Arg_none (fun o ->
4082         if !!html_mods then
4083           begin
4084             html_mods =:= false;
4085             commands_frame_height =:= 140;
4086           end
4087         else
4088           begin
4089             html_mods =:= true;
4090             html_mods_style =:= 0;
4091             commands_frame_height =:= CommonMessages.styles.(!!html_mods_style).frame_height;
4092             CommonMessages.colour_changer() ;
4093           end;
4094
4095         "\\<script type='text/javascript'\\>top.window.location.replace('/');\\</script\\>"
4096     ), ":\t\t\t\ttoggle html_mods";
4097
4098
4099     "html_mods_style", Arg_multiple (fun args o ->
4100         let buf = o.conn_buf in
4101         if args = [] then begin
4102             Array.iteri (fun i style ->
4103                 Printf.bprintf buf "%d: %s\n" i style.style_name;
4104             ) CommonMessages.styles;
4105             ""
4106           end
4107         else begin
4108             html_mods =:= true;
4109             html_mods_theme =:= "";
4110             let num = int_of_string (List.hd args) in
4111
4112             html_mods_style =:=
4113               if num >= 0 && num < Array.length CommonMessages.styles then
4114                 num else 0;
4115             commands_frame_height =:= CommonMessages.styles.(!!html_mods_style).frame_height;
4116             CommonMessages.colour_changer ();
4117             "\\<script type='text/javascript'\\>top.window.location.replace('/');\\</script\\>"
4118           end
4119
4120     ), ":\t\t\tselect html_mods_style <#>";
4121
4122     "rss", Arg_none (fun o ->
4123         let buf = o.conn_buf in
4124         let module CW = CommonWeb in
4125         Hashtbl.iter (fun url feed ->
4126             let r = feed.CW.rss_value in
4127             if o.conn_output = HTML then begin
4128                 Printf.bprintf buf "\\</pre\\>\\<div class=\\\"cs\\\"\\>";
4129                 html_mods_table_header buf "rssTable" "results" [
4130                    ( Str, "sr", "Content", "Content" ) ;
4131                    ( Str, "sr", "MLDonkey Download", "Download" ) ];
4132                 Printf.bprintf buf "\\<tr\\>";
4133                 html_mods_td buf [
4134                   (r.Rss.ch_title ^ " : " ^ url ^ (Printf.sprintf ", loaded %d hours ago" (((last_time ()) - feed.CW.rss_date) / 3600)), "srh", r.Rss.ch_title);
4135                   ("", "srh", "") ];
4136                 Printf.bprintf buf "\\</tr\\>"
4137               end
4138             else begin
4139                 Printf.bprintf buf "%s:\n" url;
4140                 Printf.bprintf buf "   loaded %d hours ago\n" (feed.CW.rss_date / 3600);
4141                 Printf.bprintf buf "   title: %s\n" r.Rss.ch_title;
4142             end;
4143             html_mods_cntr_init ();
4144             List.iter (fun item ->
4145                 match item.Rss.item_title, item.Rss.item_link with
4146                   None, _
4147                 | _, None -> ()
4148                 | Some title, Some link ->
4149                   if o.conn_output = HTML then begin
4150                       Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
4151                       html_mods_td buf [
4152                         (title, "sr", "\\<a href=\\\"" ^ link ^ "\\\"\\>" ^ title ^ "\\</a\\>");
4153                         (title, "sr",
4154                           "\\<a href=\\\"submit?q=dllink+"
4155                           ^ (Url.encode link)
4156                           ^ "\\\"\\ title=\\\"\\dllink\\\"\\>dllink\\</a\\>"
4157                           ^
4158                           " \\<a href=\\\"submit?q=http+"
4159                           ^ (Url.encode link)
4160                           ^ "\\\"\\ title=\\\"\\http\\\"\\>http\\</a\\>"
4161                           ^
4162                           " \\<a href=\\\"submit?q=startbt+"
4163                           ^ (Url.encode link)
4164                           ^ "\\\"\\ title=\\\"\\startbt\\\"\\>startbt\\</a\\>"
4165                         )
4166                       ];
4167                       Printf.bprintf buf "\\</tr\\>"
4168                     end
4169                   else begin
4170                       Printf.bprintf buf "     %s\n" title;
4171                       Printf.bprintf buf "       > %s\n" link
4172                     end
4173             ) r.Rss.ch_items;
4174             if o.conn_output = HTML then
4175                 Printf.bprintf buf "\\</table\\>\\</div\\>\\</div\\>\\<pre\\>";
4176         ) CW.rss_feeds;
4177         ""
4178
4179
4180     ), ":\t\t\t\t\tprint RSS feeds";
4181
4182     "html_theme", Arg_multiple (fun args o ->
4183         let buf = o.conn_buf in
4184         if args = [] then begin
4185             Printf.bprintf buf "Usage: html_theme <theme name>\n";
4186             Printf.bprintf buf "To use internal theme: html_theme \\\"\\\"\n";
4187             Printf.bprintf buf "Current theme: %s\n\n" !!html_mods_theme;
4188             Printf.bprintf buf "Available themes:\n";
4189             if Sys.file_exists html_themes_dir then begin
4190                 let list = Unix2.list_directory html_themes_dir in
4191                 List.iter (fun d ->
4192                     if Unix2.is_directory (Filename.concat html_themes_dir d) then
4193                       Printf.bprintf buf "%s\n" d;
4194                 ) (List.sort (fun d1 d2 -> compare d1 d2) list);
4195               end;
4196             ""
4197           end
4198         else begin
4199 (* html_mods =:= true; *)
4200             html_mods_theme =:= List.hd args;
4201             "\\<script type=\\\"text/javascript\\\"\\>top.window.location.reload();\\</script\\>"
4202           end
4203
4204     ), "<theme> :\t\t\tselect html_theme";
4205
4206     "mem_stats", Arg_multiple (fun args o ->
4207         let buf = o.conn_buf in
4208         let level = match args with
4209           [] -> 0
4210         | n :: _ -> int_of_string n in
4211         Heap.print_memstats level buf (use_html_mods o);
4212         ""
4213     ), ":\t\t\t\tprint memory stats [<verbosity #num>]";
4214
4215     "close_all_sockets", Arg_none (fun o ->
4216         BasicSocket.close_all ();
4217         _s "All sockets closed"
4218     ), ":\t\t\tclose all opened sockets";
4219
4220     "use_poll", Arg_one (fun arg o ->
4221         let b = bool_of_string arg in
4222         BasicSocket.use_poll b;
4223         Printf.sprintf "poll: %s" (string_of_bool b)
4224     ), "<bool> :\t\t\tuse poll instead of select";
4225
4226     "close_fds", Arg_none (fun o ->
4227         Unix32.close_all ();
4228         let buf = o.conn_buf in
4229         if o.conn_output = HTML then
4230           html_mods_table_one_row buf "serversTable" "servers" [
4231             ("", "srh", "All files closed"); ]
4232         else
4233           Printf.bprintf buf "All files closed";
4234         ""
4235     ), ":\t\t\t\tclose all files (use to free space on disk after remove)";
4236
4237     "debug_socks", Arg_none (fun o ->
4238         BasicSocket.print_sockets o.conn_buf;
4239         _s "done"
4240     ), ":\t\t\t\tfor debugging only";
4241
4242     "block_list", Arg_none (fun o ->
4243       let buf = o.conn_buf in
4244       if o.conn_output = HTML then
4245         List.iter (fun (tablename, l) ->
4246           html_mods_cntr_init ();
4247           html_mods_table_header buf ~total:"1" tablename "servers" [
4248             ( Str, "srh ac br", "Description (" ^ tablename ^ ")", "Description (" ^ tablename ^ ")") ;
4249             ( Num, "srh ar", "Hits", "Hits") ;
4250             ( Str, "srh ac", "Range", "Range")];
4251           let nhits =
4252             Ip_set.bl_fold_left (fun nhits br ->
4253                 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>"
4254                   (html_mods_cntr ());
4255                 html_mods_td buf [
4256                   ("Description", "sr br", br.Ip_set.blocking_description);
4257                   ("Hits", "sr ar br", string_of_int br.Ip_set.blocking_hits);
4258                   ("Range", "sr", Printf.sprintf "%s - %s"
4259                     (Ip.to_string br.Ip_set.blocking_begin)
4260                     (Ip.to_string br.Ip_set.blocking_end))];
4261                 Printf.bprintf buf "\\</tr\\>";
4262               (nhits + br.Ip_set.blocking_hits)
4263             ) 0 l
4264           and nranges = Ip_set.bl_length l in
4265           Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>"
4266             (html_mods_cntr ());
4267           if nranges > 0 then
4268           html_mods_td buf [
4269             ("Total ranges", "sr br total", ("Total ranges " ^ string_of_int nranges));
4270             ("Hits", "sr ar br total", Printf.sprintf "%s" (string_of_int nhits));
4271             ("", "sr br total", "")]
4272           else begin
4273           html_mods_td buf [
4274             ("no " ^ tablename ^ " loaded", "sr", "no " ^ tablename ^ " loaded");
4275             ("", "sr", "");
4276             ("", "sr", "")];
4277           end;
4278           Printf.bprintf buf "\\</tr\\>\\</table\\>\\<P\\>";
4279         ) [
4280           ("Web blocking list", !CommonBlocking.web_ip_blocking_list);
4281           ("Local blocking list", !CommonBlocking.ip_blocking_list)]
4282       else begin
4283         Printf.bprintf buf "Web blocking list\n";
4284         Ip_set.print_list buf !CommonBlocking.web_ip_blocking_list;
4285         Printf.bprintf buf "Local blocking list\n";
4286         Ip_set.print_list buf !CommonBlocking.ip_blocking_list;
4287       end;
4288       _s ""
4289     ), ":\t\t\t\tdisplay the list of blocked IP ranges that were hit";
4290
4291     "block_test", Arg_one (fun arg o ->
4292       let ip = Ip.of_string arg in
4293       _s (match !Ip.banned (ip, None) with
4294           None -> "Not blocked"
4295         | Some reason ->
4296           Printf.sprintf "Blocked, %s\n" reason)
4297     ), "<ip> :\t\t\tcheck whether an IP is blocked";
4298
4299     "debug_pictures", Arg_two (fun dir output o ->
4300         CommonPictures.compute_ocaml_code dir output;
4301         _s "done"
4302     ), ":\t\t\tfor debugging only";
4303
4304     "debug_upnp", Arg_multiple ( fun args o ->
4305                 match args with
4306                         | ["init"] ->
4307                                 UpnpClient.init_maps ();
4308
4309                         | ["add"; intPort; extPort; isTcp; notes ] ->
4310                                 UpnpClient.maps_add_item 1 (int_of_string intPort) (int_of_string extPort) (int_of_string isTcp) notes;
4311
4312                         | ["start"] ->
4313                                 UpnpClient.job_start ();
4314
4315                         | ["remove"; intPort; extPort; isTcp; notes] ->
4316                                 UpnpClient.maps_remove_item 1 (int_of_string intPort) (int_of_string extPort) (int_of_string isTcp) notes;
4317
4318                         | ["clear"] ->
4319                                 UpnpClient.remove_all_maps 0 ;
4320
4321                         | ["stop"] ->
4322                                 UpnpClient.job_stop 0;
4323
4324                         | ["show"] | [] ->
4325                                 let buf = o.conn_buf in
4326                                         let     maps = UpnpClient.maps_get () in
4327                                         Printf.bprintf buf "upnp port forwarding status:\n";
4328                                         List.iter (fun map ->
4329                                                 let msg = UpnpClient.strings_port_map map in
4330                                                 Printf.bprintf buf "%s\n" msg;
4331                                         ) maps;
4332
4333                         | _ -> ();
4334                                 ;
4335                         _s "done"
4336     ), ":\t\t\t\t\t$debugging upnp\n"
4337        ^"\t\t\t\t\tfor example: \"add 4662 4662 1 ed_port\" add port forwarding intPort extPort isTcp notes\n"
4338        ^"\t\t\t\t\t\"remove 4662 4662 1 ed_port\" remove port forwarding intPort extPort isTcp notes\n"
4339        ^"\t\t\t\t\t\"clear\" clear all port forwarding\n"
4340        ^"\t\t\t\t\t\"show\" show all port forwarding info $n";
4341
4342   ]