1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
3 This file is part of mldonkey.
5 mldonkey is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 mldonkey is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with mldonkey; if not, write to the Free Software
17 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
28 open TcpBufferedSocket
42 open CommonComplexOptions
44 let log_prefix = "[cInt]"
47 lprintf_nl2
log_prefix fmt
50 lprintf2
log_prefix fmt
52 (************* ADD/REMOVE FUNCTIONS ************)
53 let check_forbidden_chars (uc
: Charset.uchar
) =
56 | 92 (* '\\' *) -> 95 (* '_' *)
57 (* Windows can't do these *)
65 | 37 (* '%' *) when Autoconf.windows
-> 95 (* '_' *)
68 let canonize_basename name
=
69 let buf = Buffer.create
100 in
70 let uname = Charset.Locale.to_utf8 name
in
71 for i
= 0 to Charset.utf8_length
uname - 1 do
72 (* replace chars on users request *)
73 let uc = Charset.utf8_get
uname i
in
75 let us = List.assoc
uc !!utf8_filename_conversions
in
76 for j
= 0 to Charset.utf8_length
us - 1 do
77 let uc'
= Charset.utf8_get
us j
in
78 let uc''
= check_forbidden_chars uc'
in
79 Charset.add_uchar
buf uc''
83 let uc'
= check_forbidden_chars uc in
84 Charset.add_uchar
buf uc'
87 if not
Autoconf.windows
then
88 Charset.Locale.to_locale
(Buffer.contents
buf)
90 Buffer.contents
buf (* Windows uses patched Ocaml which always uses Unicode chars *)
92 let last_sent_dir_warning = Hashtbl.create
10
94 let hdd_full_log_closed = ref false
95 let all_temp_queued = ref false
97 let send_dirfull_warning dir full line1
=
98 if !!smtp_server
<> "" && !!smtp_port
<> 0 then begin
99 let status = if full
then "is full" else "has enough space again" in
100 lprintf_nl "WARNING: Directory %s %s, %s" dir
status line1
;
101 if (not
(keep_console_output
())) then
102 Printf.eprintf
"\n%s WARNING: Directory %s %s, %s\n%!" (log_time
()) dir
status line1
;
103 if !!hdd_send_warning_interval
<> 0 then
104 let current_time = last_time
() in
106 current_time - !!hdd_send_warning_interval
* Date.hour_in_secs
in
107 let send_mail_again =
109 let last = Hashtbl.find
last_sent_dir_warning dir
in
110 last < time_threshold
111 with Not_found
-> true in
113 if send_mail_again then begin
114 if full
then Hashtbl.replace
last_sent_dir_warning dir
current_time;
115 CommonEvent.add_event
(Console_message_event
116 (Printf.sprintf
"\nWARNING: %s %s, %s\n" dir
status line1
));
118 let module M
= Mailer
in
119 let subject = Printf.sprintf
"[mldonkey@%s] AUTOMATED WARNING: %s %s" (Unix.gethostname
()) dir
status in
121 M.mail_to
= !!mail; M.mail_from
= !!mail;
122 M.mail_subject
= subject; M.mail_body
= line1
;
125 M.sendmail
!!smtp_server
!!smtp_port
!!add_mail_brackets
mail
130 let file_committed_name incoming_dir file
=
131 (try Unix2.safe_mkdir incoming_dir
with _
-> ());
132 let fs = Unix32.filesystem incoming_dir
in
134 match Unix32.fnamelen incoming_dir
with
139 Filename2.filesystem_compliant
140 (canonize_basename (file_best_name file
)) fs namemax in
143 if Sys.file_exists
(Filename.concat incoming_dir
new_name) then
146 Filename2.filesystem_compliant
147 (Printf.sprintf
"%s_%d" new_name num
) fs namemax in
148 if Sys.file_exists
(Filename.concat incoming_dir
new_name) then
154 set_file_best_name file
(file_best_name file
) "" 0;
155 Filename.concat incoming_dir
new_name
157 let script_for_file file incoming
new_name =
158 let info = file_info file
in
159 let temp_name = file_disk_name file
in
160 let file_id = Filename.basename
temp_name in
161 let size = Int64.to_string
(file_size file
) in
163 string_of_int
((BasicSocket.last_time
()) - info.G.file_age
)
165 let network = network_find_by_num
info.G.file_network
in
166 let filename = Filename.basename
new_name in
167 let file_group_info =
168 match file_group file
with
171 let users = ref [] in
172 let counter = ref 0 in
173 user2_users_iter
(fun u
->
174 if file_owner file
<> u
&&
175 user2_can_view_file u
(file_owner file
) (file_group file
) then
178 users := (Printf.sprintf
"FILE_GROUP_USER_%d" !counter, u
.user_name
) ::
179 (Printf.sprintf
"FILE_GROUP_DIR_%d" !counter, u
.user_commit_dir
) :: !users
184 MlUnix.fork_and_exec
!!file_completed_cmd
185 [| (* keep those for compatibility *)
191 ~vars
:([("TEMPNAME", temp_name);
194 ("FILENAME", filename);
195 ("FILEHASH", string_of_uids
info.G.file_uids
);
196 ("DURATION", duration);
197 ("DLFILES", string_of_int
(List.length
!!files
));
198 ("INCOMING", incoming
);
199 ("NETWORK", network.network_name
);
200 ("ED2K_HASH", (file_print_ed2k_link
filename (file_size file
) info.G.file_md4
));
201 ("FILE_OWNER",(file_owner file
).user_name
);
202 ("FILE_GROUP",user2_print_group
(file_group file
));
203 ("USER_MAIL", ( if (file_owner file
).user_mail
<> "" then
204 (file_owner file
).user_mail
206 if !!mail <> "" then !!mail else ""));
207 ("FILE_GROUP_CNT", string_of_int
(fst
(file_group_info)));
209 @ snd
(file_group_info))
212 lprintf_nl "Exception %s while executing %s"
213 (Printexc2.to_string e
) !!file_completed_cmd
217 These two functions 'file_commit' and 'file_cancel' should be the two only
218 functions in mldonkey able to destroy a file, the first one by moving it,
219 the second one by deleting it.
221 Note that when the network specific file_commit function is called, the
222 file has already been moved to the incoming/ directory under its new
226 let file_commit file
=
227 let impl = as_file_impl file
in
228 if impl.impl_file_state
= FileDownloaded
then
229 let subfiles = file_files file
in
231 primary
:: secondary_files
->
232 if primary
== file
then
234 let file_name = file_disk_name file
in
237 (Unix2.is_directory
file_name)
238 ~needed_space
:(file_size file
)
239 ~user
:(file_owner file
)
243 let new_name = file_committed_name incoming.shdir_dirname file
in
244 if Unix2.is_directory
file_name then begin
245 Unix2.safe_mkdir
new_name;
246 Unix2.chmod
new_name !Unix32.create_dir_mode
;
249 (* the next line really moves the file *)
250 set_file_disk_name file
new_name;
252 if !!file_completed_cmd
<> "" then
253 script_for_file file
incoming.shdir_dirname
new_name;
255 let best_name = file_best_name file
in
256 Unix32.destroy
(file_fd file
);
258 if Unix2.is_directory
file_name then Unix2.remove_all_directory
file_name;
260 let impl = as_file_impl file
in
261 (* When the commit action is called, the file is supposed not to exist anymore. *)
262 impl.impl_file_ops
.op_file_commit
impl.impl_file_val
new_name;
266 if not
(Unix2.is_directory
new_name) then
267 ignore
(CommonShared.new_shared
268 incoming.shdir_dirname
incoming.shdir_priority
271 lprintf_nl "Exception %s while trying to share committed file"
272 (Printexc2.to_string e
);
275 update_file_state
impl FileShared
;
276 done_files
=:= List2.removeq file
!!done_files
;
277 files
=:= List2.removeq file
!!files
;
279 List.iter (fun file
->
280 (* Commit the file first, and share it after... *)
282 let impl = as_file_impl file
in
283 update_file_state
impl FileCancelled
;
284 impl.impl_file_ops
.op_file_cancel
impl.impl_file_val
;
285 done_files
=:= List2.removeq file
!!done_files
;
286 files
=:= List2.removeq file
!!files
;
289 lprintf_nl "Exception %s in file_commit secondaries" (Printexc2.to_string e
);
293 send_dirfull_warning "" true
294 (Printf.sprintf
"all incoming dirs are full, can not commit %s" (file_best_name file
))
295 | e
-> lprintf_nl "Exception in file_commit: %s" (Printexc2.to_string e
))
298 let file_cancel file user
=
299 if user2_allow_file_admin file user
then
301 let impl = as_file_impl file
in
302 if impl.impl_file_state
<> FileCancelled
then
303 let subfiles = file_files file
in
304 if file
!= List.hd
subfiles then
305 failwith
"Cannot cancel non primary file";
306 List.iter (fun file
->
308 update_file_state
impl FileCancelled
;
309 impl.impl_file_ops
.op_file_cancel
impl.impl_file_val
;
310 files
=:= List2.removeq file
!!files
;
312 lprintf_nl "Exception %s in file_cancel" (Printexc2.to_string e
);
315 let fd = file_fd file
in
319 lprintf_nl "Sys.remove %s exception %s"
320 (file_disk_name file
)
321 (Printexc2.to_string e
));
325 lprintf_nl "Exception in file_cancel: %s" (Printexc2.to_string e
)
327 let mail_for_completed_file file
=
328 let usermail = (file_owner file
).user_mail
in
329 if (!!mail <> "" || usermail <> "") && !!smtp_server
<> "" && !!smtp_port
<> 0 then begin
330 let module M
= Mailer
in
331 let info = file_info file
in
332 let line1 = "mldonkey has completed the download of:\r\n\r\n" in
334 let line2 = Printf.sprintf
"\r\nFile: %s\r\nSize: %Ld bytes\r\nHash: %s\r\nFile was downloaded in %s\r\n"
335 (file_best_name file
)
337 (string_of_uids
info.G.file_uids
)
338 (let age = (BasicSocket.last_time
()) - info.G.file_age
in Date.time_to_string
age "verbose")
341 let line3 = if (file_comment file
) = "" then "" else
342 Printf.sprintf
"\r\nComment: %s\r\n" (file_comment file
)
345 let subject = if !!filename_in_subject
then
346 Printf.sprintf
"mldonkey - %s complete" (file_best_name file
)
348 Printf.sprintf
"mldonkey - download complete"
351 (* TODO: This information can be wrong *)
352 let incoming = incoming_dir
(Unix2.is_directory
(file_disk_name file
)) () in
354 let line4 = if !!url_in_mail
= "" then "" else
355 Printf.sprintf
"\r\n<%s/%s%s/%s>\r\n"
357 incoming.shdir_dirname
358 (if (file_owner file
).user_commit_dir
= "" then ""
359 else Printf.sprintf
"/%s" (file_owner file
).user_commit_dir
)
360 (Url.encode
(file_best_name file
))
363 let line5 = if !!auto_commit
then "" else
364 Printf.sprintf
"\r\nauto_commit is disabled, file is not committed to incoming"
368 Printf.sprintf
"\r\nUser/Group: %s:%s" (file_owner file
).user_name
(user2_print_group
(file_group file
))
372 Printf.sprintf
"\r\nHost: %s\r\n" (Unix.gethostname
())
375 let send_mail address admin
=
378 M.mail_from
= address
;
379 M.mail_subject
= subject;
380 M.mail_body
= line1 ^
line2 ^
line3 ^
line4 ^
line5 ^
(if admin
then line6 else "") ^
line7;
382 M.sendmail
!!smtp_server
!!smtp_port
!!add_mail_brackets
mail
384 if !!mail <> "" then send_mail !!mail true; (* Multiuser ToDo: this mail is for the admin user, optional? *)
385 if usermail <> "" && usermail <> !!mail then (try send_mail usermail false with Not_found
-> ())
388 let file_completed (file
: file
) =
390 let impl = as_file_impl file
in
391 if impl.impl_file_state
= FileDownloading
then begin
392 CommonSwarming.duplicate_chunks
();
393 set_file_release file
false (admin_user
());
394 files
=:= List2.removeq file
!!files
;
395 done_files
=:= file
:: !!done_files
;
396 update_file_state
impl FileDownloaded
;
397 (try mail_for_completed_file file
with e
->
398 lprintf_nl "Exception %s in sendmail" (Printexc2.to_string e
);
402 lprintf_nl "Exception in file_completed: %s" (Printexc2.to_string e
)
404 let file_add impl state
=
406 let file = as_file
impl in
407 if impl.impl_file_state
= FileNew
then begin
408 update_file_num
impl;
411 done_files
=:= file :: !!done_files
;
414 | FileCancelled
-> ()
420 files
=:= !!files
@ [file]);
421 update_file_state
impl state
424 lprintf_nl "[cInt] Exception in file_add: %s" (Printexc2.to_string e
)
426 let server_remove server
=
428 match server_state server
with
430 | _
-> server_disconnect server
433 let impl = as_server_impl server
in
434 if impl.impl_server_state
<> RemovedHost
then begin
435 set_server_state server RemovedHost
;
436 (try impl.impl_server_ops
.op_server_remove
impl.impl_server_val
438 servers
=:= Intmap.remove
(server_num server
) !!servers
441 lprintf_nl "[cInt] Exception in server_remove: %s" (Printexc2.to_string e
)
443 let server_add impl =
444 let server = as_server
impl in
445 if impl.impl_server_state
= NewHost
then begin
446 server_update_num
impl;
447 servers
=:= Intmap.add
(server_num
server) server !!servers
;
448 impl.impl_server_state
<- NotConnected
(BasicSocket.Closed_by_user
, -1);
452 let impl = as_client_impl c
in
453 if not
(is_friend c
) then begin
455 client_must_update c
;
456 friends
=:= c
:: !!friends
;
457 contacts
:= List2.removeq c
!contacts
;
458 if network_is_enabled
((as_client_impl c
).impl_client_ops
.op_client_network
) then
459 impl.impl_client_ops
.op_client_browse
impl.impl_client_val
true
462 (* Maybe we should not add the client to the contact list and completely remove
464 let friend_remove c
=
466 let impl = as_client_impl c
in
467 if is_friend c
then begin
469 client_must_update c
;
470 friends
=:= List2.removeq c
!!friends
;
471 impl.impl_client_ops
.op_client_clear_files
impl.impl_client_val
473 if is_contact c
then begin
475 client_must_update c
;
476 contacts
:= List2.removeq c
!contacts
;
477 impl.impl_client_ops
.op_client_clear_files
impl.impl_client_val
481 lprintf_nl "Exception in friend_remove: %s" (Printexc2.to_string e
)
484 let impl = as_client_impl c
in
485 if not
(is_friend c
|| is_contact c
) then begin
487 client_must_update c
;
488 contacts
:= c
:: !contacts
;
489 if network_is_enabled
((as_client_impl c
).impl_client_ops
.op_client_network
) then
490 impl.impl_client_ops
.op_client_browse
impl.impl_client_val
true
493 let contact_remove c
=
495 let impl = as_client_impl c
in
496 if is_contact c
then begin
498 client_must_update c
;
499 contacts
:= List2.removeq c
!contacts
;
500 impl.impl_client_ops
.op_client_clear_files
impl.impl_client_val
503 lprintf_nl "Exception in contact_remove: %s" (Printexc2.to_string e
)
507 let can_exit = networks_for_all network_clean_exit
in
508 if can_exit then exit_properly n
510 let rec retry_later retry_counter
=
511 add_timer
1. (fun _
->
512 let can_exit = networks_for_all network_clean_exit
in
513 if can_exit || retry_counter
> !!shutdown_timeout
then
515 else retry_later (retry_counter
+ 1)) in
518 if (upnp_port_forwarding
()) then
520 if !!clear_upnp_port_at_exit
then
521 UpnpClient.remove_all_maps
0 ;
522 UpnpClient.job_stop
3;
526 let time_of_sec sec
=
527 let hours = sec
/ 60 / 60 in
528 let rest = sec
- hours * 60 * 60 in
529 let minutes = rest / 60 in
530 let seconds = rest - minutes * 60 in
531 if hours > 0 then Printf.sprintf
"%d:%02d:%02d" hours minutes seconds
532 else if minutes > 0 then Printf.sprintf
"%d:%02d" minutes seconds
533 else Printf.sprintf
"00:%02d" seconds
536 let display_vd = ref false
537 let display_bw_stats = ref false
539 let start_download file =
540 if !!pause_new_downloads
then file_pause
file (admin_user
());
541 if !!release_new_downloads
then set_file_release
file true (admin_user
());
542 if !!file_started_cmd
<> "" then
544 let info = file_info
file in
545 let temp_name = file_disk_name
file in
546 let file_id = Filename.basename
temp_name in
547 let size = Int64.to_string
(file_size
file) in
548 let network = network_find_by_num
info.G.file_network
in
549 let filename = file_best_name
file in
550 let file_group_info =
551 match file_group
file with
554 let users = ref [] in
555 let counter = ref 0 in
556 user2_users_iter
(fun u
->
557 if file_owner
file <> u
&&
558 user2_can_view_file u
(file_owner
file) (file_group
file) then
561 users := (Printf.sprintf
"FILE_GROUP_USER_%d" !counter, u
.user_name
) ::
562 (Printf.sprintf
"FILE_GROUP_DIR_%d" !counter, u
.user_commit_dir
) :: !users
566 MlUnix.fork_and_exec
!!file_started_cmd
570 string_of_int
(CommonFile.file_num
file);
572 ~vars
:([("TEMPNAME", temp_name);
575 ("FILENAME", filename);
576 ("FILEHASH", string_of_uids
info.G.file_uids
);
577 ("DLFILES", string_of_int
(List.length
!!files
));
578 ("NETWORK", network.network_name
);
579 ("ED2K_HASH", (file_print_ed2k_link
filename (file_size
file) info.G.file_md4
));
580 ("FILE_OWNER",(file_owner
file).user_name
);
581 ("FILE_GROUP",user2_print_group
(file_group
file));
582 ("USER_MAIL", ( if (file_owner
file).user_mail
<> "" then
583 (file_owner
file).user_mail
585 if !!mail <> "" then !!mail else ""));
586 ("FILE_GROUP_CNT", string_of_int
(fst
(file_group_info)));
588 @ snd
(file_group_info))
591 let download_file o arg
=
592 let user = o
.conn_user
in
593 let buf = o
.conn_buf
in
594 Printf.bprintf
buf "%s\n" (
596 match user.ui_last_search
with
597 None
-> "no last search"
599 let result = List.assoc
(int_of_string arg
) user.ui_last_results
in
600 let files = CommonResult.result_download
601 result [] false user.ui_user
in
602 List.iter start_download files;
606 | _
-> "could not start download"
609 let start_search user query
buf =
610 let s = CommonSearch.new_search
user query
in
612 match s.search_type
with
614 CommonSearch.local_search
s
616 networks_iter
(fun r
->
617 if query
.GuiTypes.search_network
= 0 ||
618 r
.network_num
= query
.GuiTypes.search_network
619 then network_search r
s buf);
624 let network_must_update n
=
625 CommonEvent.add_event
(Network_info_event n
)
627 let network_display_stats o
=
628 networks_iter_all
(fun r
->
630 if List.mem NetworkHasStats r
.network_flags
then
631 network_display_stats r o
634 let print_connected_servers o
=
635 let buf = o
.conn_buf
in
636 networks_iter
(fun r
->
638 let list = network_connected_servers r
in
639 if List.mem NetworkHasServers r
.network_flags
||
640 List.mem NetworkHasSupernodes r
.network_flags
642 if use_html_mods o
then begin
643 html_mods_table_one_row
buf "serversTable" "servers" [
644 ("", "srh", Printf.sprintf
(_b
"--- Connected to %d servers on the %s network ---\n")
645 (List.length
list) r
.network_name
); ]
648 Printf.bprintf
buf (_b
"--- Connected to %d servers on the %s network ---\n")
649 (List.length
list) r
.network_name
;
651 if use_html_mods o
&& List.length
list > 0 then server_print_html_header
buf "C";
653 html_mods_cntr_init
();
656 ) (List.sort
(fun s1 s2
-> compare
(server_num s1
) (server_num s2
)) list);
657 if use_html_mods o
&& List.length
list > 0 then
658 Printf.bprintf
buf "\\</table\\>\\</div\\>";
659 if Autoconf.donkey
= "yes" && r
.network_name
= "Donkey" && not
!!enable_servers
then
661 if use_html_mods o
then Printf.bprintf
buf "\\<div class=servers\\>";
662 Printf.bprintf
buf (_b
"You disabled server usage, therefore you are not able to connect ED2K servers.\n");
663 Printf.bprintf
buf (_b
"To use servers again 'set enable_servers true'\n");
664 if use_html_mods o
then Printf.bprintf
buf "\\</div\\>"
667 Printf.bprintf
buf "Exception %s in print_connected_servers"
668 (Printexc2.to_string e
);
671 let send_custom_query user buf query args
=
673 let q = List.assoc query
(CommonComplexOptions.customized_queries
()) in
674 let args = ref args in
675 let get_arg arg_name
=
676 (* lprintf "Getting %s\n" arg_name; *)
678 (label
, value) :: tail
->
680 if label
= arg_name
then value else begin
681 Printf.bprintf
buf "Error expecting argument %s instead of %s" arg_name label
;
685 Printf.bprintf
buf "Error while expecting argument %s" arg_name
;
690 | Q_COMBO _
-> assert false
692 let value = get_arg "keywords" in
693 want_and_not andnot
(fun w
-> QHasWord w
) QNone
value
699 try ands := (iter q) :: !ands with _
-> ()) list;
701 [] -> raise Not_found
704 List.fold_left
(fun q1 q2
-> QAnd
(q1
,q2
)) q1 tail
711 try ands := (iter q) :: !ands with _
-> ()) list;
713 [] -> raise Not_found
716 List.fold_left
(fun q1 q2
-> QAnd
(q1
,q2
)) q1 tail
723 try ands := (iter q) :: !ands with _
-> ()) list;
725 [] -> raise Not_found
728 List.fold_left
(fun q1 q2
-> QOr
(q1
,q2
)) q1 tail
731 | Q_ANDNOT
(q1
, q2
) ->
739 | Q_MODULE
(s, q) -> iter q
742 let minsize = get_arg "minsize" in
743 let unit = get_arg "minsize_unit" in
744 if minsize = "" then raise Not_found
;
745 let minsize = Int64.of_string
minsize in
746 let unit = Int64.of_string
unit in
747 QHasMinVal
(Field_Size
, Int64.mul
minsize unit)
750 let maxsize = get_arg "maxsize" in
751 let unit = get_arg "maxsize_unit" in
752 if maxsize = "" then raise Not_found
;
753 let maxsize = Int64.of_string
maxsize in
754 let unit = Int64.of_string
unit in
755 QHasMaxVal
(Field_Size
, maxsize ** unit)
758 let format = get_arg "format" in
759 let format_propose = get_arg "format_propose" in
760 let format = if format = "" then
761 if format_propose = "" then raise Not_found
766 (fun w
-> QHasField
(Field_Format
, w
)) QNone
format
769 let media = get_arg "media" in
770 let media_propose = get_arg "media_propose" in
771 let media = if media = "" then
772 if media_propose = "" then raise Not_found
775 QHasField
(Field_Type
, media)
778 let artist = get_arg "artist" in
779 if artist = "" then raise Not_found
;
780 want_comb_not andnot and_comb
781 (fun w
-> QHasField
(Field_Artist
, w
)) QNone
artist
784 let title = get_arg "title" in
785 if title = "" then raise Not_found
;
786 want_comb_not andnot and_comb
787 (fun w
-> QHasField
(Field_Title
, w
)) QNone
title
790 let album = get_arg "album" in
791 if album = "" then raise Not_found
;
792 want_comb_not andnot and_comb
793 (fun w
-> QHasField
(Field_Album
, w
)) QNone
album
796 let bitrate = get_arg "bitrate" in
797 if bitrate = "" then raise Not_found
;
798 QHasMinVal
(Field_KNOWN
"bitrate", Int64.of_string
bitrate)
802 let request = CommonIndexing.simplify_query
(iter q) in
803 Printf.bprintf
buf "Sending query !!!";
806 let module G
= GuiTypes
in
808 G.search_query
= request;
809 G.search_type
= RemoteSearch
;
810 G.search_max_hits
= 10000;
813 let net = get_arg "network" in
814 (network_find_by_name
net).network_num
818 ignore
(start_search user s buf)
821 Printf.bprintf
buf "Void query %s" query
824 Printf.bprintf
buf "No such custom search %s" query
827 Printf.bprintf
buf "Error %s while parsing request"
828 (Printexc2.to_string e
)
831 List.sort
(fun o1 o2
->
832 String.compare o1
.option_name o2
.option_name
) l
834 let opfile_args r opfile
=
835 let prefix = r
.network_shortname ^
"-" in
836 simple_options
prefix opfile
true
838 let all_simple_options () =
839 let options = ref (sort_options
840 (simple_options
"" downloads_ini
true)
843 networks_iter_all
(fun r
->
844 List.iter (fun opfile
->
845 options := !options @ (opfile_args r opfile
)
847 r
.network_config_file
851 let parse_simple_options args =
852 let v = all_simple_options () in
856 let match_star = Str.regexp
"\\*" in
857 let options_filter = Str.regexp
("^\\("
858 ^
(List.fold_left
(fun acc a
-> acc
859 ^
(if acc
<> "" then "\\|" else "")
860 ^
(Str.global_replace
match_star ".*" a
)) "" args)
862 List.filter
(fun o
-> Str.string_match
options_filter o
.option_name
0) v
864 let some_simple_options num
=
866 let options = ref [] in
867 networks_iter_all
(fun r
->
868 List.iter (fun opfile
->
869 if !cnt = num
then begin
870 options := !options @ (opfile_args r opfile
)
874 ) r
.network_config_file
878 let all_active_network_opfile_network_names () =
879 let names = ref [] in
880 networks_iter_all
(fun r
->
881 List.iter (fun opfile
->
882 names := !names @ [r
.network_name
]
883 ) r
.network_config_file
887 let apply_on_fully_qualified_options name f
=
888 let rec iter prefix opfile
=
889 let args = simple_options
prefix opfile
true in
891 if o
.option_name
= name
then
892 (f opfile o
.option_shortname o
.option_value
; raise Exit
))
896 iter "" downloads_ini
;
898 if not
(networks_iter_all_until_true
(fun r
->
900 List.iter (fun opfile
->
901 let prefix = r
.network_shortname ^
"-" in
904 r
.network_config_file
;
908 lprintf_nl "Could not set option %s" name
;
913 let get_fully_qualified_options name
=
914 let value = ref None
in
916 apply_on_fully_qualified_options name
(fun opfile old_name old_value
->
917 value := Some
(get_simple_option opfile old_name
)
924 let set_fully_qualified_options name
value ?
(user = None
) ?
(ip
= None
) ?
(port
= None
) ?
(gui_type
= None
) () =
925 let old_value = get_fully_qualified_options name
in
926 apply_on_fully_qualified_options name
927 (fun opfile old_name
old_value -> set_simple_option opfile old_name
value);
928 if !verbose
&& old_value <> get_fully_qualified_options name
then
932 | None
-> "IP unknown"
934 Printf.sprintf
"from host %s%s" (Ip.to_string ip
)
935 (match port
with | None
-> "" | Some port
-> Printf.sprintf
":%d" port
)
937 lprintf_nl "User %s changed option %s %s %s, old: %s, new %s"
938 (match user with | None
-> "unknown" | Some
user -> user)
941 | None
-> "GUI type unknown"
942 | Some gt
-> Printf.sprintf
"using %s interface" (connection_type_to_text gt
))
943 old_value (get_fully_qualified_options name
)
946 let keywords_of_query query
=
947 let keywords = ref [] in
952 | QAnd
(q1
, q2
) -> iter q1
; iter q2
953 | QAndNot
(q1
,q2
) -> iter q1
954 | QHasWord w
-> keywords := (String2.split_simplify w ' '
) @ !keywords
955 | QHasField
(field
, w
) ->
961 | _
-> keywords := (String2.split_simplify w ' '
) @ !keywords
963 | QHasMinVal
(field
, value) ->
966 Field_KNOWN
"bitrate"
970 | QHasMaxVal
(field
, value) ->
973 Field_KNOWN
"bitrate"
978 lprintf_nl "start_search: QNone in query";
984 let gui_options_panels = ref ([] : (string * (string * string * string) list) list)
986 let register_gui_options_panel name panel
=
987 if not
(List.mem_assoc name
!gui_options_panels) then
988 gui_options_panels := (name
, panel
) :: !gui_options_panels
991 add_infinite_timer filter_search_delay
(fun _ ->
992 (* if !!filter_search then *) begin
993 (* lprintf "Filter search results\n"; *)
994 List.iter (fun user ->
995 List.iter (fun s -> CommonSearch.Filter.find
s)
996 user.ui_user_searches
;
999 CommonSearch.Filter.clear
();
1002 let search_add_result filter
s r
=
1003 if !CommonSearch.clean_local_search
<> 0 then
1004 CommonSearch.Local.add r
;
1005 if not filter
(*!!filter_search*) then begin
1006 (* lprintf "Adding result to filter\n"; *)
1007 CommonSearch.search_add_result_in
s r
1010 CommonSearch.Filter.add r
1012 let main_options = ref ([] : (string * Arg.spec
* string) list)
1014 let add_main_options list =
1015 main_options := !main_options @ list
1018 (*************************************************************
1020 Every minute, sort the files by priority, and test if the
1021 files with the highest priority are in FileDownloading state,
1022 and the ones with lowest priority in FileQueued state, if there
1023 is a max_concurrent_downloads constraint.
1025 **************************************************************)
1029 type user_file_list
= {
1030 file_list
: file list;
1031 downloads_allowed
: int option;
1034 let force_download_quotas () =
1036 let queue_files files =
1037 List.iter (fun file ->
1038 if file_state
file = FileDownloading
then
1042 let queue_user_file_list (_user
, user_file_list
) =
1043 queue_files user_file_list
.file_list
in
1045 if !all_temp_queued then
1046 queue_files !!CommonComplexOptions.files
1049 (* create the assoc list of downloads of each user *)
1050 let files_by_user = List.fold_left
(fun acc f
->
1051 let owner = CommonFile.file_owner f
in
1053 let owner_file_list = List.assoc
owner acc
in
1054 (owner, { owner_file_list with
1055 file_list
= f
:: owner_file_list.file_list
}) ::
1056 List.remove_assoc
owner acc
1060 (match owner.user_max_concurrent_downloads
with
1063 file_list
= [f
] }) :: acc
1064 ) [] !!CommonComplexOptions.files in
1066 (* sort each user's list separately *)
1067 let files_by_user = List.map
(fun (owner, owner_file_list) ->
1068 owner, { owner_file_list with
1069 file_list
= List.sort
(fun f1 f2
->
1070 let v = compare
(file_priority f2
) (file_priority f1
) in
1071 if v <> 0 then v else
1072 (* [egs] do not start downloading a small file
1073 against an already active download *)
1074 let d1 = file_downloaded f1
in
1075 let d2 = file_downloaded f2
in
1076 let active1 = d1 > 0L in
1077 let active2 = d2 > 0L in
1078 if not
active1 && active2 then 1
1079 else if active1 && not
active2 then -1
1081 (* Try to download in priority files with fewer bytes missing
1082 Rationale: once completed, it may allow to recover some disk space *)
1083 let remaining1 = file_size f1
-- d1 in
1084 let remaining2 = file_size f2
-- d2 in
1085 compare
remaining1 remaining2
1086 ) owner_file_list.file_list
}
1089 (* sort the assoc list itself with user with highest quota first *)
1091 List.sort
(fun (_owner1
, { downloads_allowed
= allowed1
})
1092 (_owner2
, { downloads_allowed
= allowed2
}) ->
1093 match allowed1
, allowed2
with
1097 | Some allowed1
, Some allowed2
-> compare allowed2 allowed1
1100 (* serve users round-robin, starting with the one with highest quota *)
1101 let rec iter downloads_left to_serve served
=
1102 if downloads_left
= 0 then begin
1103 List.iter queue_user_file_list to_serve
;
1104 List.iter queue_user_file_list served
1108 if served
= [] then () (* nothing left to rotate *)
1109 else (* new round *)
1110 iter downloads_left served
[]
1111 | (_owner
, { file_list
= [] }) :: others
->
1112 (* user satisfied, remove from lists *)
1113 iter downloads_left others served
1114 | ((_owner
, { downloads_allowed
= Some
0 }) as first
) :: others
->
1115 (* reached quota, remove from future rounds *)
1116 queue_user_file_list first
;
1117 iter downloads_left others served
1118 | (owner, { file_list
= first_file
:: other_files
;
1119 downloads_allowed
= allowed
}) :: others
->
1120 let is_downloading =
1121 match file_state first_file
with
1122 | FileDownloading
-> true
1124 file_resume first_file
(admin_user
());
1127 if is_downloading then
1128 iter (downloads_left
- 1) others
1130 file_list
= other_files
;
1131 downloads_allowed
= match allowed
with
1133 | Some i
-> Some
(i
- 1)
1136 iter downloads_left others
1138 file_list
= other_files
;
1139 downloads_allowed
= allowed
1141 iter !!max_concurrent_downloads
files_by_user []
1144 option_hook max_concurrent_downloads
(fun _ ->
1145 ignore
(force_download_quotas ())