[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co...
|
From: |
mldonkey-commits |
|
Subject: |
[Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co... |
|
Date: |
Tue, 19 Sep 2006 17:07:44 +0000 |
CVSROOT: /sources/mldonkey
Module name: mldonkey
Changes by: spiralvoice <spiralvoice> 06/09/19 17:07:43
Modified files:
distrib : ChangeLog
src/daemon/common: commonComplexOptions.ml commonFile.ml
commonFile.mli commonInteractive.ml
commonNetwork.ml commonNetwork.mli
commonOptions.ml commonResult.ml
commonResult.mli commonTypes.ml
commonUserDb.ml
src/daemon/driver: driverCommands.ml driverControlers.ml
driverInteractive.ml driverInterface.ml
driverMain.ml
src/networks/bittorrent: bTComplexOptions.ml bTGlobals.ml
bTInteractive.ml
src/networks/donkey: donkeyComplexOptions.ml donkeyGlobals.ml
donkeyInteractive.ml donkeyOneFile.ml
donkeyShare.ml
src/networks/fasttrack: fasttrackGlobals.ml fasttrackServers.ml
src/networks/fileTP: fileTPClients.ml fileTPComplexOptions.ml
fileTPFTP.ml fileTPGlobals.ml fileTPHTTP.ml
fileTPInteractive.ml
src/networks/gnutella: gnutellaComplexOptions.ml
gnutellaGlobals.ml gnutellaInteractive.ml
gnutellaServers.ml
Added files:
docs : multiuser.txt
Log message:
patch #5406 - multiuser #1
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/mldonkey/distrib/ChangeLog?cvsroot=mldonkey&r1=1.1015&r2=1.1016
http://cvs.savannah.gnu.org/viewcvs/mldonkey/docs/multiuser.txt?cvsroot=mldonkey&rev=1.1
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonComplexOptions.ml?cvsroot=mldonkey&r1=1.60&r2=1.61
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonFile.ml?cvsroot=mldonkey&r1=1.60&r2=1.61
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonFile.mli?cvsroot=mldonkey&r1=1.20&r2=1.21
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonInteractive.ml?cvsroot=mldonkey&r1=1.80&r2=1.81
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonNetwork.ml?cvsroot=mldonkey&r1=1.29&r2=1.30
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonNetwork.mli?cvsroot=mldonkey&r1=1.15&r2=1.16
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonOptions.ml?cvsroot=mldonkey&r1=1.176&r2=1.177
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonResult.ml?cvsroot=mldonkey&r1=1.9&r2=1.10
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonResult.mli?cvsroot=mldonkey&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonTypes.ml?cvsroot=mldonkey&r1=1.55&r2=1.56
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonUserDb.ml?cvsroot=mldonkey&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/driver/driverCommands.ml?cvsroot=mldonkey&r1=1.175&r2=1.176
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/driver/driverControlers.ml?cvsroot=mldonkey&r1=1.85&r2=1.86
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/driver/driverInteractive.ml?cvsroot=mldonkey&r1=1.101&r2=1.102
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/driver/driverInterface.ml?cvsroot=mldonkey&r1=1.52&r2=1.53
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/driver/driverMain.ml?cvsroot=mldonkey&r1=1.125&r2=1.126
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTComplexOptions.ml?cvsroot=mldonkey&r1=1.36&r2=1.37
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTGlobals.ml?cvsroot=mldonkey&r1=1.63&r2=1.64
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/bittorrent/bTInteractive.ml?cvsroot=mldonkey&r1=1.108&r2=1.109
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/donkey/donkeyComplexOptions.ml?cvsroot=mldonkey&r1=1.57&r2=1.58
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/donkey/donkeyGlobals.ml?cvsroot=mldonkey&r1=1.96&r2=1.97
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/donkey/donkeyInteractive.ml?cvsroot=mldonkey&r1=1.122&r2=1.123
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/donkey/donkeyOneFile.ml?cvsroot=mldonkey&r1=1.42&r2=1.43
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/donkey/donkeyShare.ml?cvsroot=mldonkey&r1=1.50&r2=1.51
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/fasttrack/fasttrackGlobals.ml?cvsroot=mldonkey&r1=1.41&r2=1.42
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/fasttrack/fasttrackServers.ml?cvsroot=mldonkey&r1=1.29&r2=1.30
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/fileTP/fileTPClients.ml?cvsroot=mldonkey&r1=1.22&r2=1.23
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/fileTP/fileTPComplexOptions.ml?cvsroot=mldonkey&r1=1.16&r2=1.17
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/fileTP/fileTPFTP.ml?cvsroot=mldonkey&r1=1.13&r2=1.14
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/fileTP/fileTPGlobals.ml?cvsroot=mldonkey&r1=1.28&r2=1.29
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/fileTP/fileTPHTTP.ml?cvsroot=mldonkey&r1=1.25&r2=1.26
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/fileTP/fileTPInteractive.ml?cvsroot=mldonkey&r1=1.46&r2=1.47
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/gnutella/gnutellaComplexOptions.ml?cvsroot=mldonkey&r1=1.28&r2=1.29
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/gnutella/gnutellaGlobals.ml?cvsroot=mldonkey&r1=1.42&r2=1.43
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/gnutella/gnutellaInteractive.ml?cvsroot=mldonkey&r1=1.63&r2=1.64
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/gnutella/gnutellaServers.ml?cvsroot=mldonkey&r1=1.28&r2=1.29
Patches:
Index: distrib/ChangeLog
===================================================================
RCS file: /sources/mldonkey/mldonkey/distrib/ChangeLog,v
retrieving revision 1.1015
retrieving revision 1.1016
diff -u -b -r1.1015 -r1.1016
--- distrib/ChangeLog 17 Sep 2006 18:42:57 -0000 1.1015
+++ distrib/ChangeLog 19 Sep 2006 17:07:42 -0000 1.1016
@@ -14,6 +14,17 @@
ChangeLog
=========
+2006/09/19
+5406: Main multiuser patch, see docs/multiuser.txt for details
+ thx to jave, pango, zet and many other people who have helped
+ to make this work possible
+- this patch is experimental, if it breaks, you can keep the pieces;-)
+- multigroup_usercommit.patch and multigroup_su.patch are not included
+- this patch is still not finished, the To-Do list in docs/multiuser.txt
+ is still long, also GUI protocol updates have to be implemented.
+ To manage users, groups and files, its best to use the HTML interface,
+ multiuser commands can also be used in Telnet interface.
+-------------------------------------------------------------------------------
2006/09/17 version 2.8.1 = tag release-2-8-1
5401: Fix question whether to compile Ocaml with some bash versions (pango)
5400: Allow use of Ocaml 3.09.3, keep 3.09.2 as default
Index: src/daemon/common/commonComplexOptions.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonComplexOptions.ml,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -b -r1.60 -r1.61
--- src/daemon/common/commonComplexOptions.ml 1 Sep 2006 16:22:14 -0000
1.60
+++ src/daemon/common/commonComplexOptions.ml 19 Sep 2006 17:07:42 -0000
1.61
@@ -27,6 +27,7 @@
open CommonServer
open CommonNetwork
open CommonOptions
+open CommonUserDb
open CommonTypes
open CommonFile
open Gettext
@@ -102,6 +103,45 @@
impl.impl_file_age <-
normalize_time (get_value "file_age" value_to_int)
with _ -> ());
+
+ let file_user = try
+ let u = get_value "file_owner" value_to_string in
+ if user2_user_exist u then u else begin
+ lprintf_nl "file_owner %s of %s does not exist, changing to %s"
+ u (get_value "file_filename" value_to_string) admin_user;
+ admin_user
+ end
+ with _ -> admin_user
+ in
+ set_file_owner file file_user;
+
+ let file_group = try
+ match (get_value "file_group" stringvalue_to_option) with
+ None -> None
+ | Some g ->
+ if user2_group_exists g then
+ if user2_user_is_group_member file_user g then
+ Some g
+ else begin
+ lprintf_nl "file_owner %s is not member of file_group %s,
changing file_group of %s to user_default_group %s"
+ file_user
+ g
+ (get_value "file_filename" value_to_string)
+ (user2_print_user_default_group file_user);
+ user2_user_default_group file_user
+ end
+ else begin
+ lprintf_nl "file_group %s of %s does not exist, changing
file_group of %s to user_default_group %s"
+ g
+ (get_value "file_filename" value_to_string)
+ file_user
+ (user2_print_user_default_group file_user);
+ user2_user_default_group file_user
+ end
+ with _ -> user2_user_default_group file_user
+ in
+ set_file_group file file_group;
+
set_file_state file file_state;
(try
@@ -138,6 +178,8 @@
("file_filenames", List
(List.map string_to_value impl.impl_file_filenames)) ::
("file_age", IntValue (Int64.of_int impl.impl_file_age)) ::
+ ("file_owner", string_to_value (file_owner file)) ::
+ ("file_group", option_to_stringvalue (file_group file)) ::
(file_to_option file)
)
Index: src/daemon/common/commonFile.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonFile.ml,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -b -r1.60 -r1.61
--- src/daemon/common/commonFile.ml 5 Sep 2006 14:18:24 -0000 1.60
+++ src/daemon/common/commonFile.ml 19 Sep 2006 17:07:42 -0000 1.61
@@ -25,6 +25,7 @@
open CommonTypes
open CommonOptions
open CommonGlobals
+open CommonUserDb
let log_prefix = "[cF]"
@@ -41,6 +42,8 @@
(*************************************************************************)
type 'a file_impl = {
+ mutable impl_file_owner : string;
+ mutable impl_file_group : string option;
mutable impl_file_update : int;
mutable impl_file_state : file_state;
@@ -133,6 +136,8 @@
impl_file_last_seen = 0;
impl_file_comment = [];
impl_file_probable_name = None;
+ impl_file_owner = admin_user;
+ impl_file_group = Some system_user_default_group;
}
let dummy_file = as_file dummy_file_impl
@@ -216,7 +221,22 @@
let file = as_file_impl file in
file.impl_file_ops.op_file_info file.impl_file_val
-let file_pause (file : file) =
+let file_owner file =
+ (as_file_impl file).impl_file_owner
+
+let file_group file =
+ (as_file_impl file).impl_file_group
+
+let file_group_text file =
+ match (as_file_impl file).impl_file_group with
+ Some group -> group
+ | None -> "None"
+
+let user2_allow_file_admin file gui_user =
+ user2_is_admin gui_user || file_owner file = gui_user
+
+let file_pause (file : file) user =
+ if user2_allow_file_admin file user then
let file = as_file_impl file in
match file.impl_file_state with
| FileDownloading | FileQueued ->
@@ -224,7 +244,8 @@
file.impl_file_ops.op_file_pause file.impl_file_val
| _ -> ()
-let file_resume (file : file) =
+let file_resume (file : file) user =
+ if user2_allow_file_admin file user then
let file = as_file_impl file in
match file.impl_file_state with
| FilePaused | FileAborted _ ->
@@ -232,6 +253,47 @@
file.impl_file_ops.op_file_resume file.impl_file_val
| _ -> ()
+let set_file_owner file owner =
+ (as_file_impl file).impl_file_owner <- owner
+
+let set_file_group file group =
+ (as_file_impl file).impl_file_group <- group
+
+let set_file_owner_safe file user new_owner =
+ if (user2_user_exist new_owner) &&
+ (user2_allow_file_admin file user) then
+ begin
+ set_file_owner file new_owner;
+ true
+ end
+ else
+ false
+
+let set_file_group_safe file gui_user new_group =
+ if (user2_group_exists_option new_group) &&
+ (user2_allow_file_admin file gui_user) then
+ begin
+ set_file_group file new_group;
+ true
+ end
+ else
+ false
+
+let user2_filter_files files gui_user =
+ let newlist = List.filter
+ (fun file -> user2_can_view_file gui_user (file_owner file) (file_group
file)) files in
+ newlist
+
+let user2_user_dls_count user =
+ let n = ref 0 in
+ H.iter (fun f -> if file_owner f = user then incr n) files_by_num;
+ !n
+
+let user2_group_dls_count group =
+ let n = ref 0 in
+ H.iter (fun f -> if file_group f = Some group then incr n) files_by_num;
+ !n
+
let set_file_state file state =
let impl = as_file_impl file in
update_file_state impl state
@@ -627,6 +689,71 @@
("", "sr", Printf.sprintf "%d" (file_priority file)) ];
Printf.bprintf buf "\\</tr\\>\\<tr class=\\\"dl-%d\\\"\\>"
(html_mods_cntr ());
+ if user2_allow_file_admin file o.conn_user.ui_user_name then
+ let optionlist = ref "" in
+ user2_user_iter (fun user ->
+ if user.user_name <> (file_owner file) then
+ optionlist := !optionlist ^ Printf.sprintf "\\<option
value=\\\"%s\\\"\\>%s\\</option\\>\n" user.user_name user.user_name;
+ );
+
+ html_mods_td buf [("Change file owner by selecting an alternate user",
"sr br", "User");
+ ("Change owner", "sr", Printf.sprintf "
+\\<script type=\\\"text/javascript\\\"\\>
+\\<!--
+function submitChownForm(i) {
+var formID = document.getElementById(\\\"chownForm\\\" + i)
+var v = formID.newOwner.value;
+parent.fstatus.location.href='submit?q=chown+'+v+'+%d';
+}
+//--\\>
+\\</script\\>" (file_num file)
+ ^ "\\<form name=\\\"chownForm1\\\" id=\\\"chownForm1\\\"
action=\\\"javascript:submitChownForm(1);\\\"\\>"
+ ^ "\\<select name=\\\"newOwner\\\" id=\\\"newOwner\\\" "
+ ^ "style=\\\"padding: 0px; font-size: 10px; font-family: verdana\\\"
onchange=\\\"this.form.submit()\\\"\\>"
+ ^ Printf.sprintf "\\<option value=\\\"%s\\\" selected\\>%s\\</option\\>\n"
(file_owner file) (file_owner file)
+ ^ !optionlist ^ "\\</select\\>\\</form\\>\\</input\\>" ) ];
+
+ else
+ html_mods_td buf [("File owner", "sr br", "User"); ("", "sr",
(file_owner file))];
+
+ Printf.bprintf buf "\\</tr\\>\\<tr class=\\\"dl-1\\\"\\>";
+ if user2_allow_file_admin file o.conn_user.ui_user_name &&
+ user2_user_groups_safe o.conn_user.ui_user_name <> [] then
+ let optionlist =
+ if (file_group_text file) = "None" then
+ ref ""
+ else
+ ref "\\<option value=\\\"None\\\"\\>None\\</option\\>\n"
+ in
+ user2_user_groups_iter o.conn_user.ui_user_name (fun group ->
+ if group <> (file_group_text file) then
+ optionlist := !optionlist ^ Printf.sprintf "\\<option
value=\\\"%s\\\"\\>%s\\</option\\>\n" group group;
+ );
+
+ html_mods_td buf [("Change file group by selecting an alternate
group", "sr br", "Group");
+ ("Change group", "sr", Printf.sprintf "
+\\<script type=\\\"text/javascript\\\"\\>
+\\<!--
+function submitChgrpForm(i) {
+var formID = document.getElementById(\\\"chgrpForm\\\" + i)
+var v = formID.newGroup.value;
+parent.fstatus.location.href='submit?q=chgrp+'+v+'+%d';
+}
+//--\\>
+\\</script\\>" (file_num file)
+ ^ "\\<form name=\\\"chgrpForm1\\\" id=\\\"chgrpForm1\\\"
action=\\\"javascript:submitChgrpForm(1);\\\"\\>"
+ ^ "\\<select name=\\\"newGroup\\\" id=\\\"newGroup\\\" "
+ ^ "style=\\\"padding: 0px; font-size: 10px; font-family: verdana\\\"
onchange=\\\"this.form.submit()\\\"\\>"
+ ^ Printf.sprintf "\\<option value=\\\"%s\\\" selected\\>%s\\</option\\>\n"
(file_group_text file) (file_group_text file)
+ ^ !optionlist ^ "\\</select\\>\\</form\\>\\</input\\>" ) ];
+
+ else
+ html_mods_td buf [("File group", "sr br", "Group");
+ ("", "sr", (match file_group file with
+ Some group -> Printf.sprintf "%s" group
+ | None -> "None"))];
+
+ Printf.bprintf buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
html_mods_td buf [
("Number of file sources", "sr br", "Sources");
("", "sr", Printf.sprintf "%d" (List.length srcs)) ];
@@ -694,7 +821,7 @@
end else
begin
- Printf.bprintf buf "[%-s %5d]\n%s\n%s%s\nTotal %10s\nPartial
%10s\npriority %d\n"
+ Printf.bprintf buf "[%-s %5d]\n%s\n%s%s\nTotal %10s\nPartial
%10s\npriority %d\nOwner/Group: %s/%s\n"
n.network_name
(file_num file)
(shorten (file_best_name file) 80)
@@ -704,7 +831,11 @@
(string_of_uids info.G.file_uids)
(Int64.to_string info.G.file_size)
(Int64.to_string info.G.file_downloaded)
- (file_priority file);
+ (file_priority file)
+ (file_owner file)
+ (match file_group file with
+ Some group -> Printf.sprintf "%s" group
+ | None -> "private");
Printf.bprintf buf "Chunks: [%-s]\n"
(match info.G.file_chunks with
| None -> ""
Index: src/daemon/common/commonFile.mli
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonFile.mli,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -b -r1.20 -r1.21
--- src/daemon/common/commonFile.mli 5 Sep 2006 14:18:24 -0000 1.20
+++ src/daemon/common/commonFile.mli 19 Sep 2006 17:07:42 -0000 1.21
@@ -18,6 +18,8 @@
*)
type 'a file_impl = {
+ mutable impl_file_owner : string;
+ mutable impl_file_group : string option;
mutable impl_file_update : int;
mutable impl_file_state : CommonTypes.file_state;
@@ -77,8 +79,8 @@
val file_save_as : CommonTypes.file -> string -> unit
val file_network : CommonTypes.file -> CommonTypes.network
val file_info : CommonTypes.file -> GuiTypes.file_info
-val file_pause : CommonTypes.file -> unit
-val file_resume : CommonTypes.file -> unit
+val file_pause : CommonTypes.file -> string -> unit
+val file_resume : CommonTypes.file -> string -> unit
val set_file_state : CommonTypes.file -> CommonTypes.file_state -> unit
val file_best_name : CommonTypes.file -> string
val set_file_best_name : CommonTypes.file -> string -> string -> int -> unit
@@ -136,3 +138,15 @@
val forceable_download : CommonTypes.result_info list ref
val impl_file_info : 'a file_impl -> GuiTypes.file_info
+
+val user2_filter_files : CommonTypes.file list -> string -> CommonTypes.file
list
+val user2_user_dls_count : string -> int
+val user2_group_dls_count : string -> int
+val user2_allow_file_admin : CommonTypes.file -> string -> bool
+val set_file_owner : CommonTypes.file -> string -> unit
+val set_file_owner_safe : CommonTypes.file -> string -> string -> bool
+val file_owner : CommonTypes.file -> string
+val set_file_group : CommonTypes.file -> string option -> unit
+val set_file_group_safe : CommonTypes.file -> string -> string option -> bool
+val file_group : CommonTypes.file -> string option
+val file_group_text : CommonTypes.file -> string
Index: src/daemon/common/commonInteractive.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonInteractive.ml,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -b -r1.80 -r1.81
--- src/daemon/common/commonInteractive.ml 5 Sep 2006 14:18:24 -0000
1.80
+++ src/daemon/common/commonInteractive.ml 19 Sep 2006 17:07:42 -0000
1.81
@@ -40,6 +40,7 @@
open CommonServer
open CommonTypes
open CommonComplexOptions
+open CommonUserDb
let log_prefix = "[cInt]"
@@ -179,7 +180,11 @@
("DLFILES", string_of_int (List.length !!files));
("INCOMING", incoming);
("NETWORK", network.network_name);
- ("ED2K_HASH", (file_print_ed2k_link filename (file_size file)
info.G.file_md4))]
+ ("ED2K_HASH", (file_print_ed2k_link filename (file_size file)
info.G.file_md4));
+ ("FILE_OWNER",(file_owner file));
+ ("FILE_GROUP",(file_group_text file));
+ ]
+
with e ->
lprintf_nl "Exception %s while executing %s"
(Printexc2.to_string e) !!file_completed_cmd
@@ -279,7 +284,8 @@
lprintf_nl "Exception in file_commit: %s" (Printexc2.to_string
e))
| _ -> assert false
-let file_cancel file =
+let file_cancel file user =
+ if user2_allow_file_admin file user then
try
let impl = as_file_impl file in
if impl.impl_file_state <> FileCancelled then
@@ -308,7 +314,8 @@
lprintf_nl "Exception in file_cancel: %s" (Printexc2.to_string e)
let mail_for_completed_file file =
- if !!mail <> "" then
+ let usermail = user2_user_mail (file_owner file) in
+ if !!mail <> "" || usermail <> "" then begin
let module M = Mailer in
let info = file_info file in
let line1 = "mldonkey has completed the download of:\r\n\r\n" in
@@ -348,13 +355,22 @@
Printf.sprintf "\r\nauto_commit is disabled, file is not committed to
incoming"
in
+ let line6 =
+ Printf.sprintf "\r\nUser/Group: %s:%s\r\n" (file_owner file)
(file_group_text file)
+ in
+
+ let send_mail address admin =
let mail = {
- M.mail_to = !!mail;
- M.mail_from = !!mail;
+ M.mail_to = address;
+ M.mail_from = address;
M.mail_subject = subject;
- M.mail_body = line1 ^ line2 ^ line3 ^ line4 ^ line5;
+ M.mail_body = line1 ^ line2 ^ line3 ^ line4 ^ line5 ^ (if admin then
line6 else "");
} in
M.sendmail !!smtp_server !!smtp_port !!add_mail_brackets mail
+ in
+ if !!mail <> "" then send_mail !!mail true; (* Multiuser ToDo: this mail
is for the admin user, optional? *)
+ if usermail <> "" && usermail <> !!mail then (try send_mail usermail false
with Not_found -> ())
+ end
let file_completed (file : file) =
try
@@ -502,7 +518,7 @@
let display_bw_stats = ref false
let start_download file =
- if !!pause_new_downloads then file_pause file;
+ if !!pause_new_downloads then file_pause file admin_user;
if !!file_started_cmd <> "" then
MlUnix.fork_and_exec !!file_started_cmd
[|
@@ -521,7 +537,7 @@
| Some s ->
let result = List.assoc (int_of_string arg) user.ui_last_results in
let files = CommonResult.result_download
- result [] false in
+ result [] false user.ui_user_name in
List.iter start_download files;
"download started"
with
@@ -940,92 +956,123 @@
and the ones with lowest priority in FileQueued state, if there
is a max_concurrent_downloads constraint.
-In the future, we could try to mix this with the multi-users
-system to give some fairness between downloads of different
-users.
-
**************************************************************)
open CommonFile
+type user_file_list = {
+ file_list : file list;
+ downloads_allowed : int option;
+}
+
let force_download_quotas () =
- let files = List.sort (fun f1 f2 ->
- let v = file_priority f2 - file_priority f1 in
+
+ let queue_files files =
+ List.iter (fun file ->
+ if file_state file = FileDownloading then
+ set_file_state file FileQueued
+ ) files in
+
+ let queue_user_file_list (_user, user_file_list) =
+ queue_files user_file_list.file_list in
+
+ if !all_temp_queued then
+ queue_files !!CommonComplexOptions.files
+ else
+
+ (* create the assoc list of downloads of each user *)
+ let files_by_user = List.fold_left (fun acc f ->
+ let owner = CommonFile.file_owner f in
+ try
+ let owner_file_list = List.assoc owner acc in
+ (owner, { owner_file_list with
+ file_list = f :: owner_file_list.file_list }) ::
+ List.remove_assoc owner acc
+ with Not_found ->
+ (owner, {
+ downloads_allowed =
+ (match (user2_user_find owner).user_max_concurrent_downloads with
+ | 0 -> None
+ | i -> Some i);
+ file_list = [f] }) :: acc
+ ) [] !!CommonComplexOptions.files in
+
+ (* sort each user's list separately *)
+ let files_by_user = List.map (fun (owner, owner_file_list) ->
+ owner, { owner_file_list with
+ file_list = List.sort (fun f1 f2 ->
+ let v = compare (file_priority f2) (file_priority f1) in
if v <> 0 then v else
- (**
- * [egs] do not start downloading
- * a small file against an already active download
- **)
+ (* [egs] do not start downloading a small file
+ against an already active download *)
let d1 = file_downloaded f1 in
let d2 = file_downloaded f2 in
- if d1 = 0L && d2 > 0L then 1
- else
- if d1 > 0L && d2 = 0L then -1
+ let active1 = d1 > 0L in
+ let active2 = d2 > 0L in
+ if not active1 && active2 then 1
+ else if active1 && not active2 then -1
else
(* Try to download in priority files with fewer bytes missing
Rationale: once completed, it may allow to recover some disk
space *)
- let r1 = file_size f1 -- d1 in
- let r2 = file_size f2 -- d2 in
- if r1 = r2 then 0 else
- if r2 < r1 then 1 else -1
- ) !!CommonComplexOptions.files in
-
- (** move running and queued downloads from [list] to [files]
- accumulator, until a drop of priority (or end of list) is
- encountered; Then submit the batches of downloads with same
- priority to [iter_line].
-
- @param ndownloads number of running downloads no longer in [list]
- @param nqueued number of queued downloads in [files]
- *)
- let rec iter list priority files ndownloads nqueued =
- match list, files with
- | [], [] -> ()
- | [], _ ->
- iter_line list priority files ndownloads nqueued
- | f :: tail , _ :: _ when file_priority f < priority ->
- iter_line list priority files ndownloads nqueued
- | f :: tail, files ->
- match file_state f with
- | FileDownloading ->
- iter tail (file_priority f) (f :: files) (ndownloads+1) nqueued
- | FileQueued ->
- iter tail (file_priority f) (f :: files) ndownloads (nqueued+1)
- | _ ->
- iter tail (file_priority f) files ndownloads nqueued
-
- (** queue or unqueue downloads from [files] list to match quotas *)
- and iter_line list priority files ndownloads nqueued =
- if ndownloads > !!max_concurrent_downloads then
- match files with
- | [] -> assert false
- | f :: tail ->
- match file_state f with
- | FileDownloading ->
- set_file_state f FileQueued;
- iter_line list priority tail (ndownloads-1) nqueued
- | _ -> iter_line list priority tail ndownloads (nqueued-1)
- else
- if ndownloads < !!max_concurrent_downloads && nqueued > 0 then
- match files with
- | [] -> assert false
- | f :: tail ->
- match file_state f with
+ let remaining1 = file_size f1 -- d1 in
+ let remaining2 = file_size f2 -- d2 in
+ compare remaining1 remaining2
+ ) owner_file_list.file_list }
+ ) files_by_user in
+
+ (* sort the assoc list itself with user with highest quota first *)
+ let files_by_user =
+ List.sort (fun (_owner1, { downloads_allowed = allowed1 })
+ (_owner2, { downloads_allowed = allowed2 }) ->
+ match allowed1, allowed2 with
+ | None, None -> 0
+ | None, _ -> -1
+ | _, None -> 1
+ | Some allowed1, Some allowed2 -> compare allowed2 allowed1
+ ) files_by_user in
+
+ (* serve users round-robin, starting with the one with highest quota *)
+ let rec iter downloads_left to_serve served =
+ if downloads_left = 0 then begin
+ List.iter queue_user_file_list to_serve;
+ List.iter queue_user_file_list served
+ end else
+ match to_serve with
+ | [] ->
+ if served = [] then () (* nothing left to rotate *)
+ else (* new round *)
+ iter downloads_left served []
+ | (_owner, { file_list = [] }) :: others ->
+ (* user satisfied, remove from lists *)
+ iter downloads_left others served
+ | ((_owner, { downloads_allowed = Some 0 }) as first) :: others ->
+ (* reached quota, remove from future rounds *)
+ queue_user_file_list first;
+ iter downloads_left others served
+ | (owner, { file_list = first_file :: other_files;
+ downloads_allowed = allowed }) :: others ->
+ let is_downloading =
+ match file_state first_file with
+ | FileDownloading -> true
| FileQueued ->
- set_file_state f FileDownloading;
- iter_line list priority tail (ndownloads+1) (nqueued-1)
- | _ -> iter_line list priority tail ndownloads nqueued
- else
- iter list priority [] ndownloads 0
-
- in
- if not !all_temp_queued then
- iter files max_int [] 0 0
+ set_file_state first_file FileDownloading;
+ true
+ | _ -> false in
+ if is_downloading then
+ iter (downloads_left - 1) others
+ ((owner, {
+ file_list = other_files;
+ downloads_allowed = match allowed with
+ | None -> None
+ | Some i -> Some (i - 1)
+ }) :: served)
else
- List.iter (fun f ->
- if file_state f = FileDownloading then
- set_file_state f FileQueued
- ) files
+ iter downloads_left others
+ ((owner, {
+ file_list = other_files;
+ downloads_allowed = allowed
+ }) :: served) in
+ iter !!max_concurrent_downloads files_by_user []
let _ =
option_hook max_concurrent_downloads (fun _ ->
Index: src/daemon/common/commonNetwork.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonNetwork.ml,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -b -r1.29 -r1.30
--- src/daemon/common/commonNetwork.ml 5 Sep 2006 14:15:19 -0000 1.29
+++ src/daemon/common/commonNetwork.ml 19 Sep 2006 17:07:42 -0000 1.30
@@ -257,7 +257,7 @@
op_network_update_options = (fun _ -> ni_ok name "update_options");
op_network_disable = (fun _ -> ni_ok name "disable");
op_network_server_of_option = (fun _ -> fni name
"op_network_server_of_option");
- op_network_file_of_option = (fun _ _ -> fni name
"op_network_file_of_option");
+ op_network_file_of_option = (fun _ _ _ -> fni name
"op_network_file_of_option");
op_network_client_of_option = (fun _ -> fni name
"op_network_client_of_option");
op_network_recover_temp = (fun _ -> ni_ok name "recover_temp");
op_network_search = (fun _ _ -> ni_ok name "search");
@@ -268,12 +268,12 @@
op_network_close_search = (fun _ -> ni_ok name "close_search");
op_network_extend_search = (fun _ _ -> ni_ok name "extend search");
op_network_clean_servers = (fun _ -> ni_ok name "clean servers");
- op_network_parse_url = (fun _ -> ni_ok name "parse_url"; "", false);
+ op_network_parse_url = (fun _ _ -> ni_ok name "parse_url"; "", false);
op_network_info = (fun _ -> fni name "network_info");
op_network_connected = (fun _ -> ni_ok name "connected"; false);
op_network_add_server = (fun _ -> fni name "op_network_add_server");
- op_network_gui_message = (fun _ -> ni_ok name "gui_message");
- op_network_download = (fun _ -> fni name "network_download");
+ op_network_gui_message = (fun _ _ -> ni_ok name "gui_message");
+ op_network_download = (fun _ _ -> fni name "network_download");
op_network_display_stats = (fun _ _ -> ni_ok name "display_stats");
op_network_clean_exit = (fun _ -> true);
op_network_reset = (fun _ -> ni_ok name "reset");
Index: src/daemon/common/commonNetwork.mli
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonNetwork.mli,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -b -r1.15 -r1.16
--- src/daemon/common/commonNetwork.mli 5 Sep 2006 14:15:19 -0000 1.15
+++ src/daemon/common/commonNetwork.mli 19 Sep 2006 17:07:42 -0000 1.16
@@ -56,6 +56,6 @@
CommonTypes.search -> CommonTypes.extend_search -> unit
val network_connected : CommonTypes.network -> bool
val network_clean_servers : CommonTypes.network -> unit
-val network_parse_url : CommonTypes.network -> string -> string * bool
+val network_parse_url : CommonTypes.network -> string -> string -> string *
bool
val network_info : CommonTypes.network -> CommonTypes.network_info
val commands_by_kind : (string, (string * string) list ref) Hashtbl.t
Index: src/daemon/common/commonOptions.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonOptions.ml,v
retrieving revision 1.176
retrieving revision 1.177
diff -u -b -r1.176 -r1.177
--- src/daemon/common/commonOptions.ml 16 Sep 2006 15:36:59 -0000 1.176
+++ src/daemon/common/commonOptions.ml 19 Sep 2006 17:07:42 -0000 1.177
@@ -1288,10 +1288,6 @@
ones in allowed_commands"
bool_option false
-let enable_user_config = define_option current_section ["enable_user_config"]
- "Are all users allowed to change MLDonkey options?"
- bool_option true
-
let allow_browse_share = define_option current_section ["allow_browse_share"]
"Allow others to browse our share list (0: none, 1: friends only, 2:
everyone"
allow_browse_share_option 1
Index: src/daemon/common/commonResult.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonResult.ml,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -b -r1.9 -r1.10
--- src/daemon/common/commonResult.ml 17 May 2006 08:52:43 -0000 1.9
+++ src/daemon/common/commonResult.ml 19 Sep 2006 17:07:42 -0000 1.10
@@ -142,13 +142,13 @@
result_source_network = 0;
}
-let result_download rs names force =
+let result_download rs names force user =
let r = IndexedResults.get_result rs in
let files = ref [] in
CommonNetwork.networks_iter (fun n ->
(* Temporarily download results only from the network that returned the
result *)
if (n.network_num = r.result_source_network) then
- files := (n.op_network_download r) :: !files
+ files := (n.op_network_download r user) :: !files
);
!files
Index: src/daemon/common/commonResult.mli
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonResult.mli,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- src/daemon/common/commonResult.mli 12 May 2006 21:02:38 -0000 1.5
+++ src/daemon/common/commonResult.mli 19 Sep 2006 17:07:42 -0000 1.6
@@ -78,7 +78,7 @@
val find_result : int -> StoredResult.stored_result
val dummy_result : CommonTypes.result_info
val result_download :
- StoredResult.stored_result -> 'a -> 'b -> CommonTypes.file list
+ StoredResult.stored_result -> 'a -> 'b -> string -> CommonTypes.file list
val results_iter : (int -> StoredResult.stored_result -> unit) -> unit
val update_result : StoredResult.result -> unit
val update_result2 :
Index: src/daemon/common/commonTypes.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonTypes.ml,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -b -r1.55 -r1.56
--- src/daemon/common/commonTypes.ml 5 Sep 2006 14:18:24 -0000 1.55
+++ src/daemon/common/commonTypes.ml 19 Sep 2006 17:07:42 -0000 1.56
@@ -480,7 +480,7 @@
mutable op_network_share : (
string -> string -> int64 -> unit);
mutable op_network_private_message : (string -> string -> unit);
- mutable op_network_parse_url : (string -> string * bool);
+ mutable op_network_parse_url : (string -> string -> string * bool);
mutable op_network_connect_servers : (unit -> unit);
mutable op_network_search : (search -> Buffer.t -> unit);
@@ -492,9 +492,9 @@
mutable op_network_info : (unit -> network_info);
mutable op_network_connected : (unit -> bool);
- mutable op_network_gui_message : (string -> unit);
+ mutable op_network_gui_message : (string -> string -> unit);
- mutable op_network_download : (result_info -> file);
+ mutable op_network_download : (result_info -> string -> file);
mutable op_network_display_stats : (Buffer.t -> ui_conn -> unit);
mutable op_network_clean_exit : (unit -> bool);
mutable op_network_reset : (unit -> unit);
Index: src/daemon/common/commonUserDb.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonUserDb.ml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- src/daemon/common/commonUserDb.ml 12 Aug 2006 20:36:14 -0000 1.5
+++ src/daemon/common/commonUserDb.ml 19 Sep 2006 17:07:42 -0000 1.6
@@ -31,18 +31,135 @@
let lprintf_n fmt =
lprintf2 log_prefix fmt
+(*************************************************************************)
+(* TYPES *)
+(*************************************************************************)
+
type userdb = {
user_name : string;
user_pass : Md4.t;
+ user_groups : string list;
+ user_default_group : string option;
user_mail : string;
+ user_commit_dir : string;
+ user_max_concurrent_downloads : int;
}
-let admin_user = "admin"
+type groupdb = {
+ group_name : string;
+ group_mail : string;
+ group_admin : bool;
+ }
+
+exception User_has_downloads of int
+
+(*************************************************************************)
+(* DEFAULTS *)
+(*************************************************************************)
+
+let users_ini = create_options_file "users.ini"
-let user2_is_admin user = user = admin_user
+let users2_section = file_section users_ini ["Users"] "User accounts on the
core (new format)"
+let users_section = file_section users_ini ["Users"] "User accounts on the
core (old format)"
let blank_password = Md4.string ""
+let admin_user = "admin"
+let system_user_default_group = "mldonkey"
+
+(*************************************************************************)
+(* GroupOption *)
+(*************************************************************************)
+
+module GroupOption = struct
+
+ let value_to_group v =
+ match v with
+ Options.Module assocs ->
+ let get_value name conv = conv (List.assoc name assocs) in
+ let gname =
+ try
+ get_value "group_name" value_to_string
+ with _ -> system_user_default_group
+ in
+ let gmail =
+ try
+ get_value "group_mail" value_to_string
+ with _ -> ""
+ in
+ let gadmin =
+ try
+ get_value "group_admin" value_to_bool
+ with _ -> true
+ in
+ { group_name = gname;
+ group_mail = gmail;
+ group_admin = gadmin;
+ }
+
+ | _ -> failwith "Options: not a valid group"
+
+ let group_to_value group =
+ Options.Module [
+ "group_name", string_to_value group.group_name;
+ "group_mail", string_to_value group.group_mail;
+ "group_admin", bool_to_value group.group_admin;
+ ]
+
+ let t = define_option_class "Groups" value_to_group group_to_value
+
+ end
+
+let grouplist = define_option users2_section ["groups"]
+ "The groups that are defined on this core.
+
+group_admin = Are members of this group MLDonkey admins?
+ Only members of this group can change settings and see
uploads.
+"
+ (list_option GroupOption.t)
+ [
+ { group_name = system_user_default_group;
+ group_mail = "";
+ group_admin = true;
+ };
+ ]
+
+(*************************************************************************)
+(* Group database functions *)
+(*************************************************************************)
+
+let user2_group_iter f =
+ List.iter f !!grouplist
+
+let user2_group_add name ?(mail = "") ?(admin = true) () =
+ let new_group = {
+ group_name = name;
+ group_mail = mail;
+ group_admin = admin;
+ } in
+ grouplist =:= new_group :: List.filter (fun g -> g.group_name <> name)
!!grouplist
+
+let user2_group_remove name =
+ grouplist =:= List.filter (fun g -> g.group_name <> name) !!grouplist
+
+let user2_group_find group =
+ List.find (fun g -> g.group_name = group) !!grouplist
+
+let user2_group_exists group =
+ try
+ ignore (user2_group_find group);
+ true
+ with Not_found -> false
+
+let user2_group_exists_option group =
+ match group with
+ None -> true
+ | Some group -> user2_group_exists group
+
+(*************************************************************************)
+(* UserOption *)
+(*************************************************************************)
+
module UserOption = struct
let value_to_user v =
@@ -65,9 +182,48 @@
get_value "user_mail" value_to_string
with _ -> ""
in
+ let ucdir =
+ try
+ get_value "user_commit_dir" value_to_string
+ with _ -> ""
+ in
+ let umaxdl =
+ try
+ get_value "user_max_concurrent_downloads" value_to_int
+ with _ -> 0
+ in
+ let ugroups =
+ try
+ let ugl = get_value "user_groups" (value_to_list
value_to_string) in
+ List.filter (fun g -> user2_group_exists g) ugl
+ with _ -> [system_user_default_group]
+ in
+ let udgroup =
+ try
+ match get_value "user_default_group" stringvalue_to_option with
+ None -> None
+ | Some udg ->
+ if user2_group_exists udg then
+ if List.mem udg ugroups then
+ Some udg
+ else begin
+ lprintf_nl "User %s is not member of group %s, setting
user_default_group to None" uname udg;
+ None
+ end
+ else begin
+ lprintf_nl "user_default_group %s of user %s does not
exist, setting to None" udg uname;
+ None
+ end
+ with _ -> Some system_user_default_group
+ in
{ user_name = uname;
user_pass = upass;
- user_mail = umail; }
+ user_groups = ugroups;
+ user_default_group = udgroup;
+ user_mail = umail;
+ user_commit_dir = ucdir;
+ user_max_concurrent_downloads = umaxdl;
+ }
| _ -> failwith "Options: not a valid user"
@@ -75,94 +231,289 @@
Options.Module [
"user_name", string_to_value user.user_name;
"user_pass", string_to_value (Md4.to_string user.user_pass);
- "user_mail", string_to_value user.user_mail; ]
+ "user_groups", list_to_value string_to_value user.user_groups;
+ "user_default_group", option_to_stringvalue user.user_default_group;
+ "user_mail", string_to_value user.user_mail;
+ "user_commit_dir", string_to_value user.user_commit_dir;
+ "user_max_concurrent_downloads", int_to_value
user.user_max_concurrent_downloads;
+ ]
let t = define_option_class "Users" value_to_user user_to_value
end
-let users_ini = create_options_file "users.ini"
-
-let users_section = file_section users_ini ["Users"] "User accounts on the
core"
-let users2_section = file_section users_ini ["Users"] "User accounts on the
core (new format)"
-
-let users = define_option users_section ["users"]
- "Depreciated option, kept for compatibility reasons - used by MLDonkey <
2.7.5"
- (list_option (tuple2_option (string_option, Md4.option)))
- []
-
let userlist = define_option users2_section ["users2"]
"The users that are defined on this core. The default user is
called 'admin', and uses an empty password. To create new users,
-login as admin in mldonkey, and use the 'useradd' command."
+login as admin in mldonkey, and use the 'useradd' command.
+
+user_groups = Files belonging to one of these groups can be
seen by the user.
+user_default_group = New downloads by this user will belong to this
group.
+user_commit_dir = Commit files to <incoming>/<user_commit_dir>
+user_max_concurrent_downloads = Maximum number of downloads allowed, 0 =
unlimited
+"
(list_option UserOption.t)
[ { user_name = admin_user;
user_pass = blank_password;
- user_mail = "" } ]
-
-let users2 = Hashtbl.create 10
+ user_groups = [system_user_default_group];
+ user_default_group = Some system_user_default_group;
+ user_mail = "";
+ user_commit_dir = "";
+ user_max_concurrent_downloads = 0;
+ } ]
-let user2_iter f =
- Hashtbl.iter f users2
+let users = define_option users_section ["users"]
+ "Depreciated option, kept for compatibility reasons - used by MLDonkey <
2.7.5"
+ (list_option (tuple2_option (string_option, Md4.option)))
+ [admin_user, blank_password]
-let user2_add name pass mail =
- let u = {
+(*************************************************************************)
+(* User database functions *)
+(*************************************************************************)
+
+let user2_user_iter f =
+ List.iter f !!userlist
+
+let user2_user_add name pass ?(groups = [system_user_default_group])
+ ?(default_group = Some system_user_default_group)
+ ?(mail = "") ?(commit_dir = "") ?(max_dl = 0) () =
+ let groups =
+ let l =
+ (List.filter (fun g -> user2_group_exists g) groups)
+ in
+ if l = [] then
+ [system_user_default_group]
+ else l
+ in
+ let default_group =
+ match default_group with
+ | None -> default_group
+ | Some group -> if not (user2_group_exists group) then None else Some group
+ in
+ let new_user = {
user_name = name;
user_pass = pass;
+ user_groups = groups;
+ user_default_group = default_group;
+ user_mail = mail;
+ user_commit_dir = commit_dir;
+ user_max_concurrent_downloads = max_dl;
+ } in
+ userlist =:= new_user :: List.filter (fun u -> u.user_name <> name)
!!userlist
+
+let user2_user_remove user =
+ userlist =:= List.filter (fun u -> u.user_name <> user) !!userlist
+
+let user2_user_find user =
+ List.find (fun u -> u.user_name = user) !!userlist
+
+let user2_user_exist user =
+ try
+ ignore (user2_user_find user);
+ true
+ with Not_found -> false
+
+(*************************************************************************)
+(* User database functions / passwords *)
+(*************************************************************************)
+
+let user2_user_password user =
+ (user2_user_find user).user_pass
+
+let user2_user_set_password user pass_string =
+ let new_user = {
+ (user2_user_find user) with
+ user_pass = Md4.string pass_string
+ } in
+ userlist =:= new_user :: List.filter (fun u -> u.user_name <> user)
!!userlist
+
+let valid_password user pass =
+ try
+ user2_user_password user = Md4.string pass
+ with Not_found -> false
+
+let empty_password user =
+ valid_password user ""
+
+(*************************************************************************)
+(* User database functions / mail *)
+(*************************************************************************)
+
+let user2_user_mail user =
+ (user2_user_find user).user_mail
+
+let user2_print_user_mail user =
+ try
+ user2_user_mail user
+ with Not_found -> ""
+
+let user2_user_set_mail user mail =
+ let new_user = {
+ (user2_user_find user) with
user_mail = mail
} in
- Hashtbl.replace users2 name u;
- u
+ userlist =:= new_user :: List.filter (fun u -> u.user_name <> user)
!!userlist
+
+(*************************************************************************)
+(* User database functions / concurrent downloads *)
+(*************************************************************************)
+
+let user2_user_dls user =
+ (user2_user_find user).user_max_concurrent_downloads
+
+let user2_print_user_dls user =
+ try
+ let dls = user2_user_dls user in
+ if dls = 0 then "unlimited"
+ else (Printf.sprintf "%d" dls)
+ with Not_found -> "unknown"
+
+let user2_user_set_dls user dls =
+ let new_user = {
+ (user2_user_find user) with
+ user_max_concurrent_downloads = dls
+ } in
+ userlist =:= new_user :: List.filter (fun u -> u.user_name <> user)
!!userlist
+
+(*************************************************************************)
+(* User database functions / commit dir *)
+(*************************************************************************)
+
+let user2_user_commit_dir user =
+ (user2_user_find user).user_commit_dir
+
+let user2_print_user_commit_dir user =
+ try
+ user2_user_commit_dir user
+ with Not_found -> ""
+
+let user2_user_set_commit_dir user dir =
+ let new_user = {
+ (user2_user_find user) with
+ user_commit_dir = dir
+ } in
+ userlist =:= new_user :: List.filter (fun u -> u.user_name <> user)
!!userlist
-let user2_remove user =
- Hashtbl.remove users2 user
+(*************************************************************************)
+(* User/Group database functions *)
+(*************************************************************************)
-let user2_find user =
+let user2_user_groups user =
try
- Hashtbl.find users2 user
+ (user2_user_find user).user_groups
with Not_found -> failwith (Printf.sprintf "User %s does not exist" user)
-let user2_password user =
+let user2_user_groups_safe user =
try
- let u = user2_find user in
- u.user_pass
+ (user2_user_find user).user_groups
+ with Not_found -> []
+
+let user2_user_groups_safe_default user =
+ try
+ (user2_user_find user).user_groups
+ with Not_found -> [system_user_default_group]
+
+let user2_user_groups_iter user f =
+ List.iter f (user2_user_groups_safe user)
+
+let user2_print_user_groups user =
+ try
+ let u = user2_user_find user in
+ String.concat "," u.user_groups
+ with Not_found -> ""
+
+let user2_user_default_group user =
+ try
+ (user2_user_find user).user_default_group
+ with Not_found -> None
+
+let user2_print_user_default_group user =
+ try
+ let u = user2_user_find user in
+ match u.user_default_group with
+ None -> "none"
+ | Some group -> group
with Not_found -> failwith (Printf.sprintf "User %s does not exist" user)
-let user2_mail user =
+let user2_user_add_group user group =
+ if not (user2_group_exists group) then
+ user2_group_add group ();
try
- let u = user2_find user in
- u.user_mail
+ let u = user2_user_find user in
+ user2_user_add
+ u.user_name
+ u.user_pass
+ ?groups:(Some (List.append u.user_groups [group]))
+ ?mail:(Some u.user_mail)
with Not_found -> failwith (Printf.sprintf "User %s does not exist" user)
-let valid_password user pass =
+let user2_user_remove_group user group =
try
- user2_password user = Md4.string pass
- with e -> false
+ let u = user2_user_find user in
+ user2_user_add
+ u.user_name
+ u.user_pass
+ ?groups:(Some (List.filter (fun g -> not (g = group)) u.user_groups))
+ ?mail:(Some u.user_mail)
+ with Not_found -> failwith (Printf.sprintf "User %s does not exist" user)
-let empty_password user =
+let user2_user_is_group_member user group =
+ List.mem group (user2_user_groups_safe user)
+
+(*************************************************************************)
+(* Access rights *)
+(*************************************************************************)
+
+let user2_is_admin user =
+ user = admin_user ||
+ List.exists (fun groupname ->
try
- let p = user2_password user in
- p = blank_password
- with _ -> false
+ (user2_group_find groupname).group_admin
+ with Not_found -> false)
+ (user2_user_groups_safe user)
+
+let user2_can_view_uploads user =
+ user2_is_admin user
+
+let user2_can_view_file gui_user file_owner file_group =
+ user2_is_admin gui_user || gui_user = file_owner ||
+ (match file_group with
+ | None -> false
+ | Some file_group -> user2_user_is_group_member gui_user file_group)
+
+let print_command_result o buf result =
+ if use_html_mods o then
+ html_mods_table_one_row buf "serversTable" "servers" [
+ ("", "srh", result); ]
+ else
+ Printf.bprintf buf "%s" result
+
+(*************************************************************************)
+(* Hooks *)
+(*************************************************************************)
let _ =
set_after_load_hook users_ini (fun _ ->
- List.iter (fun user ->
- ignore (user2_add user.user_name user.user_pass user.user_mail)
- ) !!userlist;
- userlist =:= [];
- if !!users <> [] then begin
- lprintf_nl "converting %d users to new format" (List.length !!users);
- List.iter (fun (user,pass) -> ignore (user2_add user pass "")) !!users;
- users =:= []
+ List.iter (fun (user,pass) ->
+ if not (user2_user_exist user) then begin
+ user2_user_add user pass ();
+ lprintf_nl "converted user %s to new format" user
+ end) !!users;
+(* clean !!users to avoid saving users more than once *)
+ users =:= [];
+ if not (user2_user_exist admin_user) then
+ begin
+ user2_user_add admin_user blank_password ();
+ lprintf_nl "SECURITY INFO: user 'admin' has to be present, creating
with empty password!..."
end
);
+
+(* This code provides backward-compatibility for older MLDonkey clients *)
+(* reading new user db and copying the values into old user db !!users *)
set_before_save_hook users_ini (fun _ ->
- user2_iter (fun _ user ->
- userlist =:= (user2_find user.user_name) :: !!userlist;
- users =:= (user.user_name, (user2_password user.user_name)) ::
!!users
+ user2_user_iter (fun user ->
+ users =:= (user.user_name, (user2_user_password user.user_name)) ::
!!users
)
);
- set_after_save_hook users_ini (fun _ ->
- userlist =:= [];
- users =:= [])
+(* clean !!users to avoid saving users more than once *)
+ set_after_save_hook users_ini (fun _ -> users =:= [])
Index: src/daemon/driver/driverCommands.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/driver/driverCommands.ml,v
retrieving revision 1.175
retrieving revision 1.176
diff -u -b -r1.175 -r1.176
--- src/daemon/driver/driverCommands.ml 16 Sep 2006 09:38:59 -0000 1.175
+++ src/daemon/driver/driverCommands.ml 19 Sep 2006 17:07:43 -0000 1.176
@@ -1301,7 +1301,7 @@
begin
let r = List.hd !forceable_download in
CommonNetwork.networks_iter (fun n ->
- ignore(n.op_network_download r));
+ ignore (n.op_network_download r o.conn_user.ui_user_name));
let output = (if o.conn_output = HTML then begin
let buf = Buffer.create 100 in
@@ -1702,7 +1702,6 @@
| 8 ->
[
strings_of_option term_ansi;
- strings_of_option enable_user_config;
strings_of_option messages_filter;
strings_of_option max_displayed_results;
strings_of_option max_name_len;
@@ -2160,6 +2159,17 @@
"upstats", Arg_none (fun o ->
let buf = o.conn_buf in
+ if not (user2_can_view_uploads o.conn_user.ui_user_name) then
+ begin
+ if use_html_mods o then
+ html_mods_table_one_row buf "upstatsTable" "upstats" [
+ ("", "srh", "You are not allowed to see upload statistics") ]
+ else
+ Printf.bprintf buf "You are not allowed to see upload
statistics\n"
+ end
+ else
+ begin
+
if use_html_mods o then begin
if !!html_mods_use_js_tooltips then Printf.bprintf buf
@@ -2258,14 +2268,23 @@
(shorten (Filename.basename impl.impl_shared_codedname)
!!max_name_len);
) list;
- if use_html_mods o then Printf.bprintf buf
"\\</table\\>\\</div\\>\\</div\\>";
-
-
+ if use_html_mods o then Printf.bprintf buf
"\\</table\\>\\</div\\>\\</div\\>"
+ end;
_s ""
), ":\t\t\t\tstatistics on upload";
"links", Arg_none (fun o ->
let buf = o.conn_buf in
+ if not (user2_can_view_uploads o.conn_user.ui_user_name) then
+ begin
+ if use_html_mods o then
+ html_mods_table_one_row buf "upstatsTable" "upstats" [
+ ("", "srh", "You are not allowed to see shared files list") ]
+ else
+ Printf.bprintf buf "You are not allowed to see shared files
list\n"
+ end
+ else begin
+
let list = ref [] in
shared_iter (fun s ->
let impl = as_shared_impl s in
@@ -2285,12 +2304,26 @@
(Filename.basename impl.impl_shared_codedname)
impl.impl_shared_size impl.impl_shared_id);
) list;
+ end;
"Done"
), ":\t\t\t\t\tlist links of shared files";
"uploaders", Arg_none (fun o ->
let buf = o.conn_buf in
+ if not (user2_can_view_uploads o.conn_user.ui_user_name) then
+ begin
+ begin
+ if use_html_mods o then
+ html_mods_table_one_row buf "upstatsTable" "upstats" [
+ ("", "srh", "You are not allowed to see uploaders list") ]
+ else
+ Printf.bprintf buf "You are not allowed to see uploaders
list\n";
+ end;
+ ""
+ end
+ else begin
+
let nuploaders = Intmap.length !uploaders in
if use_html_mods o then
@@ -2457,6 +2490,7 @@
end
+ end
), ":\t\t\t\tshow users currently uploading";
@@ -2504,7 +2538,7 @@
"yes" | "y" | "true" ->
List.iter (fun file ->
try
- file_cancel file
+ file_cancel file o.conn_user.ui_user_name
with e ->
lprintf "Exception %s in cancel file %d\n"
(Printexc2.to_string e) (file_num file)
@@ -2541,7 +2575,7 @@
if not (List.memq num !to_cancel) then
to_cancel := num :: !to_cancel
in
- if args = ["all"] then
+ if args = ["all"] && user2_is_admin o.conn_user.ui_user_name then
List.iter (fun file ->
file_cancel file
) !!files
@@ -2611,32 +2645,30 @@
), "<num> :\t\t\tverify chunks of file <num>";
"pause", Arg_multiple (fun args o ->
- if args = ["all"] then
+ if args = ["all"] && user2_is_admin o.conn_user.ui_user_name then
List.iter (fun file ->
- file_pause file;
+ file_pause file admin_user;
) !!files
else
List.iter (fun num ->
let num = int_of_string num in
List.iter (fun file ->
- if (as_file_impl file).impl_file_num = num then begin
- file_pause file
- end
+ if (as_file_impl file).impl_file_num = num then
+ file_pause file o.conn_user.ui_user_name
) !!files) args; ""
), "<num> :\t\t\t\tpause a download (use arg 'all' for all files)";
"resume", Arg_multiple (fun args o ->
- if args = ["all"] then
+ if args = ["all"] && user2_is_admin o.conn_user.ui_user_name then
List.iter (fun file ->
- file_resume file
+ file_resume file admin_user
) !!files
else
List.iter (fun num ->
let num = int_of_string num in
List.iter (fun file ->
- if (as_file_impl file).impl_file_num = num then begin
- file_resume file
- end
+ if (as_file_impl file).impl_file_num = num then
+ file_resume file o.conn_user.ui_user_name
) !!files) args; ""
), "<num> :\t\t\t\tresume a paused download (use arg 'all' for all files)";
@@ -2655,20 +2687,19 @@
"vd", Arg_multiple (fun args o ->
let buf = o.conn_buf in
+ let list = user2_filter_files !!files o.conn_user.ui_user_name in
+ let filelist = List2.tail_map file_info list in
match args with
| ["queued"] ->
- let list = List2.tail_map file_info !!files in
- let list = List.filter ( fun f -> f.file_state = FileQueued )
list in
+ let list = List.filter ( fun f -> f.file_state = FileQueued )
filelist in
DriverInteractive.display_active_file_list buf o list;
""
| ["paused"] ->
- let list = List2.tail_map file_info !!files in
- let list = List.filter ( fun f -> f.file_state = FilePaused )
list in
+ let list = List.filter ( fun f -> f.file_state = FilePaused )
filelist in
DriverInteractive.display_active_file_list buf o list;
""
| ["downloading"] ->
- let list = List2.tail_map file_info !!files in
- let list = List.filter ( fun f -> f.file_state = FileDownloading
) list in
+ let list = List.filter ( fun f -> f.file_state = FileDownloading
) filelist in
DriverInteractive.display_file_list buf o list;
""
| [arg] ->
@@ -2696,15 +2727,14 @@
List.iter
(fun file -> if (as_file_impl file).impl_file_num = num then
CommonFile.file_print file o)
- !!files;
+ list;
List.iter
(fun file -> if (as_file_impl file).impl_file_num = num then
CommonFile.file_print file o)
!!done_files;
""
| _ ->
- let list = List2.tail_map file_info !!files in
- DriverInteractive.display_file_list buf o list;
+ DriverInteractive.display_file_list buf o filelist;
""
), "[<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";
@@ -2726,14 +2756,15 @@
), "<num> \"<new name>\" :\t\tchange name of download <num> to <new name>";
"filenames_variability", Arg_none (fun o ->
- let list = List2.tail_map file_info !!files in
+ let list = List2.tail_map file_info
+ (user2_filter_files !!files o.conn_user.ui_user_name) in
DriverInteractive.filenames_variability o list;
_s "done"
), ":\t\t\ttell which files have several very different names";
"dllink", Arg_multiple (fun args o ->
let url = String2.unsplit args ' ' in
- dllink_parse (o.conn_output = HTML) url
+ dllink_parse (o.conn_output = HTML) url o.conn_user.ui_user_name
), "<link> :\t\t\t\tdownload ed2k, sig2dat, torrent or other link";
"dllinks", Arg_one (fun arg o ->
@@ -2741,7 +2772,7 @@
let file = File.to_string arg in
let lines = String2.split_simplify file '\n' in
List.iter (fun line ->
- Buffer.add_string result (dllink_parse (o.conn_output = HTML) line);
+ Buffer.add_string result (dllink_parse (o.conn_output = HTML) line
o.conn_user.ui_user_name);
Buffer.add_string result (if o.conn_output = HTML then "\\<P\\>" else
"\n")
) lines;
(Buffer.contents result)
@@ -2760,65 +2791,148 @@
"useradd", Arg_multiple (fun args o ->
let buf = o.conn_buf in
- let print_result o result =
- if o.conn_output = HTML then
- html_mods_table_one_row buf "serversTable" "servers" [
- ("", "srh", result); ]
- else
- Printf.bprintf buf "%s" result
- in
- let add_new_user user pass mail =
- if o.conn_user == default_user
- || o.conn_user == (find_ui_user user) then
+ let add_new_user user pass_string =
+ if user2_is_admin o.conn_user.ui_user_name
+ || o.conn_user.ui_user_name = (find_ui_user user).ui_user_name then
try
- ignore (user2_find user);
- ignore (user2_add user (Md4.string pass) "");
- print_result o (Printf.sprintf "Password of user %s changed" user)
- with _ ->
- ignore (user2_add user (Md4.string pass) "");
- print_result o (Printf.sprintf "User %s added" user)
+ user2_user_set_password user pass_string;
+ print_command_result o buf (Printf.sprintf "Password of user %s
changed" user)
+ with Not_found ->
+ user2_user_add user (Md4.string pass_string) ();
+ print_command_result o buf (Printf.sprintf "User %s added with
default values" user)
else
- print_result o "Only 'admin' is allowed to add users"
+ print_command_result o buf "You are not allowed to add users"
in begin
match args with
- user :: pass :: mail :: _ ->
- add_new_user user pass mail
- | user :: pass :: _ ->
- add_new_user user pass "";
- | _ -> print_result o "Wrong syntax: use 'useradd user pass <mail>'"
+ user :: pass_string :: _ ->
+ add_new_user user pass_string;
+ | _ -> print_command_result o buf "Wrong syntax: use 'useradd user
pass'"
end;
_s ""
- ), "<user> <passwd> [<mail>] :\tadd new mldonkey user/change user
password";
+ ), "<user> <passwd> :\t\tadd new mldonkey user/change user password";
"userdel", Arg_one (fun user o ->
let buf = o.conn_buf in
- let print_result o result =
- if o.conn_output = HTML then
- html_mods_table_one_row buf "serversTable" "servers" [
- ("", "srh", result); ]
- else
- Printf.bprintf buf "%s" result
- in
- if o.conn_user == default_user then
+ if user <> o.conn_user.ui_user_name then
+ if user2_is_admin o.conn_user.ui_user_name then
if user = admin_user then
- print_result o "User 'admin' can not be removed"
+ print_command_result o buf "User 'admin' can not be removed"
else
try
- ignore (user2_find user);
- ignore (user2_remove user);
- print_result o (Printf.sprintf "User %s removed" user)
- with _ ->
- print_result o (Printf.sprintf "User %s not found" user)
+ let n = user2_user_dls_count user in if n <> 0 then raise
(User_has_downloads n);
+ ignore (user2_user_find user);
+ ignore (user2_user_remove user);
+ print_command_result o buf (Printf.sprintf "User %s removed"
user)
+ with
+ Not_found -> print_command_result o buf (Printf.sprintf "User
%s does not exist" user)
+ | User_has_downloads n -> print_command_result o buf
+ (Printf.sprintf "User %s has %d downloads, can not delete"
user n)
+ else
+ print_command_result o buf "You are not allowed to remove users"
else
- print_result o "Only 'admin' is allowed to remove users";
+ print_command_result o buf "You can not remove yourself";
_s ""
), "<user> :\t\t\tremove a mldonkey user";
+ "passwd", Arg_one (fun passwd o ->
+ let buf = o.conn_buf in
+ let user = o.conn_user.ui_user_name in
+ begin
+ try
+ user2_user_set_password user passwd;
+ print_command_result o buf (Printf.sprintf "Password of user %s
changed" user)
+ with Not_found -> print_command_result o buf (Printf.sprintf "User %s
does not exist" user)
+ end;
+ _s ""
+ ), "<passwd> :\t\tchange own password";
- "users", Arg_none (fun o ->
- if o.conn_user == default_user then
+ "usermail", Arg_two (fun user mail o ->
+ let buf = o.conn_buf in
+ if user2_is_admin o.conn_user.ui_user_name
+ || o.conn_user.ui_user_name = (find_ui_user user).ui_user_name then
+ begin
+ try
+ user2_user_set_mail user mail;
+ print_command_result o buf (Printf.sprintf "User %s has new mail
%s" user mail)
+ with Not_found -> print_command_result o buf (Printf.sprintf "User
%s does not exist" user)
+ end
+ else print_command_result o buf "You are not allowed to change mail
addresses";
+ _s ""
+ ), "<user> <mail> :\t\tchange user mail address";
+
+ "userdls", Arg_two (fun user dls o ->
+ let buf = o.conn_buf in
+ if user2_is_admin o.conn_user.ui_user_name
+ || o.conn_user.ui_user_name = (find_ui_user user).ui_user_name then
+ begin
+ try
+ user2_user_set_dls user (int_of_string dls);
+ print_command_result o buf (Printf.sprintf "User %s has now %s
downloads allowed" user (user2_print_user_dls user))
+ with Not_found -> print_command_result o buf (Printf.sprintf "User
%s does not exist" user)
+ end
+ else print_command_result o buf "You are not allowed to change this
value";
+ _s ""
+ ), "<user> <num> :\t\tchange number of allowed concurrent downloads";
+
+ "usercommit", Arg_two (fun user dir o ->
+ let buf = o.conn_buf in
+ if user2_is_admin o.conn_user.ui_user_name
+ || o.conn_user.ui_user_name = (find_ui_user user).ui_user_name then
+ begin
+ try
+ user2_user_set_commit_dir user dir;
+ print_command_result o buf (Printf.sprintf "User %s has new
commit dir %s" user (user2_print_user_commit_dir user))
+ with Not_found -> print_command_result o buf (Printf.sprintf "User
%s does not exist" user)
+ end
+ else print_command_result o buf "You are not allowed to change this
value";
+ _s ""
+ ), "<user> <dir> :\t\tchange user specific commit directory";
+
+ "groupadd", Arg_multiple (fun args o ->
+ let buf = o.conn_buf in
+ let add_new_group group admin mail =
+ if user2_is_admin o.conn_user.ui_user_name then
+ if user2_group_exists group then
+ print_command_result o buf (Printf.sprintf "Group %s already
exists, use groupmod for updates" group)
+ else
+ begin
+ user2_group_add group ?mail:(Some mail) ?admin:(Some admin) ();
+ print_command_result o buf (Printf.sprintf "Group %s added"
group)
+ end
+ else
+ print_command_result o buf "You are not allowed to add group"
+ in begin
+ match args with
+ group :: admin :: mail :: _ ->
+ let a =
+ try
+ bool_of_string admin
+ with _ -> false
+ in
+ add_new_group group a mail
+ | group :: admin :: _ ->
+ let a =
+ try
+ bool_of_string admin
+ with _ -> false
+ in
+ add_new_group group a ""
+ | _ -> print_command_result o buf "Wrong syntax: use 'groupadd group
true|false'"
+ end;
+ _s ""
+ ), "<group> <admin: true | false> [<mail>] :\t\tadd new mldonkey group";
+ "groupdel", Arg_one (fun group o ->
let buf = o.conn_buf in
+(* if user2_is_admin o.conn_user.ui_user_name then _s ""
+ else
+ print_command_result o buf "You are not allowed to remove users"; *)
+ _s ""
+ ), "<group> :\t\t\tremove an unused mldonkey group";
+
+ "users", Arg_none (fun o ->
+ let buf = o.conn_buf in
+ if user2_is_admin o.conn_user.ui_user_name then begin
if use_html_mods o then begin
Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table
class=main cellspacing=0 cellpadding=0\\>
@@ -2831,23 +2945,27 @@
var outstr = getdir.replace(reg, '+');
parent.fstatus.location.href='submit?q=useradd+' + outstr;
setTimeout('window.location.reload()',1000);
- }\\\"\\>Add User\\</a\\>
-\\</td\\>
-\\</tr\\>\\</table\\>
-\\</td\\>\\</tr\\>
-\\<tr\\>\\<td\\>";
+ }\\\"\\>Add user\\</a\\>
+\\</td\\>\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\<tr\\>\\<td\\>";
html_mods_table_header buf "sharesTable" "shares" [
( "0", "srh ac", "Click to remove user", "Remove" ) ;
- ( "0", "srh", "User", "Username" ) ];
+ ( "0", "srh", "Username", "User" ) ;
+ ( "0", "srh ac", "Admin", "Admin" ) ;
+ ( "0", "srh", "Member of groups", "Groups" ) ;
+ ( "0", "srh", "Default group", "Default group" ) ;
+ ( "0", "srh", "Mail address", "Email" ) ;
+ ( "0", "srh", "Commit dir", "Commit dir" ) ;
+ ( "0", "srh ar", "Download quota", "Max DLs" ) ;
+ ( "0", "srh ar", "Download count", "DLs" ) ];
let counter = ref 0 in
-
- user2_iter (fun name user ->
+ user2_user_iter (fun user ->
incr counter;
+ let u_dls = user2_user_dls_count user.user_name in
Printf.bprintf buf "\\<tr class=\\\"%s\\\"\\>"
(if !counter mod 2 == 0 then "dl-1" else "dl-2");
- if user.user_name <> admin_user then Printf.bprintf buf "
+ if user.user_name <> admin_user && (u_dls = 0) then
Printf.bprintf buf "
\\<td title=\\\"Click to remove user\\\"
onMouseOver=\\\"mOvr(this);\\\"
onMouseOut=\\\"mOut(this);\\\"
@@ -2859,27 +2977,144 @@
\\<td title=\\\"\\\"
class=\\\"srb\\\"\\>------\\</td\\>";
Printf.bprintf buf
- "\\<td class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>" user.user_name
+ "\\<td class=\\\"sr\\\"\\>%s\\</td\\>" user.user_name;
+ Printf.bprintf buf
+ "\\<td class=\\\"sr ac\\\"\\>%b\\</td\\>" (user2_is_admin
user.user_name);
+ Printf.bprintf buf
+ "\\<td class=\\\"sr\\\"\\>%s\\</td\\>"
(user2_print_user_groups user.user_name);
+ Printf.bprintf buf
+ "\\<td class=\\\"sr\\\"\\>%s\\</td\\>"
(user2_print_user_default_group user.user_name);
+ Printf.bprintf buf
+ "\\<td class=\\\"sr\\\"\\>%s\\</td\\>" (user2_print_user_mail
user.user_name);
+ Printf.bprintf buf
+ "\\<td class=\\\"sr\\\"\\>%s\\</td\\>"
(user2_print_user_commit_dir user.user_name);
+ Printf.bprintf buf
+ "\\<td class=\\\"sr ar\\\"\\>%s\\</td\\>"
(user2_print_user_dls user.user_name);
+ Printf.bprintf buf
+ "\\<td class=\\\"sr ar\\\"\\>%d\\</td\\>" u_dls
+ );
+ Printf.bprintf buf
"\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
+ print_option_help o userlist;
+ Printf.bprintf buf "\\<P\\>";
+
+ Printf.bprintf buf "\\<div class=\\\"shares\\\"\\>\\<table
class=main cellspacing=0 cellpadding=0\\>
+\\<tr\\>\\<td\\>
+\\<table cellspacing=0 cellpadding=0 width=100%%\\>\\<tr\\>
+\\<td class=downloaded width=100%%\\>\\</td\\>
+\\<td nowrap class=\\\"fbig pr\\\"\\>\\<a onclick=\\\"javascript: {
+ var getdir = prompt('Input: <group> <admin: true|false>
[<mail>]','group true')
+ var reg = new RegExp (' ', 'gi') ;
+ var outstr = getdir.replace(reg, '+');
+ parent.fstatus.location.href='submit?q=groupadd+' + outstr;
+ setTimeout('window.location.reload()',1000);
+ }\\\"\\>Add group\\</a\\>
+\\</td\\>\\</tr\\>\\</table\\>\\</td\\>\\</tr\\>\\<tr\\>\\<td\\>";
+
+ html_mods_table_header buf "sharesTable" "shares" [
+ ( "0", "srh ac", "Click to remove group", "Remove" ) ;
+ ( "0", "srh", "Groupname", "Group" ) ;
+ ( "0", "srh ac", "Admin group", "Admin" ) ;
+ ( "0", "srh", "Mail address", "Email" ) ;
+ ( "0", "srh ar", "Download count", "DLs" ) ];
+
+ let counter = ref 0 in
+ user2_group_iter (fun group ->
+ incr counter;
+ let g_dls = user2_group_dls_count group.group_name in
+ Printf.bprintf buf "\\<tr class=\\\"%s\\\"\\>"
+ (if !counter mod 2 == 0 then "dl-1" else "dl-2");
+ if g_dls = 0 then Printf.bprintf buf "
+ \\<td title=\\\"Click to remove group\\\"
+ onMouseOver=\\\"mOvr(this);\\\"
+ onMouseOut=\\\"mOut(this);\\\"
+ onClick=\\\'javascript:{
+
parent.fstatus.location.href=\\\"submit?q=groupdel+\\\\\\\"%s\\\\\\\"\\\";
+ setTimeout(\\\"window.location.reload()\\\",1000);}'
+ class=\\\"srb\\\"\\>Remove\\</td\\>" group.group_name
+ else Printf.bprintf buf "
+ \\<td title=\\\"\\\"
+ class=\\\"srb\\\"\\>------\\</td\\>";
+ Printf.bprintf buf
+ "\\<td class=\\\"sr\\\"\\>%s\\</td\\>" group.group_name;
+ Printf.bprintf buf
+ "\\<td class=\\\"sr ac\\\"\\>%b\\</td\\>" group.group_admin;
+ Printf.bprintf buf
+ "\\<td class=\\\"sr\\\"\\>%s\\</td\\>" group.group_mail;
+ Printf.bprintf buf
+ "\\<td class=\\\"sr ar\\\"\\>%d\\</td\\>" g_dls
);
+ Printf.bprintf buf
"\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>\\<P\\>";
+ print_option_help o grouplist;
+ Printf.bprintf buf "\\<P\\>";
- Printf.bprintf buf
"\\</table\\>\\</td\\>\\<tr\\>\\</table\\>\\</div\\>";
+ Buffer.add_string buf "\\<div class=\\\"cs\\\"\\>";
+ html_mods_table_header buf "helpTable" "results" [];
+ Buffer.add_string buf "\\<tr\\>";
+ html_mods_td buf [
+ ("", "srh", "");
+ ("", "srh", "Commands to manipulate user data");
+ ("", "srh", ""); ];
+ Buffer.add_string buf "\\</tr\\>";
+ html_mods_cntr_init ();
+ let list = Hashtbl2.to_list2 commands_by_kind in
+ let list = List.sort (fun (s1,_) (s2,_) -> compare s1 s2) list in
+ List.iter (fun (s,list) ->
+ if s = "Driver/Users" then
+ let list = List.sort (fun (s1,_) (s2,_) -> compare s1 s2) !list
in
+ List.iter (fun (cmd, help) ->
+ Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>"
(html_mods_cntr ());
+ html_mods_td buf [
+ ("", "sr", "\\<a href=\\\"submit?q=" ^ cmd ^
+ "\\\"\\>" ^ cmd ^ "\\</a\\>");
+ ("", "srw", Str.global_replace (Str.regexp "\n") "\\<br\\>"
help);
+ ("", "sr", "\\<a href=\\\"http://mldonkey.sourceforge.net/";
^ (String2.upp_initial cmd) ^
+ "\\\"\\>wiki\\</a\\>"); ];
+ Printf.bprintf buf "\\</tr\\>\n"
+ ) list
+ ) list
end
else
begin
Printf.bprintf buf "Users:\n";
- user2_iter (fun name user ->
+ user2_user_iter (fun user ->
Printf.bprintf buf " %s\n"
user.user_name);
+ Printf.bprintf buf "\nGroup:\n";
+ user2_group_iter (fun group ->
+ Printf.bprintf buf " %s\n"
+ group.group_name);
end;
- ""
- else
- _s "Only 'admin' is allowed to list users"
- ), ":\t\t\t\t\tprint users";
+ end else print_command_result o buf "You are not allowed to list users";
+ _s ""
+ ), "\t\t\t\t\tprint users";
"whoami", Arg_none (fun o ->
print_command_result o o.conn_buf o.conn_user.ui_user_name;
_s ""
), "\t\t\t\t\tprint logged-in user name";
+
+ "chgrp", Arg_two (fun group filenum o ->
+ let num = int_of_string filenum in
+ try
+ let file = file_find num in
+ if set_file_group_safe file o.conn_user.ui_user_name (if
(String.lowercase group) = "none" then None else Some group) then
+ Printf.sprintf (_b "Changed group of download %d to %s") num group
+ else
+ Printf.sprintf (_b "Could not change group of download %d to %s")
num group
+ with e -> Printf.sprintf (_b "No file number %d, error %s") num
(Printexc2.to_string e)
+ ), "<group> \"<num>\" :\t\tchange group of download <num> to <group>,
group = none for private file";
+
+ "chown", Arg_two (fun new_owner filenum o ->
+ let num = int_of_string filenum in
+ try
+ let file = file_find num in
+ if set_file_owner_safe file o.conn_user.ui_user_name new_owner then
+ Printf.sprintf (_b "Changed owner of download %d to %s") num
new_owner
+ else
+ Printf.sprintf (_b "Could not change owner of download %d to %s")
num new_owner
+ with e -> Printf.sprintf (_b "No file number %d, error %s") num
(Printexc2.to_string e)
+ ), "<user> \"<num>\" :\t\tchange owner of download <num> to <user>";
+
]
Index: src/daemon/driver/driverControlers.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/driver/driverControlers.ml,v
retrieving revision 1.85
retrieving revision 1.86
diff -u -b -r1.85 -r1.86
--- src/daemon/driver/driverControlers.ml 12 Sep 2006 22:47:11 -0000
1.85
+++ src/daemon/driver/driverControlers.ml 19 Sep 2006 17:07:43 -0000
1.86
@@ -1000,15 +1000,15 @@
"VDC" ->
let num = int_of_string value in
let file = file_find num in
- file_cancel file
+ file_cancel file o.conn_user.ui_user_name
| "VDP" ->
let num = int_of_string value in
let file = file_find num in
- file_pause file
+ file_pause file o.conn_user.ui_user_name
| "VDR" ->
let num = int_of_string value in
let file = file_find num in
- file_resume file
+ file_resume file o.conn_user.ui_user_name
| _ -> ()
) r.get_url.Url.args;
@@ -1265,7 +1265,7 @@
try
let num = int_of_string value in
let r = find_result num in
- let files = result_download r [] false in
+ let files = result_download r [] false
o.conn_user.ui_user_name in
List.iter CommonInteractive.start_download files;
let module M = CommonMessages in
@@ -1285,15 +1285,15 @@
"cancel" ->
let num = int_of_string value in
let file = file_find num in
- file_cancel file
+ file_cancel file o.conn_user.ui_user_name
| "pause" ->
let num = int_of_string value in
let file = file_find num in
- file_pause file
+ file_pause file o.conn_user.ui_user_name
| "resume" ->
let num = int_of_string value in
let file = file_find num in
- file_resume file
+ file_resume file o.conn_user.ui_user_name
| "sortby" ->
begin
match value with
@@ -1319,7 +1319,7 @@
) r.get_url.Url.args;
let b = Buffer.create 10000 in
- let list = (List2.tail_map file_info !!files) in
+ let list = List2.tail_map file_info (user2_filter_files !!files
o.conn_user.ui_user_name) in
DriverInteractive.display_file_list b o list;
html_open_page buf t r true;
Buffer.add_string buf (html_escaped (Buffer.contents b))
@@ -1333,7 +1333,7 @@
List.iter (fun url ->
if url <> "\013" && url <> "" then
begin
- Buffer.add_string buf (html_escaped (dllink_parse
(o.conn_output = HTML) url));
+ Buffer.add_string buf (html_escaped (dllink_parse
(o.conn_output = HTML) url o.conn_user.ui_user_name));
Buffer.add_string buf (html_escaped "\\<P\\>")
end
) (String2.split links '\n')
@@ -1388,7 +1388,7 @@
| [ "setoption", _ ; "option", name; "value", value ] ->
html_open_page buf t r true;
- if (o.conn_user == default_user) || !!enable_user_config then
+ if user2_is_admin o.conn_user.ui_user_name then
begin
CommonInteractive.set_fully_qualified_options name value;
Buffer.add_string buf "Option value changed"
Index: src/daemon/driver/driverInteractive.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/driver/driverInteractive.ml,v
retrieving revision 1.101
retrieving revision 1.102
diff -u -b -r1.101 -r1.102
--- src/daemon/driver/driverInteractive.ml 7 Sep 2006 10:55:11 -0000
1.101
+++ src/daemon/driver/driverInteractive.ml 19 Sep 2006 17:07:43 -0000
1.102
@@ -49,19 +49,10 @@
lprintf2 log_prefix fmt
let verify_user_admin () =
- let empty_pwd = ref false in
- begin try
- if user2_password admin_user = blank_password then
- empty_pwd := true
- with e ->
- lprintf_nl (_b "SECURITY INFO: user 'admin' has to be present,
creating...");
- empty_pwd := true;
- ignore (user2_add admin_user blank_password "")
- end;
let warning =
"SECURITY WARNING: user admin has an empty password, use command: useradd
admin password\n"
in
- if !empty_pwd && not !!enable_user_config then
+ if empty_password admin_user then
begin
lprintf_n "%s" warning;
warning
@@ -1867,7 +1858,8 @@
tack list
(
"Features:\t",
- (if BasicSocket.has_threads () then "threads" else "no-threads") ^
+ ("multiuser") ^
+ (if BasicSocket.has_threads () then " threads" else " no-threads") ^
(let s = Zlib.zlib_version_num () in
Printf.sprintf " zlib%s" (if s <> "" then "-" ^ s else "")) ^
(if Autoconf.bzip2 then
@@ -2186,11 +2178,11 @@
if html then Printf.bprintf buf "\\</tr\\>\\</table\\>\\</div\\>\\</div\\>";
Buffer.contents buf
-let dllink_query_networks html url =
+let dllink_query_networks html url user =
let result = ref [] in
if not (networks_iter_until_true (fun n ->
try
- let s,r = network_parse_url n url in
+ let s,r = network_parse_url n url user in
if s = "" then
r
else
@@ -2208,7 +2200,7 @@
else
dllink_print_result html url "Added link" !result
-let dllink_parse html url =
+let dllink_parse html url user =
if (String2.starts_with url "http") then (
let u = Url.of_string url in
let module H = Http_client in
@@ -2242,21 +2234,14 @@
let concat_headers =
(List.fold_right (fun (n, c) t -> n ^ ": " ^ c ^ "\n" ^ t) headers "")
in
- ignore (dllink_query_networks html concat_headers)
+ ignore (dllink_query_networks html concat_headers user)
);
dllink_print_result html url "Parsing HTTP url" [])
else
if (String2.starts_with url "ftp") then
- dllink_query_networks html (Printf.sprintf "Location: %s" url)
- else
- dllink_query_networks html url
-
-let print_command_result o buf result =
- if use_html_mods o then
- html_mods_table_one_row buf "serversTable" "servers" [
- ("", "srh", result); ]
+ dllink_query_networks html (Printf.sprintf "Location: %s" url) user
else
- Printf.bprintf buf "%s" result
+ dllink_query_networks html url user
module UnionFind = struct
type t = int array
Index: src/daemon/driver/driverInterface.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/driver/driverInterface.ml,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -b -r1.52 -r1.53
--- src/daemon/driver/driverInterface.ml 12 Aug 2006 20:36:14 -0000
1.52
+++ src/daemon/driver/driverInterface.ml 19 Sep 2006 17:07:43 -0000
1.53
@@ -246,6 +246,8 @@
let send_update_file gui file_num update =
let file = file_find file_num in
+ if user2_can_view_file gui.gui_conn.conn_user.ui_user_name (file_owner file)
(file_group file) then
+ begin
let impl = as_file_impl file in
let file_info = if update then
P.File_info (file_info file)
@@ -256,6 +258,7 @@
impl.impl_file_last_seen)
in
gui_send gui file_info
+ end
let send_update_user gui user_num update =
let user = user_find user_num in
@@ -428,7 +431,7 @@
(File_add_source_event (file,c))
:: gui.gui_events.gui_new_events
) sources
- ) !!files;
+ ) (user2_filter_files !!files gui.gui_conn.conn_user.ui_user_name);
List.iter (fun file ->
addevent gui.gui_events.gui_files (file_num file) true;
@@ -458,6 +461,7 @@
end
);
+ if user2_can_view_uploads gui.gui_conn.conn_user.ui_user_name then
shared_iter (fun s ->
addevent gui.gui_events.gui_shared_files (shared_num s) true
);
@@ -466,8 +470,11 @@
gui.gui_events.gui_new_events <- ev :: gui.gui_events.gui_new_events
) console_messages;
+ if user2_is_admin gui.gui_conn.conn_user.ui_user_name then
gui_send gui (
P.Options_info (simple_options "" downloads_ini));
+
+ if user2_is_admin gui.gui_conn.conn_user.ui_user_name then
networks_iter_all (fun r ->
List.iter (fun opfile ->
let prefix = r.network_shortname ^ "-" in
@@ -475,6 +482,7 @@
gui_send gui (P.Options_info args)) r.network_config_file);
(* Options panels defined in downloads.ini *)
+ if user2_is_admin gui.gui_conn.conn_user.ui_user_name then
List.iter (fun s ->
let section = section_name s in
List.iter (fun o ->
@@ -484,6 +492,7 @@
) (sections downloads_ini);
(* Options panels defined in users.ini *)
+ if user2_is_admin gui.gui_conn.conn_user.ui_user_name then
List.iter (fun s ->
let section = section_name s in
List.iter (fun o ->
@@ -493,6 +502,7 @@
) (sections users_ini);
(* Options panels defined in each plugin *)
+ if user2_is_admin gui.gui_conn.conn_user.ui_user_name then
networks_iter_all (fun r ->
let prefix = r.network_shortname ^ "-" in
List.iter (fun file ->
@@ -554,7 +564,7 @@
(File_add_source_event (file,c))
:: gui.gui_events.gui_new_events
) (file_active_sources file)
- ) !!files;
+ ) (user2_filter_files !!files gui.gui_conn.conn_user.ui_user_name);
end
@@ -613,7 +623,7 @@
) list
| P.SetOption (name, value) ->
- if user2_is_admin gui.gui_conn.conn_user.ui_user_name ||
!!enable_user_config then
+ if user2_is_admin gui.gui_conn.conn_user.ui_user_name then
CommonInteractive.set_fully_qualified_options name value
else
begin
@@ -644,6 +654,7 @@
end
| P.EnableNetwork (num, bool) ->
+ if user2_is_admin gui.gui_conn.conn_user.ui_user_name then
let n = network_find_by_num num in
if n.op_network_is_enabled () <> bool then
(try
@@ -720,7 +731,7 @@
| P.Download_query (filenames, num, force) ->
let r = find_result num in
- let files = result_download r filenames force in
+ let files = result_download r filenames force
gui.gui_conn.conn_user.ui_user_name in
List.iter CommonInteractive.start_download files
| P.ConnectMore_query ->
@@ -731,7 +742,7 @@
if not (networks_iter_until_true
(fun n ->
try
- let s,r = network_parse_url n url in r
+ let s,r = network_parse_url n url
gui.gui_conn.conn_user.ui_user_name in r
with e ->
lprintf "Exception %s for network %s\n"
(Printexc2.to_string e) (n.network_name);
@@ -765,11 +776,13 @@
query_networks url
| P.GetUploaders ->
+ if user2_can_view_uploads gui.gui_conn.conn_user.ui_user_name
then
gui_send gui (P.Uploaders
(List2.tail_map (fun c -> client_num c)
(Intmap.to_list !uploaders)))
| P.GetPending ->
+ if user2_can_view_uploads gui.gui_conn.conn_user.ui_user_name
then
gui_send gui (P.Pending (
List2.tail_map (fun c -> client_num c)
(Intmap.to_list !CommonUploads.pending_slots_map)))
@@ -778,13 +791,13 @@
server_remove (server_find num)
| P.SaveOptions_query list ->
-
+ if user2_is_admin gui.gui_conn.conn_user.ui_user_name then
List.iter (fun (name, value) ->
CommonInteractive.set_fully_qualified_options name value)
list;
DriverInteractive.save_config ()
| P.RemoveDownload_query num ->
- file_cancel (file_find num)
+ file_cancel (file_find num) gui.gui_conn.conn_user.ui_user_name
| P.ViewUsers num ->
let s = server_find num in
@@ -868,6 +881,7 @@
client_connect c
| P.DisconnectClient num ->
+ if user2_can_view_uploads gui.gui_conn.conn_user.ui_user_name
then
let c = client_find num in
client_disconnect c
@@ -905,9 +919,9 @@
| P.SwitchDownload (num, resume) ->
let file = file_find num in
if resume then
- file_resume file
+ file_resume file gui.gui_conn.conn_user.ui_user_name
else
- file_pause file
+ file_pause file gui.gui_conn.conn_user.ui_user_name
| P.FindFriend user ->
networks_iter (fun n ->
@@ -1026,7 +1040,7 @@
| NetworkMessage (num, s) ->
let n = network_find_by_num num in
- n.op_network_gui_message s
+ n.op_network_gui_message s gui.gui_conn.conn_user.ui_user_name
| AddServer_query (num, ip, port) ->
let n = network_find_by_num num in
@@ -1036,7 +1050,7 @@
let s = n.op_network_add_server (Ip.addr_of_ip ip) port in
server_connect s
| RefreshUploadStats ->
-
+ if user2_can_view_uploads gui.gui_conn.conn_user.ui_user_name
then
shared_iter (fun s ->
update_shared_info s;
)
Index: src/daemon/driver/driverMain.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/driver/driverMain.ml,v
retrieving revision 1.125
retrieving revision 1.126
diff -u -b -r1.125 -r1.126
--- src/daemon/driver/driverMain.ml 5 Sep 2006 14:15:19 -0000 1.125
+++ src/daemon/driver/driverMain.ml 19 Sep 2006 17:07:43 -0000 1.126
@@ -218,7 +218,6 @@
(try
Options.load downloads_ini;
Options.load users_ini;
- ignore (DriverInteractive.verify_user_admin ());
DriverInteractive.hdd_check ()
with e ->
lprintf_nl "Exception %s during options load" (Printexc2.to_string e);
Index: src/networks/bittorrent/bTComplexOptions.ml
===================================================================
RCS file:
/sources/mldonkey/mldonkey/src/networks/bittorrent/bTComplexOptions.ml,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -b -r1.36 -r1.37
--- src/networks/bittorrent/bTComplexOptions.ml 16 Sep 2006 09:47:17 -0000
1.36
+++ src/networks/bittorrent/bTComplexOptions.ml 19 Sep 2006 17:07:43 -0000
1.37
@@ -183,7 +183,8 @@
(Printf.sprintf "BT-%s" (Sha1.to_string file_id)) in
file_temp
in
- let file = new_file file_id torrent torrent_diskname file_temp file_state in
+ let file = new_file file_id torrent torrent_diskname
+ file_temp file_state CommonUserDb.admin_user in
let file_uploaded = try
value_to_int64 (List.assoc "file_uploaded" assocs)
Index: src/networks/bittorrent/bTGlobals.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/bittorrent/bTGlobals.ml,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -b -r1.63 -r1.64
--- src/networks/bittorrent/bTGlobals.ml 16 Sep 2006 09:47:17 -0000
1.63
+++ src/networks/bittorrent/bTGlobals.ml 19 Sep 2006 17:07:43 -0000
1.64
@@ -223,7 +223,7 @@
file.file_trackers <- t :: file.file_trackers;
set_trackers file q
-let new_file file_id t torrent_diskname file_temp file_state =
+let new_file file_id t torrent_diskname file_temp file_state user =
try
Hashtbl.find files_by_uid file_id
with Not_found ->
@@ -252,6 +252,8 @@
file_shared = None;
} and file_impl = {
dummy_file_impl with
+ impl_file_owner = user;
+ impl_file_group = CommonUserDb.user2_user_default_group user;
impl_file_fd = Some file_fd;
impl_file_size = t.torrent_length;
impl_file_downloaded = Int64.zero;
@@ -299,15 +301,15 @@
(* lprintf "ADD FILE TO DOWNLOAD LIST\n"; *)
file
-let new_download file_id t torrent_diskname =
+let new_download file_id t torrent_diskname user =
let file_temp = Filename.concat !!DO.temp_directory
(Printf.sprintf "BT-%s" (Sha1.to_string file_id)) in
- new_file file_id t torrent_diskname file_temp FileDownloading
+ new_file file_id t torrent_diskname file_temp FileDownloading user
let ft_by_num = Hashtbl.create 13
let ft_counter = ref 0
-let new_ft file_name =
+let new_ft file_name user =
incr ft_counter;
let rec ft = {
ft_file = file_impl;
@@ -316,6 +318,8 @@
ft_retry = (fun _ -> ());
} and file_impl = {
dummy_file_impl with
+ impl_file_owner = user;
+ impl_file_group = CommonUserDb.user2_user_default_group user;
impl_file_fd = None;
impl_file_size = zero;
impl_file_downloaded = Int64.zero;
Index: src/networks/bittorrent/bTInteractive.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/bittorrent/bTInteractive.ml,v
retrieving revision 1.108
retrieving revision 1.109
diff -u -b -r1.108 -r1.109
--- src/networks/bittorrent/bTInteractive.ml 16 Sep 2006 09:47:17 -0000
1.108
+++ src/networks/bittorrent/bTInteractive.ml 19 Sep 2006 17:07:43 -0000
1.109
@@ -469,7 +469,7 @@
-let load_torrent_string s =
+let load_torrent_string s user =
let file_id, torrent = BTTorrent.decode_torrent s in
(* Save the torrent, because we later want to put
@@ -495,13 +495,13 @@
if !verbose then
lprintf_nl "Starting torrent download with diskname: %s"
torrent_diskname;
- let file = new_download file_id torrent torrent_diskname in
+ let file = new_download file_id torrent torrent_diskname user in
BTClients.get_sources_from_tracker file;
BTShare.must_share_file file;
CommonInteractive.start_download (file_find (file_num file));
file
-let load_torrent_file filename =
+let load_torrent_file filename user =
if !verbose then
lprintf_nl "load_torrent_file %s" filename;
let s = File.to_string filename in
@@ -510,7 +510,7 @@
if Sys.file_exists filename
&& (Filename.dirname filename) = downloads_directory then
Sys.remove filename;
- ignore (load_torrent_string s)
+ ignore (load_torrent_string s user)
let parse_tracker_reply file t filename =
(*This is the function which will be called by the http client
@@ -576,7 +576,7 @@
in
let file = new_file file_id torrent torrent_diskname
- filename FileShared in
+ filename FileShared CommonUserDb.admin_user in
BTShare.must_share_file file;
if !verbose_share then lprintf_file_nl file "Sharing file %s" filename;
BTClients.connect_trackers file "started"
@@ -636,7 +636,8 @@
let file_basename = Filename.basename file in
if not (Unix2.is_directory file) then
try
- load_torrent_file file;
+ let user = fst (Unix32.owner file) in
+ load_torrent_file file (if not (CommonUserDb.user2_user_exist user) then
CommonUserDb.admin_user else user);
(try Sys.remove file with _ -> ())
with
Torrent_can_not_be_used ->
@@ -651,12 +652,12 @@
lprintf_nl "ft_retry: exception %s" (Printexc2.to_string e)
) ft_by_num
-let load_torrent_from_web r ft =
+let load_torrent_from_web r user ft =
let module H = Http_client in
H.wget r (fun filename ->
if ft_state ft = FileDownloading then begin
- load_torrent_file filename;
- file_cancel (as_ft ft)
+ load_torrent_file filename user;
+ file_cancel (as_ft ft) CommonUserDb.admin_user
end)
let valid_torrent_extension url =
@@ -669,7 +670,7 @@
let b = Str.group_end 1 in
String.sub text a (b - a)
-let op_network_parse_url url =
+let op_network_parse_url url user =
let location_regexp = "Location: \\(.*\\)" in
try
let real_url = get_regexp_string url (Str.regexp location_regexp) in
@@ -704,9 +705,9 @@
} in
let file_diskname = Filename.basename u.Url.short_file in
- let ft = new_ft file_diskname in
- ft.ft_retry <- load_torrent_from_web r ;
- load_torrent_from_web r ft;
+ let ft = new_ft file_diskname user in
+ ft.ft_retry <- (load_torrent_from_web r user);
+ load_torrent_from_web r user ft;
"started download", true
)
else
@@ -717,7 +718,7 @@
try
if !verbose then lprintf_nl "Not_found and trying to load %s" url;
try
- load_torrent_file url;
+ load_torrent_file url user;
"", true
with
Already_exists -> "A torrent with this name is already in the
download queue", false
@@ -950,13 +951,13 @@
let buf = o.conn_buf in
if Sys.file_exists url then
begin
- load_torrent_file url;
+ load_torrent_file url o.conn_user.ui_user_name;
Printf.bprintf buf "loaded file %s\n" url
end
else
begin
let url = "Location: " ^ url ^ "\nContent-Type:
application/x-bittorrent" in
- let result = fst (op_network_parse_url url) in
+ let result = fst (op_network_parse_url url o.conn_user.ui_user_name)
in
Printf.bprintf buf "%s\n" result
end;
_s ""
@@ -1031,12 +1032,12 @@
open LittleEndian
open GuiDecoding
-let op_gui_message s =
+let op_gui_message s user =
match get_int16 s 0 with
0 ->
let text = String.sub s 2 (String.length s - 2) in
if !verbose then lprintf_nl "received torrent from gui...";
- ignore (load_torrent_string text)
+ ignore (load_torrent_string text user)
| 1 -> (* 34+ *)
let n = get_int s 2 in
let a, pos = get_string s 6 in
@@ -1072,7 +1073,7 @@
network.op_network_forget_search <- (fun s -> ());
network.op_network_connect_servers <- (fun s -> ());
network.op_network_search <- (fun ss buf -> ());
- network.op_network_download <- (fun r -> dummy_file);
+ network.op_network_download <- (fun r user -> dummy_file);
network.op_network_recover_temp <- (fun s -> ());
let clean_exit_started = ref false in
network.op_network_clean_exit <- (fun s ->
Index: src/networks/donkey/donkeyComplexOptions.ml
===================================================================
RCS file:
/sources/mldonkey/mldonkey/src/networks/donkey/donkeyComplexOptions.ml,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -b -r1.57 -r1.58
--- src/networks/donkey/donkeyComplexOptions.ml 5 Sep 2006 14:15:19 -0000
1.57
+++ src/networks/donkey/donkeyComplexOptions.ml 19 Sep 2006 17:07:43 -0000
1.58
@@ -273,7 +273,7 @@
in
let file = DonkeyGlobals.new_file file_diskname file_state
- (Md4.of_string file_md4) file_size "" true in
+ (Md4.of_string file_md4) file_size "" true CommonUserDb.admin_user in
(try
set_file_best_name (as_file file)
Index: src/networks/donkey/donkeyGlobals.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/donkey/donkeyGlobals.ml,v
retrieving revision 1.96
retrieving revision 1.97
diff -u -b -r1.96 -r1.97
--- src/networks/donkey/donkeyGlobals.ml 16 Sep 2006 15:36:59 -0000
1.96
+++ src/networks/donkey/donkeyGlobals.ml 19 Sep 2006 17:07:43 -0000
1.97
@@ -311,7 +311,7 @@
set_file_best_name file best_name "" 0
with Not_found -> ()
-let new_file file_diskname file_state md4 file_size filename writable =
+let new_file file_diskname file_state md4 file_size filename writable user =
try
let file = find_file md4 in
@@ -402,6 +402,8 @@
}
and file_impl = {
dummy_file_impl with
+ impl_file_owner = user;
+ impl_file_group = CommonUserDb.user2_user_default_group user;
impl_file_val = file;
impl_file_ops = file_ops;
impl_file_age = last_time ();
Index: src/networks/donkey/donkeyInteractive.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/donkey/donkeyInteractive.ml,v
retrieving revision 1.122
retrieving revision 1.123
diff -u -b -r1.122 -r1.123
--- src/networks/donkey/donkeyInteractive.ml 5 Sep 2006 14:18:24 -0000
1.122
+++ src/networks/donkey/donkeyInteractive.ml 19 Sep 2006 17:07:43 -0000
1.123
@@ -181,14 +181,11 @@
)
let already_done = Failure (Printf.sprintf (_b "File already downloaded (use
'force_download' if necessary)"))
-
let no_download_to_force = Failure (Printf.sprintf (_b "No forceable download
found"))
+exception Already_downloading of string
+exception Already_shared of string
-let already_downloading = Failure (Printf.sprintf (_b "File is already in
download queue"))
-
-let already_shared = Failure (Printf.sprintf (_b "File is already shared"))
-
-let really_query_download filename size md4 location old_file absents =
+let really_query_download filename size md4 location old_file absents user =
begin
try
@@ -226,7 +223,7 @@
end;
(* TODO RESULT let other_names = DonkeyIndexer.find_names md4 in *)
- let file = new_file file_diskname FileDownloading md4 size filename true in
+ let file = new_file file_diskname FileDownloading md4 size filename true
user in
begin
match absents with
None -> ()
@@ -295,7 +292,7 @@
);
as_file file
-let query_download filename size md4 location old_file absents force =
+let query_download filename size md4 location old_file absents force user =
if force then
if !forceable_download = [] then
raise no_download_to_force
@@ -303,20 +300,23 @@
begin
let f = List.hd !forceable_download in
forceable_download := [];
- really_query_download (List.hd f.result_names) f.result_size md4 None
None None
+ really_query_download (List.hd f.result_names) f.result_size md4 None
None None user
end
else
begin
try
let file = find_file md4 in
if (file_state file) = FileShared then
- raise already_shared
+ raise (Already_shared (Printf.sprintf (_b "File is already
shared%s")
+ (match file.file_shared with
+ None -> ""
+ | Some sh -> (" in " ^ (Filename2.dirname
sh.impl_shared_fullname)))))
else
begin
(* jave TODO: if a user currently not downloading this file is requesting the
download add this user
to the list of users currently downloading this file *)
forceable_download := [];
- raise already_downloading
+ raise (Already_downloading (Printf.sprintf (_b "File is already
in download queue of %s") (file_owner (as_file file))))
end
with Not_found ->
begin
@@ -336,19 +336,19 @@
else
begin
forceable_download := [];
- really_query_download filename size md4 location old_file absents
+ really_query_download filename size md4 location old_file absents
user
end
end
end
-let result_download r filenames force =
+let result_download r filenames force user =
let rec iter uids =
match uids with
[] -> raise IgnoreNetwork
| uid :: tail ->
match Uid.to_uid uid with
Ed2k md4 ->
- query_download (List.hd filenames) r.result_size md4 None None
None force
+ query_download (List.hd filenames) r.result_size md4 None None
None force user
| _ -> iter tail
in
iter r.result_uids
@@ -391,7 +391,7 @@
(match !filename_met with
None -> filename
| Some s -> s) !size f.P.md4 None
- (Some filename) (Some (List.rev f.P.absents)));
+ (Some filename) (Some (List.rev f.P.absents))
CommonUserDb.admin_user);
with _ -> ()
) list
@@ -508,7 +508,7 @@
-let parse_donkey_url url =
+let parse_donkey_url url user =
let url = Str.global_replace (Str.regexp "|sources,") "|sources|" url in
match String2.split url '|' with
(* TODO RESULT *)
@@ -536,7 +536,7 @@
begin
try
let file = query_download name (Int64.of_string size)
- (Md4.of_string md4) None None None false in
+ (Md4.of_string md4) None None None false user in
let new_file = find_file (Md4.of_string md4) in
CommonInteractive.start_download file;
if !new_sources <> [] then
@@ -547,7 +547,10 @@
(Printf.sprintf (_b "added %d sources to new download")
(List.length !new_sources)), true
end
else "", true
- with e -> (Printexc2.to_string e), false
+ with
+ Already_downloading (s)
+ | Already_shared (s) -> s, false
+ | e -> (Printexc2.to_string e), false
end
end
| "ed2k://" :: "file" :: name :: size :: md4 :: _
@@ -566,12 +569,14 @@
in
begin try
let file = query_download name (Int64.of_string size)
- (Md4.of_string md4) None None None false;
+ (Md4.of_string md4) None None None false user;
in
CommonInteractive.start_download file;
"", true
- with e ->
- (Printexc2.to_string e), false
+ with
+ Already_downloading (s)
+ | Already_shared (s) -> s, false
+ | e -> (Printexc2.to_string e), false
end
| "ed2k://" :: "server" :: ip :: port :: _
| "server" :: ip :: port :: _ ->
@@ -776,6 +781,7 @@
"<port> :\t\t\t\tchange connection port";
"scan_temp", Arg_none (fun o ->
+ if CommonUserDb.user2_is_admin o.conn_user.ui_user_name then begin
let buf = o.conn_buf in
let list = Unix2.list_directory !!temp_directory in
@@ -873,24 +879,22 @@
) list;
if use_html_mods o then Printf.bprintf buf "\\</table\\>\\</div\\>";
+ "" end
+ else begin
+ CommonUserDb.print_command_result o o.conn_buf "You are not allowed
to use scan_temp";
+ "" end
- ""
), ":\t\t\t\tprint temp directory content";
"sources", Arg_none (fun o ->
- let buf = o.conn_buf in
- DonkeySources.print buf o.conn_output;
- ""
+ if CommonUserDb.user2_is_admin o.conn_user.ui_user_name then begin
+ DonkeySources.print o.conn_buf o.conn_output;
+ "" end
+ else begin
+ CommonUserDb.print_command_result o o.conn_buf "You are not allowed
to list sources";
+ "" end
), ":\t\t\t\tshow sources currently known";
- (*
- "update_sources", Arg_none (fun o ->
- let buf = o.conn_buf in
- DonkeySources.recompute_ready_sources ();
- "done"
- ), ":\t\t\trecompute order of connections to sources (experimental)";
-*)
-
"xs", Arg_none (fun o ->
let buf = o.conn_buf in
if !xs_last_search >= 0 then begin
@@ -920,7 +924,7 @@
(* TODO RESULT *)
"dd", Arg_two(fun size md4 o ->
let file = query_download md4 (Int64.of_string size)
- (Md4.of_string md4) None None None false in
+ (Md4.of_string md4) None None None false o.conn_user.ui_user_name in
CommonInteractive.start_download file;
"download started"
), "<size> <md4> :\t\t\tdownload from size and md4";
@@ -1003,8 +1007,8 @@
with
Not_found -> ()
);
- network.op_network_download <- (fun r ->
- result_download r r.result_names r.result_force
+ network.op_network_download <- (fun r user ->
+ result_download r r.result_names r.result_force user
)
module P = GuiTypes
Index: src/networks/donkey/donkeyOneFile.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/donkey/donkeyOneFile.ml,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -b -r1.42 -r1.43
--- src/networks/donkey/donkeyOneFile.ml 8 Aug 2006 23:55:28 -0000
1.42
+++ src/networks/donkey/donkeyOneFile.ml 19 Sep 2006 17:07:43 -0000
1.43
@@ -435,7 +435,7 @@
(file_best_name file) (Printexc2.to_string e) in
Printf2.lprint_string m;
CommonEvent.add_event (Console_message_event m);
- file_pause (as_file file);
+ file_pause (as_file file) CommonUserDb.admin_user;
raise e
end
Index: src/networks/donkey/donkeyShare.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/donkey/donkeyShare.ml,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -b -r1.50 -r1.51
--- src/networks/donkey/donkeyShare.ml 1 Sep 2006 16:22:15 -0000 1.50
+++ src/networks/donkey/donkeyShare.ml 19 Sep 2006 17:07:43 -0000 1.51
@@ -99,7 +99,7 @@
lprintf_nl "Sharing file with MD4: %s" (Md4.to_string md4);
let file = new_file sh.sh_name FileShared md4 sh.sh_size
- "" false in
+ "" false CommonUserDb.admin_user in
must_share_file file codedname old_impl;
file.file_computed_md4s <- md4s;
add_file_filenames (as_file file) (Filename.basename sh.sh_name);
Index: src/networks/fasttrack/fasttrackGlobals.ml
===================================================================
RCS file:
/sources/mldonkey/mldonkey/src/networks/fasttrack/fasttrackGlobals.ml,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -b -r1.41 -r1.42
--- src/networks/fasttrack/fasttrackGlobals.ml 1 Sep 2006 16:22:15 -0000
1.41
+++ src/networks/fasttrack/fasttrackGlobals.ml 19 Sep 2006 17:07:43 -0000
1.42
@@ -267,7 +267,7 @@
let min_range_size = megabyte
-let new_file file_temporary file_name file_size file_hash =
+let new_file file_temporary file_name file_size file_hash user =
let file_temp = Filename.concat !!temp_directory file_temporary in
(* (Printf.sprintf "FT-%s" (Md4.to_string file_id)) in *)
let t = Unix32.create_rw file_temp in
@@ -293,6 +293,8 @@
impl_file_fd = Some t;
impl_file_size = file_size;
impl_file_downloaded = Int64.zero;
+ impl_file_owner = user;
+ impl_file_group = CommonUserDb.user2_user_default_group user;
impl_file_val = file;
impl_file_ops = file_ops;
impl_file_age = last_time ();
@@ -335,7 +337,7 @@
exception FileFound of file
-let new_file file_id file_name file_size file_uids =
+let new_file file_id file_name file_size file_uids user =
let file = ref None in
List.iter (fun uid ->
match Uid.to_uid uid with
@@ -343,7 +345,7 @@
file := Some (try
Hashtbl.find files_by_uid file_hash
with _ ->
- let file = new_file file_id file_name file_size file_hash in
+ let file = new_file file_id file_name file_size file_hash user
in
Hashtbl.add files_by_uid file_hash file;
file)
| _ -> ()
Index: src/networks/fasttrack/fasttrackServers.ml
===================================================================
RCS file:
/sources/mldonkey/mldonkey/src/networks/fasttrack/fasttrackServers.ml,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -b -r1.29 -r1.30
--- src/networks/fasttrack/fasttrackServers.ml 19 May 2006 23:43:54 -0000
1.29
+++ src/networks/fasttrack/fasttrackServers.ml 19 Sep 2006 17:07:43 -0000
1.30
@@ -322,7 +322,7 @@
) file.file_searches
) !connected_servers
-let really_download_file (r : CommonTypes.result_info) =
+let really_download_file (r : CommonTypes.result_info) user =
let rec iter uids =
match uids with
uid :: tail ->
@@ -334,7 +334,7 @@
let hash,file_temp = iter r.result_uids in
let file = new_file file_temp (List.hd r.result_names)
- r.result_size [Uid.create (Md5Ext hash)] in
+ r.result_size [Uid.create (Md5Ext hash)] user in
if !verbose then
lprintf "DOWNLOAD FILE %s\n" file.file_name;
if not (List.memq file !current_files) then begin
Index: src/networks/fileTP/fileTPClients.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/fileTP/fileTPClients.ml,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -b -r1.22 -r1.23
--- src/networks/fileTP/fileTPClients.ml 8 Aug 2006 23:55:28 -0000
1.22
+++ src/networks/fileTP/fileTPClients.ml 19 Sep 2006 17:07:43 -0000
1.23
@@ -63,9 +63,9 @@
if (filesize = 0L || !!chunk_size = 0) then 1
else Int64.to_int ((filesize) // (min_range_size file)) + 5
-let pause_for_cause f r =
+let pause_for_cause f r user =
lprintf_nl "Pausing file %s (%s)" (file_best_name f) r;
- file_pause (as_file f)
+ file_pause (as_file f) user
let disconnect_client c r =
match c.client_sock with
Index: src/networks/fileTP/fileTPComplexOptions.ml
===================================================================
RCS file:
/sources/mldonkey/mldonkey/src/networks/fileTP/fileTPComplexOptions.ml,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -b -r1.16 -r1.17
--- src/networks/fileTP/fileTPComplexOptions.ml 25 May 2006 19:47:25 -0000
1.16
+++ src/networks/fileTP/fileTPComplexOptions.ml 19 Sep 2006 17:07:43 -0000
1.17
@@ -78,8 +78,7 @@
Md4.of_string (get_value "file_id" value_to_string)
with _ -> failwith "Bad file_id"
in
-
- let file = new_file file_id file_name file_size in
+ let file = new_file file_id file_name file_size CommonUserDb.admin_user in
(match file.file_swarmer with
None -> ()
Index: src/networks/fileTP/fileTPFTP.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/fileTP/fileTPFTP.ml,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -b -r1.13 -r1.14
--- src/networks/fileTP/fileTPFTP.ml 30 May 2006 10:54:14 -0000 1.13
+++ src/networks/fileTP/fileTPFTP.ml 19 Sep 2006 17:07:43 -0000 1.14
@@ -278,13 +278,13 @@
| "530 " ->
let reason = String.sub line 4 (slen - 4) in
if not (retry_530 reason) then begin
- pause_for_cause d.download_file "530";
+ pause_for_cause d.download_file "530"
CommonUserDb.admin_user;
end else begin
c.client_reconnect <- true;
end;
disconnect_client c Closed_by_user;
| "550 " ->
- pause_for_cause d.download_file "550";
+ pause_for_cause d.download_file "550"
CommonUserDb.admin_user;
disconnect_client c Closed_by_user;
| _ ->
if !verbose then lprintf_nl "Unexpected line %s" line;
@@ -443,11 +443,11 @@
| "530 " ->
let reason = String.sub line 4 (slen - 4) in
if not (retry_530 reason) then begin
- pause_for_cause file "530";
+ pause_for_cause file "530" CommonUserDb.admin_user;
end;
close sock Closed_by_user;
| "550 " ->
- pause_for_cause file "550";
+ pause_for_cause file "550" CommonUserDb.admin_user;
close sock Closed_by_user;
| _ ->
if !verbose then lprintf_nl "Unexpected line %s" line;
Index: src/networks/fileTP/fileTPGlobals.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/fileTP/fileTPGlobals.ml,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -b -r1.28 -r1.29
--- src/networks/fileTP/fileTPGlobals.ml 1 Sep 2006 16:22:15 -0000
1.28
+++ src/networks/fileTP/fileTPGlobals.ml 19 Sep 2006 17:07:43 -0000
1.29
@@ -138,7 +138,7 @@
file_must_update (as_file file);
end
-let new_file file_id file_name file_size =
+let new_file file_id file_name file_size user =
let file_temp = Filename.concat !!temp_directory
(Printf.sprintf "FileTP-%s" (Md4.to_string file_id)) in
let t = Unix32.create_rw file_temp in
@@ -152,6 +152,8 @@
file_nconnected_clients = 0;
} and file_impl = {
dummy_file_impl with
+ impl_file_owner = user;
+ impl_file_group = CommonUserDb.user2_user_default_group user;
impl_file_fd = Some t;
impl_file_size = zero;
impl_file_downloaded = zero;
@@ -168,11 +170,11 @@
(* lprintf "ADD FILE TO DOWNLOAD LIST\n"; *)
file
-let new_file file_id file_name file_size =
+let new_file file_id file_name file_size users =
try
Hashtbl.find files_by_uid file_id
with _ ->
- let file = new_file file_id file_name file_size in
+ let file = new_file file_id file_name file_size users in
Hashtbl.add files_by_uid file_id file;
file
Index: src/networks/fileTP/fileTPHTTP.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/fileTP/fileTPHTTP.ml,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -b -r1.25 -r1.26
--- src/networks/fileTP/fileTPHTTP.ml 10 Aug 2006 17:41:20 -0000 1.25
+++ src/networks/fileTP/fileTPHTTP.ml 19 Sep 2006 17:07:43 -0000 1.26
@@ -174,7 +174,7 @@
end;
if code < 200 || code > 299 then begin
- pause_for_cause file (Printf.sprintf "%d" code);
+ pause_for_cause file (Printf.sprintf "%d" code) CommonUserDb.admin_user;
failwith "Bad HTTP code";
end;
@@ -386,7 +386,7 @@
(fun c ->
match c with
x when x < 200 || x > 299 ->
- pause_for_cause file (string_of_int x);
+ pause_for_cause file (string_of_int x) CommonUserDb.admin_user;
| _ -> ()
)
Index: src/networks/fileTP/fileTPInteractive.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/fileTP/fileTPInteractive.ml,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -b -r1.46 -r1.47
--- src/networks/fileTP/fileTPInteractive.ml 5 Sep 2006 15:32:17 -0000
1.46
+++ src/networks/fileTP/fileTPInteractive.ml 19 Sep 2006 17:07:43 -0000
1.47
@@ -234,7 +234,7 @@
let previous_url = ref ""
-let download_file url referer =
+let download_file url referer user =
let u = Url.of_string url in
if List.mem u !!old_files && !previous_url <> url then begin
@@ -242,7 +242,7 @@
failwith "URL already downloaded: repeat command again to force";
end;
- let file = new_file (Md4.random ()) u.Url.full_file zero in
+ let file = new_file (Md4.random ()) u.Url.full_file zero user in
if !verbose then
lprintf_nl "Started new download: %s from %s" (file_best_name file) url;
@@ -276,7 +276,7 @@
It returns true if this file can be handled by fileTP,
and false otherwise.
*)
-let op_network_parse_url url =
+let op_network_parse_url url user =
let location_regexp = "Location: \\(.*\\)" in
let real_url = get_regexp_string url (Str.regexp location_regexp) in
if (is_http_torrent url real_url) && !!enable_bittorrent then
@@ -286,7 +286,7 @@
let length_regexp = "Content-Length: \\(.*\\)" in
try let length = get_regexp_int url (Str.regexp length_regexp) in
if (length > 0) then begin
- download_file real_url ""; "started FileTP download", true
+ download_file real_url "" user; "started FileTP download", true
end
else "can not parse Content-Length", false
with Not_found ->
@@ -295,7 +295,7 @@
else
if (String2.check_prefix real_url "ftp://";) ||
(String2.check_prefix real_url "ssh://") then (
- download_file real_url "";
+ download_file url "" user;
"started FileTP download", true)
else
"invalid URL", false
@@ -310,8 +310,8 @@
"http", "Network/FileTP", Arg_multiple (fun args o ->
try
(match args with
- url :: [referer] -> download_file url referer
- | [url] -> download_file url ""
+ url :: [referer] -> download_file url referer
o.conn_user.ui_user_name
+ | [url] -> download_file url "" o.conn_user.ui_user_name
| _ -> raise Not_found);
let buf = o.conn_buf in
if o.conn_output = HTML then
@@ -405,7 +405,7 @@
CommonNetwork.register_commands commands;
network.op_network_share <- (fun fullname codedname size -> ());
network.op_network_search <- (fun ss buf -> ());
- network.op_network_download <- (fun r -> dummy_file);
+ network.op_network_download <- (fun r user -> dummy_file);
file_ops.op_file_commit <- (fun file new_name -> clean_stop file);
file_ops.op_file_pause <- (fun file ->
List.iter (fun c ->
Index: src/networks/gnutella/gnutellaComplexOptions.ml
===================================================================
RCS file:
/sources/mldonkey/mldonkey/src/networks/gnutella/gnutellaComplexOptions.ml,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -b -r1.28 -r1.29
--- src/networks/gnutella/gnutellaComplexOptions.ml 25 May 2006 19:47:25
-0000 1.28
+++ src/networks/gnutella/gnutellaComplexOptions.ml 19 Sep 2006 17:07:43
-0000 1.29
@@ -130,7 +130,7 @@
file_uids := hash :: !file_uids;
with _ -> ());
- let file = new_file file_temp file_name file_size !file_uids in
+ let file = new_file file_temp file_name file_size !file_uids
CommonUserDb.admin_user in
(try
file.file_ttr <- Some (get_value "file_ttr" (value_to_array
Index: src/networks/gnutella/gnutellaGlobals.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/gnutella/gnutellaGlobals.ml,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -b -r1.42 -r1.43
--- src/networks/gnutella/gnutellaGlobals.ml 1 Sep 2006 16:22:15 -0000
1.42
+++ src/networks/gnutella/gnutellaGlobals.ml 19 Sep 2006 17:07:43 -0000
1.43
@@ -310,7 +310,7 @@
let megabyte = Int64.of_int (1024 * 1024)
let megabytes10 = Int64.of_int (10 * 1024 * 1024)
-let new_file file_temporary file_name file_size file_uids =
+let new_file file_temporary file_name file_size file_uids user =
let file_temp = Filename.concat !!temp_directory file_temporary in
let t = Unix32.create_rw file_temp in
let rec file = {
@@ -329,6 +329,8 @@
impl_file_fd = Some t;
impl_file_size = file_size;
impl_file_downloaded = Int64.zero;
+ impl_file_owner = user;
+ impl_file_group = CommonUserDb.user2_user_default_group user;
impl_file_val = file;
impl_file_ops = file_ops;
impl_file_age = last_time ();
@@ -357,7 +359,7 @@
exception FileFound of file
-let new_file file_id file_name file_size file_uids =
+let new_file file_id file_name file_size file_uids user =
(* if file_uids = [] then
try Hashtbl.find files_by_key (file_name, file_size) with
_ ->
@@ -370,7 +372,7 @@
try raise (FileFound (Hashtbl.find files_by_uid uid))
with Not_found -> ()
) file_uids;
- let file = new_file file_id file_name file_size file_uids in
+ let file = new_file file_id file_name file_size file_uids user in
List.iter (fun uid ->
if !verbose then
lprintf "Adding file %s\n" (Uid.to_string uid);
Index: src/networks/gnutella/gnutellaInteractive.ml
===================================================================
RCS file:
/sources/mldonkey/mldonkey/src/networks/gnutella/gnutellaInteractive.ml,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -b -r1.63 -r1.64
--- src/networks/gnutella/gnutellaInteractive.ml 5 Sep 2006 15:32:17
-0000 1.63
+++ src/networks/gnutella/gnutellaInteractive.ml 19 Sep 2006 17:07:43
-0000 1.64
@@ -77,8 +77,8 @@
if file_state file = FileDownloading then
GnutellaServers.really_recover_file file
-let download_file r =
- let file = GnutellaServers.really_download_file r in
+let download_file r user =
+ let file = GnutellaServers.really_download_file r user in
recover_file file;
as_file file
@@ -241,8 +241,8 @@
end
);
(* TODO RESULT *)
- network.op_network_download <- (fun r ->
- result_download r
+ network.op_network_download <- (fun r user ->
+ result_download r user
)
let file_num file =
@@ -370,7 +370,7 @@
List2.tail_map (fun s -> as_server s.server_server)
!connected_servers
);
- network.op_network_parse_url <- (fun url ->
+ network.op_network_parse_url <- (fun url user ->
match String2.split (String.escaped url) '|' with
| "gnut://" :: "server" :: ip :: port :: _ ->
let ip = Ip.addr_of_string ip in
@@ -402,7 +402,7 @@
(* Start a download for this file *)
let rs = new_result name size [] uids [] in
let r = IndexedResults.get_result rs in
- let file = download_file r in
+ let file = download_file r user in
CommonInteractive.start_download file;
"started Gnutella download", true
end
Index: src/networks/gnutella/gnutellaServers.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/gnutella/gnutellaServers.ml,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -b -r1.28 -r1.29
--- src/networks/gnutella/gnutellaServers.ml 19 May 2006 23:43:55 -0000
1.28
+++ src/networks/gnutella/gnutellaServers.ml 19 Sep 2006 17:07:43 -0000
1.29
@@ -678,14 +678,14 @@
(* *)
(*************************************************************************)
-let really_download_file (r : result_info) =
+let really_download_file (r : result_info) user =
if !verbose then
lprintf "download_file\n";
let file_temp = match r.result_uids with
[] -> assert false
| uid :: _ -> Uid.to_file_string uid in
let file = new_file file_temp
- (List.hd r.result_names) r.result_size r.result_uids in
+ (List.hd r.result_names) r.result_size r.result_uids user in
if !verbose then
lprintf "DOWNLOAD FILE %s\n" file.file_name;
if not (List.memq file !current_files) then begin
Index: docs/multiuser.txt
===================================================================
RCS file: docs/multiuser.txt
diff -N docs/multiuser.txt
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ docs/multiuser.txt 19 Sep 2006 17:07:42 -0000 1.1
@@ -0,0 +1,143 @@
+Description of multiuser patch
+==============================
+This file provides some HowTos and internals about the new multiuser
+functionality of MLDonkey. The goal is to provide a p2p-service to be used
+by more than user and where each user has its own environment in provided
+by the daemon.
+
+Some basics and definitions
+===========================
+User "admin" and all users belonging to a group where group_admin = true can
+see all files in any case and can use all functions of MLDonkey.
+
+file_owner in this text means one user which owns a downloading file,
+file_group means one group the file belongs to, file_owner must be a member of
+this group, both values are saved in files.ini.
+
+New options (displayed options are default values)
+==================================================
+users.ini
+---------
+- users is kept unchanged for compatibility
+- users2 is extended with these settings:
+
+ user_groups = []
+A list of groups the user belongs to, this user can view all files
+which belong to one of the groups
+
+The default group of the user, the user must also be a member of this
+group. File_group of new downloads started by the user are automatically
+assigned to this value. This value can be None, this means the file is
+only visible to the file_owner (and admins, of course).
+ user_default_group = mldonkey
+
+E-mail address to sent commit notifications to. Globals option "mail"
+can still be used for admins, if both addresses match only one mail is sent.
+ user_mail = ""
+
+Not implemented yet, planned feature is to have user specific directories
+below global incoming directories.
+ user_commit_dir = ""
+
+Like global option max_concurrent_downloads this implements a user-specific
+limit of the maximum number of concurrent files a user can download. Other
+downloads are queued, this is done by round-robin. If the sum of
+user_max_concurrent_downloads from all users is bigger than
+max_concurrent_downloads less downloads than user_max_concurrent_downloads
+are in downloading state. 0 means no user-specific limit.
+Users can change file priorities the control which files are not queued.
+ user_max_concurrent_downloads = 0
+
+- groups, new option
+At least one group named "mldonkey" with group_admin = true must exist
+
+This option is not implemented yet
+ group_mail = ""
+
+Option to control if the group has admin rights. All users belonging to such a
+group have the same rights as user "admin".
+ group_admin = true
+
+
+files.ini
+---------
+- each file has two new options in files.ini
+file_owner: the incoming directory of the owner is used for commit,
+ if the user does not exist "admin" is used
+file_group: default value for a new download is user_default_group
+ if file_owner is not member of file_group or the group does not
+ exist, the value user_default_group is used
+
+
+Commands to control multiuser features/data
+===========================================
+chgrp <group> "<num>"
+change group of download <num> to <group>, group = none for private file
+
+chown <user> "<num>"
+change owner of download <num> to <user>
+
+groupadd <group> <admin: true | false> [<mail>]
+add new mldonkey group
+
+passwd <passwd>
+change own password
+
+useradd <user> <passwd>
+add new mldonkey user/change user password
+
+usercommit <user> <dir>
+change user specific commit directory
+
+userdel <user>
+remove a mldonkey user
+
+userdls <user> <num>
+change number of allowed concurrent downloads
+
+usermail <user> <mail>
+change user mail address
+
+users
+use this command in HTML interface for a small GUI to control users
+
+whoami
+print logged-in user name
+
+
+Updating from a non-multiuser MLDonkey
+======================================
+When updating all files have file_owner "admin" and file_group "mldonkey".
+All existing users have
+user_default_group = "mldonkey" and user_groups = ["mldonkey"].
+This means all users can use all features of MLDonkey and see all files
+in use by MLDonkey core.
+
+To hide user downloads from each other create a new group with
+group_admin = false and assign all users to this group and remove them
+from all admin groups
+
+
+Additional features
+===================
+- file_completed_cmd has new environment variables $FILE_OWNER and $FILE_GROUP
+- remove option enable_user_config, replaced by membership of admin groups
+
+To-Do
+======
+- check on start-up of group "mldonkey" exists and if it has admin rights
+- implement groupdel + prevent deletion if group is in use
+- prevent groupdel if group is file_group of current downloads
+- prevent groupdel if group has members
+- implement user_commit_dir (work is done in multigroup_usercommit.patch)
+ Besides supporting the option user_commit_dir the mechanism to choose
+ incoming directory is changed.
+ Incoming directories are saved in a list of directories in option
+ shared_directories. They have a special sharing_strategy named
+ incoming_directories (for BT multifile downloads only) or incoming_files.
+ Current implementation uses the first directory with this stratagy found in
+ the list.
+ The new implementation (already done) iters the list of marked incoming
+ directories until one is found with enough free space. If no usable directory
+ is found, the file will stay in the list of files to be committed.
+- implement group_mail
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., (continued)
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/01
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/03
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/03
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/04
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/05
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/05
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/14
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/14
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/16
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/16
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co...,
mldonkey-commits <=
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/22
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/23
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/23
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/25
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/25
- [Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co..., mldonkey-commits, 2006/09/25