1 (* Copyright 2001, 2002 b52_simon :), 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
34 open CommonComplexOptions
38 open CommonInteractive
50 let _s x
= _s "BTInteractive" x
51 let _b x
= _b "BTInteractive" x
53 module VB
= VerificationBitmap
55 let porttest_result = ref PorttestNotStarted
57 let interpret_azureus_porttest s
=
58 let failure_message fmt
=
59 Printf.sprintf
("Port test failure, " ^^ fmt
) in
61 let value = decode s
in
65 match List.assoc
"result" alist
with
66 | Int
1L -> "Port test OK!"
69 match List.assoc
"reason" alist
with
70 | String reason
-> failure_message "%s" reason
71 | _
-> raise Not_found
73 failure_message "%s" "no reason given")
75 failure_message "unknown status code (%Ld)" status
76 | _
-> raise Not_found
78 failure_message "%s" "no status given")
80 failure_message "unexpected value type %s" (Bencode.print
value)
82 failure_message "%s" "broken bencoded value"
84 let interpret_utorrent_porttest s
=
85 if String2.contains s
"<div class=\"status-image\">OK!</div>" then
88 "Port is not accessible"
90 let perform_porttests tests
=
92 | [] -> porttest_result := PorttestResult
(last_time
(), "No tests available")
94 let module H
= Http_client
in
95 porttest_result := PorttestInProgress
(last_time
());
96 let rec loop = function
98 | (url
,interpret
)::other
->
101 H.req_url
= Url.of_string url
;
102 H.req_user_agent
= get_user_agent
();
103 (* no sense in using proxy anyway *)
104 (* H.req_proxy = !CommonOptions.http_proxy; *)
105 H.req_max_total_time
= 45.;
108 (fun s
-> porttest_result := PorttestResult
(last_time
(), interpret s
))
110 porttest_result := PorttestResult
(last_time
(), Printf.sprintf
"Error : %s" (H.show_error e
));
116 let op_file_all_sources file
=
118 Hashtbl.iter
(fun _ c
->
119 list := (as_client c
) :: !list
123 let op_file_active_sources file
=
125 Hashtbl.iter
(fun _ c
->
126 let as_c = as_client c
in
127 match client_state
as_c with
128 Connected_downloading _
-> list := as_c :: !list
133 let op_file_files file impl
=
134 match file
.file_swarmer
with
135 None
-> [CommonFile.as_file impl
]
137 CommonSwarming.subfiles swarmer
139 let op_file_debug file
=
140 let buf = Buffer.create
100 in
141 (* CommonSwarming.debug_print buf file.file_swarmer; *)
142 Hashtbl.iter
(fun _ c
->
143 Printf.bprintf
buf "Client %d: %s\n" (client_num c
)
144 (match c
.client_sock
with
145 NoConnection
-> "No Connection"
146 | Connection _
-> "Connected"
147 | ConnectionWaiting _
-> "Waiting for Connection"
152 let op_file_commit file new_name
=
153 CommonSwarming.remove_swarmer file
.file_swarmer
;
154 file
.file_swarmer
<- None
;
155 if file_state file
<> FileShared
then
157 if not
(List.mem
(file
.file_name
, file_size file
) !!old_files
) then
158 old_files
=:= (file
.file_name
, file_size file
) :: !!old_files
;
159 set_file_state file FileShared
;
161 if Unix32.destroyed
(file_fd file
) then
162 if !verbose
then lprintf_file_nl
(as_file file
) "op_file_commit: FD is destroyed... repairing";
164 (* During the commit operation, for security, the file_fd is destroyed. So
165 we create it again to be able to share this file again. *)
168 (create_temp_file new_name
(List.map
(fun (file
,size
,_
) -> (file
,size
)) file
.file_files
) (file_state file
));
170 if Unix32.destroyed
(file_fd file
) then
171 lprintf_file_nl
(as_file file
) "op_file_commit: FD is destroyed... could not repair!";
173 let new_torrent_diskname =
174 Filename.concat seeded_directory
175 (Filename.basename file
.file_torrent_diskname
)
178 Unix2.rename file
.file_torrent_diskname
new_torrent_diskname;
180 (lprintf_file_nl
(as_file file
) "op_file_commit: failed to rename %s to %s"
181 file
.file_torrent_diskname
new_torrent_diskname));
182 file
.file_torrent_diskname
<- new_torrent_diskname;
184 (* update file_shared with new path to committed file *)
185 match file
.file_shared
with
190 impl_shared_update
= 1;
191 impl_shared_fullname
= file_disk_name file
;
192 impl_shared_codedname
= old_impl
.impl_shared_codedname
;
193 impl_shared_size
= file_size file
;
194 impl_shared_id
= Md4.null
;
196 impl_shared_uploaded
= old_impl
.impl_shared_uploaded
;
197 impl_shared_ops
= shared_ops
;
198 impl_shared_val
= file
;
199 impl_shared_requests
= old_impl
.impl_shared_requests
;
200 impl_shared_file
= Some
(as_file file
);
201 impl_shared_servers
= [];
203 file
.file_shared
<- Some
impl;
204 replace_shared old_impl
impl;
209 let re = Str.regexp_case_fold
"\\(https?://[a-zA-Z0-9_.!~*'();/?:@&=+$,%-]+\\)" in
210 fun s
-> Str.global_replace
re "\\<a href=\\\"\\1\\\"\\>\\1\\</a\\>" s
212 (** Get swarming info for subfiles (priorities and progress)
213 @return empty list if no swarmer *)
214 let get_subfiles file
=
215 match try Some
(CommonSwarming.file_swarmer
(as_file file
)) with _
-> None
with
218 match CommonSwarming.get_swarmer_priorities_intervals swarmer
with
220 | ((_
,prio
)::_
as l
) ->
221 let intervals = ref l
in
222 let prio = ref prio in
223 let rec count_intervals_till bytes
=
224 let rec loop acc_prio
= function
225 | (i_start
,i_prio
) :: tail
when i_start
< bytes
->
227 loop (min acc_prio i_prio
) tail
228 | ((i_start
,i_prio
) :: _
as l
) when i_start
= bytes
->
232 | l
-> intervals := l
; acc_prio
234 loop !prio !intervals
236 let downloaded = CommonSwarming.get_swarmer_block_verified swarmer
in
238 Unix32.subfile_tree_map
(file_fd file
)
239 begin fun fname start length current_length
->
240 let prio = count_intervals_till (start
++ length
) in
241 (* let (blockstart,blockend) = CommonSwarming.blocks_of_ *)
242 let stop = if length
<> 0L then (start
++ length
-- 1L) else start
in
243 let blockstart = try CommonSwarming.compute_block_num swarmer start
with _
-> 0 in
244 let blockend = try CommonSwarming.compute_block_num swarmer
stop with _
-> 0 in
246 for i
= blockstart to blockend do
247 if VB.State_verified
= VB.get
downloaded i
then incr
ok;
249 let progress = float !ok /. float (blockend - blockstart + 1) in
250 r := (fname
, length
, prio, progress) :: !r
255 let op_file_print file o
=
258 let subfiles = ref (get_subfiles file
) in
259 List.map
begin fun (name
,size
,magic
) ->
260 let magic = match magic with None
-> "" | Some m
-> Printf.sprintf
" / %s" m
in
262 | [] -> (name
,size
,magic,"",None
)
263 | (i_name
,i_size
,i_prio
,progress)::t
->
265 lprintf_nl "%S = %S %Ld = %Ld | priority %d" name i_name size i_size i_prio;
268 let progress = Printf.sprintf
", %.0f%%" (100. *. progress) in
269 if name
= i_name
&& size
= i_size
then (* sanity check *)
270 (name
,size
,magic,progress,Some i_prio
)
272 (name
,size
,magic,progress,None
)
275 let buf = o
.conn_buf
in
276 if use_html_mods o
then
278 let emit text ?
(desc
=text
) value =
279 Printf.bprintf
buf "\\</tr\\>\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr
());
281 (desc
, "sr br", text
);
286 emit (_s"Filename") file
.file_name
;
287 emit (_s"Hash") ~desc
:(_s"Torrent metadata hash") (Sha1.to_hexa file
.file_id
);
288 emit (_s"Torrent search") ~desc
:(_s"Search for similar torrent files") (Printf.sprintf
289 "\\<a target=\\\"_blank\\\" href=\\\"http://isohunt.com/%s\\\"\\>IsoHunt\\</a\\>" file
.file_name
);
291 let tracker_header_printed = ref false in
292 List.iter
(fun tracker
->
293 let tracker_url = show_tracker_url tracker
.tracker_url in
295 if not
!!use_trackers
then
296 Printf.sprintf
"disabled: %s" tracker_url
298 match tracker
.tracker_status
with
299 | Disabled s
| Disabled_mld s
->
300 Printf.sprintf
"\\<font color=\\\"red\\\"\\>disabled: %s\\<br\\>\\--error: %s\\</font\\>"
302 | Disabled_failure
(i
,s
) ->
303 Printf.sprintf
"\\<font color=\\\"red\\\"\\>disabled: %s\\<br\\>\\--error: %s (try %d)\\</font\\>"
306 Printf.sprintf
"enabled: %s" tracker_url
308 let text = if not
!tracker_header_printed then _s"Tracker(s)" else "" in
309 emit text tracker_text;
310 tracker_header_printed := true;
311 ) file
.file_trackers
;
313 emit (_s"Torrent filename") file
.file_torrent_diskname
;
314 emit (_s"Comment") (match file
.file_comment
with "" -> "-" | s
-> auto_links s
);
315 emit (_s"Created by") (match file
.file_created_by
with "" -> "-" | s
-> auto_links s
);
316 emit (_s"Creation date") (Date.to_string
(Int64.to_float file
.file_creation_date
));
317 emit (_s"Modified by") (match file
.file_modified_by
with "" -> "-" | s
-> auto_links s
);
318 emit (_s"Encoding") (match file
.file_encoding
with "" -> "-" | s
-> s
);
319 emit (_s"Piece size") (Int64.to_string file
.file_piece_size
);
320 emit (_s"Private") ~desc
:(_s"Private torrents get peers only via trackers")
321 (if file
.file_private
then _s "yes" else _s "no");
322 if !bt_dht
<> None
then
323 emit (_s"Last DHT announce") ~desc
:(_s"Last time this torrent was announced in DHT")
324 (string_of_date file
.file_last_dht_announce
);
325 emit (_s"Metadata downloading") (if file
.file_metadata_downloading
then _s "yes" else _s "no");
327 let rec print_first_tracker l
=
331 if not
(tracker_is_enabled t
) then
332 print_first_tracker q
334 emit (_s"Last announce") ~desc
:(_s"Last time this torrent was announced to the tracker")
335 (string_of_date t
.tracker_last_conn
);
337 if t
.tracker_last_conn
> 1 then
338 emit (_s"Next announce") ~desc
:(_s"Time of the next announce to the tracker (planned)")
339 (string_of_date
(t
.tracker_last_conn
+ t
.tracker_interval
));
341 emit (_s"Announce interval") ~desc
:(_s"Tracker announce interval")
342 (Printf.sprintf
"%d seconds" t
.tracker_interval
);
344 emit (_s"Min announce interval") ~desc
:(_s"Minimum tracker announce interval")
345 (Printf.sprintf
"%d seconds" t
.tracker_min_interval
);
347 (* show only interesting answers*)
348 if t
.tracker_torrent_downloaded
> 0 then
349 emit (_s"Downloaded") (string_of_int t
.tracker_torrent_downloaded
);
351 if t
.tracker_torrent_complete
> 0 then
352 emit (_s"Seeders") ~desc
:(_s"Peers that have complete download")
353 (string_of_int t
.tracker_torrent_complete
);
355 if t
.tracker_torrent_incomplete
> 0 then
356 emit (_s"Leechers") ~desc
:(_s"Peers that have incomplete download")
357 (string_of_int t
.tracker_torrent_incomplete
);
359 if t
.tracker_torrent_total_clients_count
> 0 then
360 emit (_s"Peers") ~desc
:(_s"Total clients count")
361 (string_of_int t
.tracker_torrent_total_clients_count
);
363 if t
.tracker_torrent_last_dl_req
> 0 then
364 emit (_s"Latest request") (Printf.sprintf
"%ds" t
.tracker_torrent_last_dl_req
);
366 if String.length t
.tracker_id
> 0 then
367 emit (_s"Tracker id") t
.tracker_id
;
369 if String.length t
.tracker_key
> 0 then
370 emit (_s"Tracker key") t
.tracker_key
;
373 print_first_tracker file
.file_trackers
;
375 (* This is bad. Magic info should be automatically filled in when
376 the corresponding chunks complete. (see CommonSwarming)
378 This code only fills in the magic info for subfiles when a user
379 manually performs a "vd #". (interfaces out of sync)
381 Magic info for shared files with subfiles is missing as well?
383 if !Autoconf.magic_works
then begin
384 let check_magic file
=
385 match Magic.M.magic_fileinfo file
false with
387 | Some s
-> Some
(intern s
)
389 let fdn = file_disk_name file
in
390 let new_file_files = ref [] in
392 List.iter
(fun (f
, s
, m
) ->
393 let subfile = Filename.concat
fdn f
in
394 new_file_files := (f
,s
, check_magic subfile) :: !new_file_files;
397 file
.file_files
<- List.rev
!new_file_files;
398 file_must_update file
; (* Send update to guis *)
404 match List.fold_left
(fun acc
subfile ->
405 match acc
, subfile with
406 | (Some
false|None
),(_
,_
,_
,_
,Some
prio) when prio > 0 -> Some
true
407 | None
,(_
,_
,_
,_
,Some
0) -> Some
false
408 | None
,(_
,_
,_
,_
,None
) -> None
409 | acc
,_
-> acc
) None
subfiles
413 Printf.sprintf
", \\<a title=\\\"toggle all files\\\" href=\\\"submit?q=set_subfile_prio+%d+%d+%d+%d\\\"\\>%s\\</a\\>"
414 (file_num file
) (if dl
then 0 else 1) 0 (List.length
subfiles - 1)
415 (if dl
then "unselect all" else "select all")
417 emit (_s"Full path"^
extra) ~desc
:(_s"Full path to the download") (file_disk_name file
);
420 List.iter
(fun (filename
, size
, magic, progress, prio) ->
421 Printf.bprintf
buf "\\</tr\\>\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr
());
422 let fs = Printf.sprintf
(_b"File %d") !cntr in
423 let extra = match prio with
425 | Some
prio -> Printf.sprintf
", \\<a title=\\\"toggle file\\\" href=\\\"javascript:void(0)\\\" onclick=\\\"xhr_get('submit?api=set_subfile_prio+%d+%d+%d',toggle_priority(this,%d,%d))\\\"\\>priority %d\\</a\\>" (file_num file
) (if prio = 0 then 1 else 0) !cntr (file_num file
) !cntr prio
427 emit (fs^
extra) ~desc
:fs (Printf.sprintf
"%s (%Ld bytes%s)%s" filename size
progress magic);
430 end (* use_html_mods *)
433 Printf.bprintf
buf "Trackers:\n";
434 List.iter
(fun tracker
->
435 let tracker_url = show_tracker_url tracker
.tracker_url in
436 match tracker
.tracker_status
with
437 | Disabled s
| Disabled_mld s
->
438 Printf.bprintf
buf "%s, disabled: %s\n" tracker_url s
439 | Disabled_failure
(i
,s
) ->
440 Printf.bprintf
buf "%s, disabled (try %d): %s\n" tracker_url i s
441 | _
-> Printf.bprintf
buf "%s\n" tracker_url
442 ) file
.file_trackers
;
443 if file
.file_torrent_diskname
<> "" then
444 Printf.bprintf
buf "Torrent diskname: %s\n" file
.file_torrent_diskname
;
445 if file
.file_comment
<> "" then Printf.bprintf
buf "Comment: %s\n" file
.file_comment
;
446 if file
.file_created_by
<> "" then Printf.bprintf
buf "Created by %s\n" file
.file_created_by
;
447 let s = Date.to_string
(Int64.to_float file
.file_creation_date
) in
448 if s <> "" then Printf.bprintf
buf "Creation date: %s\n" s;
449 if file
.file_modified_by
<> "" then Printf.bprintf
buf "Modified by %s\n" file
.file_modified_by
;
450 if file
.file_encoding
<> "" then Printf.bprintf
buf "Encoding: %s\n" file
.file_encoding
;
451 Printf.bprintf
buf (_b"Full path: %s\n") (file_disk_name file
);
452 if file
.file_files
<> [] then Printf.bprintf
buf "Subfiles: %d\n" (List.length file
.file_files
);
454 List.iter
(fun (filename
, size
, magic, progress, prio) ->
456 let prio = match prio with Some n
-> Printf.sprintf
", priority %d" n
| None
-> "" in
457 Printf.bprintf
buf "File %d%s: %s (%Ld bytes%s)%s\n" !cntr prio filename size
progress magic
461 let op_file_print_sources file o
=
462 let buf = o
.conn_buf
in
464 (* redefine functions for telnet output *)
465 let html_mods_td buf l
=
466 if use_html_mods o
then
470 List.iter
(fun (t
,c
,d
) ->
471 (* Title Class Value *)
472 Printf.bprintf
buf "%s "
476 let html_mods_table_header buf n c l
=
477 if use_html_mods o
then
478 html_mods_table_header buf n c l
480 if List.length l
> 0 then begin
481 Printf.bprintf
buf "\n";
482 List.iter
(fun (w
,x
,y
,z
) ->
483 (* Sort Class Title Value *)
484 Printf.bprintf
buf "%s "
487 Printf.bprintf
buf "\n"
491 if Hashtbl.length file
.file_clients
> 0 then begin
494 ( Num
, "srh br ac", "Client number", "Num" ) ;
495 ( Str
, "srh br", "Client UID", "UID" ) ;
496 ( Str
, "srh br", "Client software", "Soft" ) ;
497 ( Str
, "srh", "IP address", "IP address" ) ;
498 ( Num
, "srh br ar", "Port", "Port" ) ;
499 ] @ (if Geoip.active
() then [( Str
, "srh br ar", "Country Code/Name", "CC" )] else []) @ [
500 ( Num
, "srh ar", "Total UL bytes to this client for all files", "tUL" ) ;
501 ( Num
, "srh ar br", "Total DL bytes from this client for all files", "tDL" ) ;
502 ( Num
, "srh ar", "Session UL bytes to this client for all files", "sUL" ) ;
503 ( Num
, "srh ar br", "Session DL bytes from this client for all files", "sDL" ) ;
504 ( Str
, "srh ar", "Interested [T]rue, [F]alse", "I" ) ;
505 ( Str
, "srh ar", "Choked [T]rue, [F]alse", "C" ) ;
506 ( Num
, "srh br ar", "Allowed to write", "A" ) ;
507 ( Str
, "srh ar", "Interesting [T]rue, [F]alse", "I" );
508 ( Str
, "srh ar", "Already sent interested [T]rue, [F]alse", "A" );
509 ( Str
, "srh br ar", "Already sent not interested [T]rue, [F]alse", "N" );
511 ( Str
, "srh ar", "Good [T]rue, [F]alse", "G" );
512 ( Str
, "srh ar", "Incoming [T]rue, [F]alse", "I" );
513 ( Str
, "srh br ar", "Registered bitfield [T]rue, [F]alse", "B" );
515 ( Num
, "srh ar", "Connection Time", "T" );
516 ( Str
, "srh ar", "Last optimistic unchoke", "L.Opt" );
517 ( Num
, "srh br ar", "Number of tries", "N" );
519 ( Str
, "srh", "DHT [T]rue, [F]alse", "D" );
520 ( Str
, "srh", "Cache extensions [T]rue, [F]alse", "C" );
521 ( Str
, "srh", "Fast extensions [T]rue, [F]alse", "F" );
522 ( Str
, "srh", "uTorrent extensions [T]rue, [F]alse", "U" );
523 ( Str
, "srh br", "Azureus messaging protocol [T]rue, [F]alse", "A" );
525 ( Str, "srh", "Bitmap (absent|partial|present|verified)", (colored_chunks
526 (Array.init (String.length info.G.file_chunks)
527 (fun i -> ((int_of_char info.G.file_chunks.[i])-48)))) ) ;
529 ( Num
, "srh ar", "Number of full chunks", (Printf.sprintf
"%d"
530 (match file
.file_swarmer
with
534 CommonSwarming.chunks_verified_bitmap swarmer
in
535 VB.fold_lefti
(fun acc _
s ->
536 if s = VB.State_verified
then acc
+ 1 else acc
) 0 bitmap)))
539 html_mods_table_header buf "sourcesTable" "sources al" header_list;
541 Hashtbl.iter
(fun _ c
->
542 let cinfo = client_info
(as_client c
) in
543 if use_html_mods o
then
544 Printf.bprintf
buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr
());
546 let btos b
= if b
then "T" else "F" in
547 let cc,cn
= Geoip.get_country_code_name
cinfo.GuiTypes.client_country_code
in
549 ("", "sr br ar", Printf.sprintf
"%d" (client_num c
));
550 ("", "sr br", (Sha1.to_string c
.client_uid
));
551 ("", "sr br", Printf.sprintf
"%s %s" (brand_to_string c
.client_brand
) c
.client_release
);
552 ("", "sr", (Ip.to_string
(fst c
.client_host
)));
553 ("", "sr br ar", Printf.sprintf
"%d" (snd c
.client_host
));
554 ] @ (if Geoip.active
() then
555 [( cn
, "sr br", if use_html_mods o
then CommonPictures.flag_html
cc else cc)]
557 ("", "sr ar", (size_of_int64 c
.client_total_uploaded
));
558 ("", "sr ar br", (size_of_int64 c
.client_total_downloaded
));
559 ("", "sr ar", (size_of_int64 c
.client_session_uploaded
));
560 ("", "sr ar br", (size_of_int64 c
.client_session_downloaded
));
561 ("", "sr", (btos c
.client_interested
));
562 ("", "sr", (btos c
.client_choked
));
563 ("", "sr br ar", (Int64.to_string c
.client_allowed_to_write
));
564 (* This is way too slow for 1000's of chunks on a page with 100's of sources
565 ("", "sr", (CommonFile.colored_chunks (Array.init (String.length c.client_bitmap)
566 (fun i -> (if c.client_bitmap.[i] = '1' then 2 else 0)) )) );
568 ("", "sr", (btos c
.client_interesting
));
569 ("", "sr", (btos c
.client_alrd_sent_interested
));
570 ("", "br sr", (btos c
.client_alrd_sent_notinterested
));
572 ("", "sr", (btos c
.client_good
));
573 ("", "sr", (btos c
.client_incoming
));
574 ("", "br sr", (btos c
.client_registered_bitfield
));
576 ("", "sr", Printf.sprintf
"%d" ((last_time
() - c
.client_connect_time
) / 60));
577 ("", "ar sr", string_of_date c
.client_last_optimist
);
578 ("", "br sr", Printf.sprintf
"%d" c
.client_num_try
);
580 ("", "sr", (btos c
.client_dht
));
581 ("", "sr", (btos c
.client_cache_extension
));
582 ("", "sr", (btos c
.client_fast_extension
));
583 ("", "sr", (btos c
.client_utorrent_extension
));
584 ("", "br sr", (btos c
.client_azureus_messaging_protocol
));
586 ("", "sr ar", (let fc = ref 0 in
587 (match c
.client_bitmap
with
590 Bitv.iter
(fun s -> if s then incr
fc) bitmap);
591 (Printf.sprintf
"%d" !fc) ) )
594 html_mods_td buf td_list;
595 if use_html_mods o
then Printf.bprintf
buf "\\</tr\\>"
596 else Printf.bprintf
buf "\n";
600 if use_html_mods o
then Printf.bprintf
buf "\\</table\\>\\</div\\>\\<br\\>"
601 else Printf.bprintf
buf "\n";
605 let op_file_check file
=
606 lprintf_file_nl
(as_file file
) "Checking chunks of %s" file
.file_name
;
607 match file
.file_swarmer
with
609 lprintf_file_nl
(as_file file
) "verify_chunks: no swarmer to verify chunks"
611 CommonSwarming.verify_all_chunks_immediately swarmer
613 let remove_all_clients file
=
614 Hashtbl.clear file
.file_clients
;
615 file
.file_clients_num
<- 0
617 let op_file_cancel file
=
618 CommonSwarming.remove_swarmer file
.file_swarmer
;
619 file
.file_swarmer
<- None
;
620 BTClients.file_stop file
;
622 BTClients.disconnect_clients file
;
623 remove_all_clients file
;
624 if Sys.file_exists file
.file_torrent_diskname
then Sys.remove file
.file_torrent_diskname
626 let op_ft_cancel ft
=
627 Hashtbl.remove ft_by_num ft
.ft_id
629 let op_ft_commit ft newname
=
630 Hashtbl.remove ft_by_num ft
.ft_id
632 let op_file_info file
=
634 let module P
= GuiTypes
in
636 let last_seen = match file
.file_swarmer
with
637 None
-> [| last_time
() |]
638 | Some swarmer
-> CommonSwarming.compute_last_seen swarmer
in
640 { (impl_file_info file
.file_file
) with
642 P.file_name
= file
.file_name
;
643 P.file_network
= network
.network_num
;
644 P.file_chunks
= (match file
.file_swarmer
with
646 | Some swarmer
-> Some
(CommonSwarming.chunks_verified_bitmap swarmer
));
647 P.file_chunk_size
= (match file
.file_swarmer
with
649 | Some t
-> Some
(List.map
(fun t
-> t
.CommonSwarming.t_chunk_size
) t
.CommonSwarming.t_s
.CommonSwarming.s_networks
));
650 P.file_availability
=
651 [network
.network_num
,(match file
.file_swarmer
with
652 None
-> "" | Some swarmer
->
653 CommonSwarming.chunks_availability swarmer
)];
655 P.file_chunks_age
= last_seen;
656 P.file_uids
= [Uid.create
(BTUrl file
.file_id
)];
657 P.file_sub_files
= file
.file_files
;
658 P.file_active_sources
= List.length
(op_file_active_sources file
);
659 P.file_all_sources
= (Hashtbl.length file
.file_clients
);
660 P.file_comment
= file
.file_comment
;
665 let module P
= GuiTypes
in
668 P.file_fields
= P.Fields_file_info.all
;
670 P.file_comment
= file_comment
(as_ft ft
);
671 P.file_name
= ft
.ft_filename
;
672 P.file_num
= ft_num ft
;
673 P.file_network
= network
.network_num
;
674 P.file_names
= [ft
.ft_filename
];
675 P.file_md4
= Md4.null
;
676 P.file_size
= ft_size ft
;
677 P.file_downloaded
= zero
;
678 P.file_all_sources
= 0;
679 P.file_active_sources
= 0;
680 P.file_state
= ft_state ft
;
681 P.file_sources
= None
;
682 P.file_download_rate
= 0.;
683 P.file_chunks
= None
;
684 P.file_chunk_size
= None
;
685 P.file_availability
= [network
.network_num
, ""];
686 P.file_format
= FormatNotComputed
0;
687 P.file_chunks_age
= [| last_time
() |];
689 P.file_last_seen
= BasicSocket.last_time
();
692 P.file_sub_files
= [];
694 P.file_comments
= [];
697 P.file_release
= file_release
(as_ft ft
);
702 let load_torrent_string s user group
=
703 if !verbose
then lprintf_nl
"load_torrent_string";
704 let file_id, torrent
= BTTorrent.decode_torrent
s in
706 (* Save the torrent, because we later want to put
707 it in the seeded directory. *)
708 let torrent_diskname = CommonFile.concat_file downloads_directory
(torrent
.torrent_name ^
".torrent") in
709 if Sys.file_exists
torrent_diskname then
711 if !verbose
then lprintf_nl
"load_torrent_string: %s already exists, ignoring" torrent_diskname;
712 raise
(Torrent_already_exists torrent
.torrent_name
)
714 File.from_string
torrent_diskname s;
717 lprintf_nl
"Starting torrent download with diskname: %s"
719 let file = new_download
file_id torrent
torrent_diskname user group
in
720 BTClients.talk_to_tracker
file true;
721 CommonInteractive.start_download
(file_find
(file_num
file));
724 let load_torrent_file filename user group
=
726 lprintf_nl
"load_torrent_file %s" filename
;
727 let s = File.to_string filename
in
728 (* Delete the torrent if it is in the downloads dir. because it gets saved
729 again under the torrent name and we don't want to clutter up this dir. .*)
730 if Sys.file_exists filename
731 && (Filename.dirname filename
) = downloads_directory
then
733 ignore
(load_torrent_string s user group
)
736 let parse_tracker_reply file t filename =
737 (*This is the function which will be called by the http client
738 for parsing the response*)
739 (* Interested only in interval*)
740 if !verbose_msg_servers
then lprintf_file_nl
(as_file
file) "Filename %s" filename
;
743 File.to_string filename
744 with e
-> lprintf_file_nl
(as_file
file) "Empty reply from tracker"; ""
747 match tracker_reply with
749 if !verbose_connect
then
750 lprintf_file_nl
(as_file
file) "Empty reply from tracker";
752 | _
-> Bencode.decode
tracker_reply
754 if !verbose_msg_servers
then lprintf_file_nl
(as_file
file) "Received: %s" (Bencode.print
v);
755 t
.tracker_interval
<- 600;
758 List.iter
(fun (key
,value) ->
759 match (key
, value) with
760 String
"interval", Int n
->
761 t
.tracker_interval
<- Int64.to_int n
;
762 if !verbose_msg_servers
then lprintf_file_nl
(as_file
file) ".. interval %d .." t
.tracker_interval
763 | String
"failure reason", String failure
->
764 lprintf_file_nl
(as_file
file) "Failure from Tracker in file: %s Reason: %s" file.file_name failure
765 (*TODO: merge with f from get_sources_from_tracker and parse the rest of the answer, too.
766 also connect to the sources we receive or instruct tracker to send none, perhaps based
767 on an config option. firewalled people could activate the option and then seed torrents, too.*)
773 let try_share_file torrent_diskname =
774 if !verbose_share
then lprintf_nl
"try_share_file: %s" torrent_diskname;
775 let s = File.to_string
torrent_diskname in
776 let file_id, torrent
= BTTorrent.decode_torrent
s in
782 [] -> raise Not_found
784 let s = sharing_strategy sh
.shdir_strategy
in
785 if match torrent
.torrent_files
with
786 [] -> not
s.sharing_directories
787 | _
-> s.sharing_directories
then
789 Filename.concat sh
.shdir_dirname torrent
.torrent_name
791 if !verbose_share
then lprintf_nl
"Checking for %s" filename;
792 if Sys.file_exists
filename then filename else
797 iter (shared_directories_including_user_commit
())
800 let user = CommonUserDb.admin_user
() in
801 let file = new_file
file_id torrent
torrent_diskname
802 filename FileShared
user user.user_default_group
in
804 if !verbose_share
then
805 lprintf_file_nl
(as_file
file) "Sharing file %s" filename;
806 BTClients.talk_to_tracker
file false;
810 (* if the torrent is still there while the file is gone, remove the torrent *)
811 if !verbose_share
then lprintf_nl
"Removing torrent for %s" s;
812 let new_torrent_diskname =
813 Filename.concat old_directory
814 (Filename.basename
torrent_diskname)
817 Unix2.rename
torrent_diskname new_torrent_diskname;
818 `Ok
new_torrent_diskname
820 let msg = Printf.sprintf
"Failed to rename %S to %S" torrent_diskname new_torrent_diskname in
825 let msg = Printf.sprintf
"Cannot share %S - exn %s" torrent_diskname (Printexc2.to_string e
) in
829 (* Call one minute after start, and then every 20 minutes. Should
830 automatically contact the tracker. *)
832 if !verbose_share
then lprintf_nl
"share_files";
833 List.iter (fun file ->
834 ignore
(try_share_file (Filename.concat seeded_directory
file))
835 ) (Unix2.list_directory seeded_directory
);
836 let shared_files_copy = !current_files
in
837 (* if the torrent is gone while the file is still shared, remove the share *)
838 List.iter (fun file ->
839 (* if !verbose_share then lprintf_nl "Checking torrent share for %s" file.file_torrent_diskname; *)
840 if not
(Sys.file_exists
file.file_torrent_diskname
) &&
841 file_state
file = FileShared
&&
842 not
(file.file_metadata_downloading
) then
844 if !verbose_share
then lprintf_nl
"Removing torrent share for %s" file.file_torrent_diskname
;
845 BTClients.file_stop
file;
847 BTClients.disconnect_clients
file;
848 remove_all_clients file;
852 (** talk_to_tracker maintains timers and will connect to trackers only when allowed by rules *)
853 let announce_shared_files () =
854 List.iter (fun file -> if file_state
file = FileShared
then BTClients.talk_to_tracker
file false) !current_files
856 let scan_new_torrents_directory () =
857 let filenames = Unix2.list_directory new_torrents_directory
in
858 List.iter (fun file ->
859 let file = Filename.concat new_torrents_directory
file in
860 let file_basename = Filename.basename
file in
861 if not
(Unix2.is_directory
file) then
863 let file_owner = fst
(Unix32.owner
file) in
866 CommonUserDb.user2_user_find
file_owner
867 with Not_found
-> CommonUserDb.admin_user
()
869 load_torrent_file file user user.user_default_group
;
870 (try Sys.remove
file with _
-> ())
873 Unix2.rename
file (Filename.concat old_directory
file_basename);
874 lprintf_nl
"Error %s in scan_new_torrents_directory for %s, moved to torrents/old ..."
875 (Printexc2.to_string e
) file_basename
878 let retry_all_ft () =
879 Hashtbl.iter (fun _ ft
->
880 try ft
.ft_retry ft
with e
->
881 lprintf_nl
"ft_retry: exception %s" (Printexc2.to_string e
)
884 let load_torrent_from_web r user group ft
=
885 let module H
= Http_client
in
886 H.wget
r (fun filename ->
887 if ft_state ft
= FileDownloading
then begin
888 load_torrent_file filename user group
;
889 file_cancel
(as_ft ft
) (CommonUserDb.admin_user
())
892 let valid_torrent_extension url
=
893 let ext = String.lowercase
(Filename2.last_extension url
) in
894 ext = ".torrent" || ext = ".tor"
896 let get_regexp_string text r =
897 ignore
(Str.search_forward
r text 0);
898 let a = Str.group_beginning
1 in
899 let b = Str.group_end
1 in
900 String.sub
text a (b - a)
902 let op_network_parse_url url
user group
=
903 let exn_catch f x
= try `Ok
(f x
) with exn
-> `Exn exn
in
904 match exn_catch parse_magnet_url url
with
907 if !verbose
then begin
908 lprintf_nl
"Got magnet url %S" url
;
909 List.iter (fun(v) -> lprintf_nl
"magnet %s" (string_of_uid
v)) magnet#uids
;
910 List.iter (fun(v) -> lprintf_nl
"magnet trackers %s" v) magnet#trackers
;
912 match List2.filter_map
(function BTUrl btih
-> Some btih
| _
-> None
) magnet#uids
with
913 | [] -> "No btih found in magnet url", false;
916 lprintf_nl
"Got btih %S" (Sha1.to_string btih
);
917 let hashstr = (Sha1.to_string btih
) in
919 torrent_name
= hashstr; (*magnet#name*)
920 torrent_filename
= hashstr;
921 torrent_name_utf8
= hashstr;
922 torrent_comment
= "";
923 torrent_pieces
= Array.of_list
[];
924 torrent_piece_size
= 1L;
927 torrent_created_by
= "";
928 torrent_creation_date
= 1000000L;
929 torrent_modified_by
= "";
930 torrent_encoding
= "";
931 torrent_private
= false;
933 (match magnet#trackers
with
936 torrent_announce_list
= magnet#trackers
;
938 ignore
(new_download ~metadata
:true btih
torrent "" user group
);
943 let location_regexp = "Location: \\(.*\\)" in
945 let real_url = get_regexp_string url
(Str.regexp
location_regexp) in
946 if (valid_torrent_extension real_url)
947 || (String2.contains url
"Content-Type: application/x-bittorrent")
949 let u = Url.of_string
real_url in
950 let module H
= Http_client
in
954 H.req_proxy
= !CommonOptions.http_proxy
;
955 H.req_user_agent
= get_user_agent
();
957 let (rule_search
,rule_value
) =
958 try (List.find
(fun (rule_search
,rule_value
) ->
959 Str.string_match
(Str.regexp rule_search
) real_url 0
961 with Not_found
-> ("",real_url) in
962 Some
(Url.of_string rule_value
) );
964 let cookies = List.assoc
u.Url.server
!!cookies in
965 [ ( "Cookie", List.fold_left
(fun res
(key
, value) ->
969 res ^
"; " ^ key ^
"=" ^
value
972 with Not_found
-> []);
973 H.req_max_retry
= 10;
976 let file_diskname = Filename.basename
u.Url.short_file
in
977 let ft = new_ft
file_diskname user in
978 ft.ft_retry
<- (load_torrent_from_web r user group
);
979 load_torrent_from_web r user group
ft;
980 "started download", true
986 if (valid_torrent_extension url
) then
988 if !verbose
then lprintf_nl
"Not_found and trying to load %s" url
;
990 load_torrent_file url
user group
;
993 Torrent_already_exists _
-> "A torrent with this name is already in the download queue", false
995 lprintf_nl
"Exception %s while 2nd loading" (Printexc2.to_string e
);
996 let s = Printf.sprintf
"Can not load load torrent file: %s"
997 (Printexc2.to_string e
) in
1001 if !verbose
then lprintf_nl
"Not_found and url has non valid torrent extension: %s" url
;
1002 "Not_found and url has non valid torrent extension", false
1005 lprintf_nl
"Exception %s while loading" (Printexc2.to_string e
);
1006 let s = Printf.sprintf
"Can not load load torrent file: %s"
1007 (Printexc2.to_string e
) in
1011 let op_client_info c
=
1012 check_client_country_code c
;
1013 let module P
= GuiTypes
in
1014 let (ip
,port
) = c
.client_host
in
1015 { (impl_client_info c
.client_client
) with
1017 P.client_network
= network
.network_num
;
1018 P.client_kind
= Known_location
(ip
,port
);
1019 P.client_country_code
= c
.client_country_code
;
1020 P.client_state
= client_state
(as_client c
);
1021 P.client_type
= client_type c
;
1022 P.client_name
= (Printf.sprintf
"%s:%d" (Ip.to_string ip
) port
);
1023 P.client_software
= (brand_to_string c
.client_brand
);
1024 P.client_release
= c
.client_release
;
1025 P.client_total_downloaded
= c
.client_total_downloaded
;
1026 P.client_total_uploaded
= c
.client_total_uploaded
;
1027 P.client_session_downloaded
= c
.client_session_downloaded
;
1028 P.client_session_uploaded
= c
.client_session_uploaded
;
1029 P.client_upload
= Some
(c
.client_file
.file_name
);
1030 P.client_connect_time
= c
.client_connect_time
;
1034 let op_client_connect c
=
1035 BTClients.connect_client c
1037 let op_client_disconnect c
=
1038 BTClients.disconnect_client c Closed_by_user
1040 let op_client_bprint c
buf =
1041 let cc = as_client c
in
1042 let cinfo = client_info
cc in
1043 Printf.bprintf
buf "%s (%s)\n"
1044 cinfo.GuiTypes.client_name
1045 (Sha1.to_string c
.client_uid
)
1047 let op_client_dprint c o
file =
1048 let info = file_info
file in
1049 let buf = o
.conn_buf
in
1050 let cc = as_client c
in
1052 Printf.bprintf
buf (_b "\n%18sDown : %-10s Uploaded: %-10s Ratio: %s%1.1f (%s)\n") ""
1053 (Int64.to_string c
.client_total_downloaded
)
1054 (Int64.to_string c
.client_total_uploaded
)
1055 (if c
.client_total_downloaded
> c
.client_total_uploaded
then "-" else "+")
1056 (if c
.client_total_uploaded
> Int64.zero
then
1057 Int64.to_float
(c
.client_total_downloaded
// c
.client_total_uploaded
)
1060 (Printf.bprintf
buf (_b "%18sFile : %s\n") "" info.GuiTypes.file_name
)
1062 let op_client_dprint_html c o
file str
=
1063 let info = file_info
file in
1064 let buf = o
.conn_buf
in
1065 let ac = as_client c
in
1066 let cinfo = client_info
ac in
1067 Printf.bprintf
buf " \\<tr onMouseOver=\\\"mOvr(this);\\\"
1068 onMouseOut=\\\"mOut(this);\\\" class=\\\"%s\\\"\\>" str
;
1070 let show_emulemods_column = ref false in
1071 if Autoconf.donkey
= "yes" then begin
1072 if !!emule_mods_count
then
1073 show_emulemods_column := true
1076 let cc,cn
= Geoip.get_country_code_name
cinfo.GuiTypes.client_country_code
in
1079 ("", "srb ar", Printf.sprintf
"%d" (client_num c
));
1080 ((string_of_connection_state
(client_state
ac)), "sr",
1081 (short_string_of_connection_state
(client_state
ac)));
1082 ((Sha1.to_string c
.client_uid
), "sr", cinfo.GuiTypes.client_name
);
1083 ("", "sr", (brand_to_string c
.client_brand
)); (* cinfo.GuiTypes.client_software *)
1084 ("", "sr", c
.client_release
);
1086 (if !show_emulemods_column then [("", "sr", "")] else [])
1089 ("", "sr ar", Printf.sprintf
"%d"
1090 (((last_time
()) - cinfo.GuiTypes.client_connect_time
) / 60));
1093 ("", "sr", (Ip.to_string
(fst c
.client_host
)));
1094 ] @ (if Geoip.active
() then [(cn
, "sr", CommonPictures.flag_html
cc)] else []) @ [
1095 ("", "sr ar", (size_of_int64 c
.client_total_uploaded
));
1096 ("", "sr ar", (size_of_int64 c
.client_total_downloaded
));
1097 ("", "sr ar", (size_of_int64 c
.client_session_uploaded
));
1098 ("", "sr ar", (size_of_int64 c
.client_session_downloaded
));
1099 ("", "sr", info.GuiTypes.file_name
); ]);
1102 let op_network_connected _
= true
1104 let compute_torrent filename announce comment
=
1105 let announce = if announce = "" then BTTracker.get_default_tracker
() else announce in
1106 if !verbose
then lprintf_nl
"compute_torrent: [%s] [%s] [%s]"
1107 filename announce comment
;
1108 let basename = Printf.sprintf
"%s.torrent" (Filename.basename filename) in
1109 let torrent = Filename.concat seeded_directory
basename in
1110 let is_private = false in
1111 let file_id = BTTorrent.generate_torrent
announce torrent comment
is_private filename in
1112 match try_share_file torrent with
1113 | `Err
msg -> failwith
msg
1114 | `Ok torrent_path
->
1115 Filename.concat
(Sys.getcwd
()) torrent_path
,
1116 try `Ok
(BTTracker.track_torrent
basename file_id) with exn
-> `Err
(Printexc2.to_string exn
)
1118 (* let text fmt = Printf.ksprintf (fun s -> `Text s) fmt *)
1120 OCaml 3.08.3 compatibility (ksprintf not available)
1121 http://mldonkey.sourceforge.net/phpBB2/viewtopic.php?p=30453
1123 let text s = `Text
s
1124 let link name url
= `Link
(name
,url
)
1126 let output buf typ elements
=
1127 let f = match typ
with
1128 | HTML
| XHTML
| XML
->
1130 | `Text
s -> Xml.buffer_escape
buf s
1131 | `Link
(name
,url
) ->
1132 Printf.bprintf
buf "<a href=\"%s\">%s</a>"
1133 (Xml.escape url
) (Xml.escape
(match name
with "" -> url
| s -> s))
1134 | `Break
-> Buffer.add_string
buf "<br/>"
1138 | `Text
s -> Buffer.add_string
buf s
1139 | `Link
("",url
) -> Printf.bprintf
buf "%s" url
1140 | `Link
(name
,url
) -> Printf.bprintf
buf "%s <%s>" name url
1141 | `Break
-> Buffer.add_string
buf "\n"
1144 List.iter f elements
1148 match o
.conn_output
with
1149 | ANSI
| TEXT
-> output o
.conn_buf o
.conn_output l
1150 | HTML
| XHTML
| XML
->
1151 let buf = Buffer.create
1024 in
1152 output buf o
.conn_output l
;
1153 let s = Buffer.contents
buf in
1154 for i
= 0 to String.length
s - 1 do
1155 begin match s.[i
] with
1156 | '
<'
| '
>'
| '
\\'
| '
"' | '&' -> Buffer.add_char o.conn_buf '\\'
1158 Buffer.add_char o.conn_buf s.[i]
1164 "compute_torrent", "Network
/Bittorrent
", Arg_multiple (fun args o ->
1167 let filename = ref "" in
1168 let comment = ref "" in
1170 fname :: [comm] -> filename := fname; comment := comm
1171 | [fname] -> filename := fname
1172 | _ -> raise Not_found);
1174 let (path,url) = compute_torrent !filename "" !comment in
1176 text (Printf.sprintf "Torrent
file generated
: %s
" path);
1179 | `Ok url -> link "Download
" url
1180 | `Err s -> text (Printf.sprintf "Not tracked
: %s
" s));
1184 | Not_found -> [text "Not enough parameters
"; `Break]
1185 | exn -> [text (Printf.sprintf "Error
: %s
" (Printexc2.to_string exn)); `Break]
1188 ), _s "<filename> [<comment>] :\tgenerate the corresponding
<filename> .torrent file with <comment>.\n\t\t\t\t\t\tThe
file is automatically tracked
if tracker is enabled
and seeded
if located
in incoming
/";
1190 "torrents
", "Network
/Bittorrent
", Arg_none (fun o ->
1193 BTTracker.check_tracker ();
1194 let files_tracked = Unix2.list_directory tracked_directory in
1195 let files_downloading = Unix2.list_directory downloads_directory in
1196 let files_seeded = Unix2.list_directory seeded_directory in
1197 let files_old = Unix2.list_directory old_directory in
1198 let all_torrents_files = files_tracked @ files_downloading @ files_seeded @ files_old in
1200 let l = List.map (fun file -> [link file (BTTracker.tracker_url file); `Break]) all_torrents_files in
1202 (`Text (_s ".torrent files available
:")) :: `Break :: List.flatten l
1205 [`Text (Printexc2.to_string exn); `Break]
1208 ), _s ":\t\t\t\tprint all
.torrent files on this server
";
1210 "print_torrent
", "Network
/Bittorrent
", Arg_one (fun arg o ->
1211 if CommonUserDb.user2_is_admin o.conn_user.ui_user then begin
1214 Some (as_file_impl (file_find (int_of_string arg)))
1218 | None -> Printf.sprintf "file %s not found
" arg
1221 if use_html_mods o then begin
1222 html_mods_cntr_init ();
1223 html_mods_table_header o.conn_buf "sourcesInfo
" "sourcesInfo
" [
1224 ( Str, "srh br
", "File Info
", "Info
" ) ;
1225 ( Str, "srh
", "Value
", "Value
" ) ]
1227 op_file_print file.impl_file_val o;
1228 if use_html_mods o then begin
1229 Printf.bprintf o.conn_buf "\\</tr
\\>\\</table
\\>\\</div
\\>";
1230 Printf.bprintf o.conn_buf "\\</td
\\>\\</tr
\\>\\</table
\\>\\</div
\\>\\<br
\\>"
1235 begin print_command_result o "You are not allowed
to use print_torrent
";
1237 ), _s "<num
> :\t\t\tshow internal data
of .torrent file";
1239 "seeded_torrents
", "Network
/Bittorrent
", Arg_none (fun o ->
1240 if CommonUserDb.user2_is_admin o.conn_user.ui_user then begin
1241 List.iter (fun file ->
1242 if file_state file = FileShared then
1243 Printf.bprintf o.conn_buf "%s
[U %Ld
u/d %Ld
/%Ld
]\n"
1244 file.file_name file.file_uploaded file.file_session_uploaded file.file_session_downloaded
1248 begin print_command_result o "You are not allowed
to use seeded_torrents
";
1250 ), _s ":\t\t\tprint all seeded
.torrent files on this server
(output: name
, total upload
, session upload
, session download
)";
1252 "reshare_torrents
", "Network
/Bittorrent
", Arg_none (fun o ->
1255 ), _s ":\t\t\trecheck torrents
/* directories
for changes
";
1257 "rm_old_torrents
", "Network
/Bittorrent
", Arg_none (fun o ->
1258 let files_outdated = Unix2.list_directory old_directory in
1259 let buf = o.conn_buf in
1260 if o.conn_output = HTML then begin
1261 (* TODO: really htmlize it *)
1262 Printf.bprintf buf "Removing old torrents
...";
1263 List.iter (fun file ->
1264 Printf.bprintf buf "%s
"
1269 Printf.bprintf buf "Removing old torrents
...\n";
1270 List.iter (fun file ->
1271 Printf.bprintf buf "%s
\n"
1275 List.iter (fun file ->
1276 Sys.remove (Filename.concat old_directory file)
1279 ), _s ":\t\t\tremove all old
.torrent files
";
1281 "startbt
", "Network
/Bittorrent
", Arg_one (fun url o ->
1282 let buf = o.conn_buf in
1283 if Sys.file_exists url then
1285 load_torrent_file url o.conn_user.ui_user o.conn_user.ui_user.user_default_group;
1286 Printf.bprintf buf "loaded
file %s
\n" url
1290 let url = "Location
: " ^ url ^ "\nContent
-Type
: application
/x
-bittorrent
" in
1291 let result = fst (op_network_parse_url url o.conn_user.ui_user o.conn_user.ui_user.user_default_group) in
1292 Printf.bprintf buf "%s
\n" result
1295 ), "<url|file> :\t\t\tstart BT download
";
1297 "stop_all_bt
", "Network
/Bittorrent
", Arg_none (fun o ->
1298 List.iter (fun file -> BTClients.file_stop file ) !current_files;
1299 let buf = o.conn_buf in
1300 if o.conn_output = HTML then
1301 (* TODO: really htmlize it *)
1302 Printf.bprintf buf "started sending stops
..."
1304 Printf.bprintf buf "started sending stops
...\n";
1306 ), _s ":\t\t\t\tstops all bittorrent downloads
, use this
if you want
to make sure that the
stop signal actually
\n\t\t\t\t\tgets
to the tracker
when shutting mlnet down
, but you have
to wait till the stops get
to the
\n\t\t\t\t\ttracker
and not wait too long
, so mldonkey reconnects
to the tracker
:)";
1308 "tracker
", "Network
/Bittorrent
", Arg_multiple (fun args o ->
1311 let urls = ref [] in
1313 | nums :: [] -> raise Not_found
1314 | nums :: rest -> num := nums; urls := rest
1315 | _ -> raise Not_found);
1317 let num = int_of_string !num in
1318 Hashtbl.iter (fun _ file ->
1319 if file_num file = num then begin
1321 lprintf_file_nl (as_file file) "adding trackers
for file %i
" num;
1322 set_trackers file !urls;
1326 let buf = o.conn_buf in
1327 if o.conn_output = HTML then
1328 html_mods_table_one_row buf "serversTable
" "servers
" [
1329 ("", "srh
", "file not found
"); ]
1331 Printf.bprintf buf "file not found
";
1335 let buf = o.conn_buf in
1336 if o.conn_output = HTML then
1337 html_mods_table_one_row buf "serversTable
" "servers
" [
1338 ("", "srh
", "tracker added
"); ]
1340 Printf.bprintf buf "tracker added
";
1344 lprintf_nl "Not enough
or wrong parameters
.";
1345 let buf = o.conn_buf in
1346 if o.conn_output = HTML then
1347 html_mods_table_one_row buf "serversTable
" "servers
" [
1348 ("", "srh
", "Not enough
or wrong parameters
."); ]
1350 Printf.bprintf buf "Not enough
or wrong parameters
.";
1352 ), "<num> <url> <url>... :\t\tadd URLs
as trackers
for num";
1354 (* TODO : add some code from make_torrent
1355 "print_torrent
", Arg_one (fun filename o ->
1357 ".torrent file printed
"
1358 ), "<filename.torrent> :\t\tprint the content
of filename"
1366 let op_gui_message s user =
1367 match get_int16 s 0 with
1369 let text = String.sub s 2 (String.length s - 2) in
1370 if !verbose then lprintf_nl "received
torrent from gui
...";
1372 let file = load_torrent_string text user user.user_default_group in
1373 raise (Torrent_started file.file_name)
1374 with e -> (match e with
1375 | Torrent_already_exists s -> lprintf_nl "Loading
torrent from GUI
: torrent %s is already
in download queue
" s
1379 let n = get_int s 2 in
1380 let a, pos = get_string s 6 in
1381 let c, pos = get_string s pos in
1382 let sf = CommonShared.shared_find n in
1383 let f = shared_fullname sf in
1384 ignore (compute_torrent f a c)
1385 | opcode -> failwith (Printf.sprintf "[BT
] Unknown message opcode %d
" opcode)
1389 ft_ops.op_file_cancel <- op_ft_cancel;
1390 ft_ops.op_file_commit <- op_ft_commit;
1391 ft_ops.op_file_info <- op_ft_info;
1392 ft_ops.op_file_active_sources <- (fun _ -> []);
1393 ft_ops.op_file_all_sources <- (fun _ -> []);
1395 file_ops.op_file_all_sources <- op_file_all_sources;
1396 file_ops.op_file_files <- op_file_files;
1397 file_ops.op_file_active_sources <- op_file_active_sources;
1398 file_ops.op_file_debug <- op_file_debug;
1399 file_ops.op_file_commit <- op_file_commit;
1400 file_ops.op_file_print <- op_file_print;
1401 file_ops.op_file_print_sources <- op_file_print_sources;
1402 file_ops.op_file_check <- op_file_check;
1403 file_ops.op_file_cancel <- op_file_cancel;
1404 file_ops.op_file_info <- op_file_info;
1405 file_ops.op_file_save_as <- (fun file name -> ());
1406 file_ops.op_file_shared <- (fun file ->
1407 match file.file_shared with
1409 | Some sh -> Some (as_shared sh)
1411 file_ops.op_file_download_order <- (fun file strategy ->
1412 match file.file_swarmer with
1415 (match strategy with
1416 (* return current strategy *)
1417 | None -> Some (CommonSwarming.get_strategy s)
1418 | Some strategy -> CommonSwarming.set_strategy s strategy;
1419 Some (CommonSwarming.get_strategy s))
1422 network.op_network_gui_message <- op_gui_message;
1423 network.op_network_connected <- op_network_connected;
1424 network.op_network_parse_url <- op_network_parse_url;
1425 network.op_network_share <- (fun fullname codedname size -> ());
1426 network.op_network_close_search <- (fun s -> ());
1427 network.op_network_forget_search <- (fun s -> ());
1428 network.op_network_connect_servers <- (fun s -> ());
1429 network.op_network_search <- (fun ss buf -> ());
1430 network.op_network_download <- (fun r user group -> dummy_file);
1431 network.op_network_recover_temp <- (fun s -> ());
1432 let clean_exit_started = ref false in
1433 network.op_network_clean_exit <- (fun s ->
1434 if not !clean_exit_started then
1436 List.iter (fun file -> BTClients.file_stop file) !current_files;
1437 clean_exit_started := true;
1439 List.for_all (fun file -> not file.file_tracker_connected) !current_files;
1441 network.op_network_reset <- (fun _ ->
1442 List.iter (fun file -> BTClients.file_stop file) !current_files);
1443 network.op_network_ports <- (fun _ ->
1445 !!client_port, "client_port TCP
";
1446 !!BTTracker.tracker_port, "tracker_port TCP
";
1447 ] @ (match !bt_dht with None -> [] | Some dht -> [dht.BT_DHT.M.dht_port,"dht_port UDP
"]));
1448 network.op_network_porttest_result <- (fun _ -> !porttest_result);
1449 network.op_network_porttest_start <- (fun _ ->
1450 azureus_porttest_random := (Random.int 100000);
1452 Printf.sprintf "http
://www
.utorrent
.com
/testport?port
=%d
" !!client_port, interpret_utorrent_porttest;
1453 Printf.sprintf "http
://azureus
.aelitis
.com
/natcheck
.php?port
=%d
&check
=azureus_rand_%d
"
1454 !!client_port !azureus_porttest_random, interpret_azureus_porttest;
1456 perform_porttests tests
1458 network.op_network_check_upload_slots <- (fun _ -> check_bt_uploaders ());
1459 client_ops.op_client_info <- op_client_info;
1460 client_ops.op_client_connect <- op_client_connect;
1461 client_ops.op_client_disconnect <- op_client_disconnect;
1462 client_ops.op_client_bprint <- op_client_bprint;
1463 client_ops.op_client_dprint <- op_client_dprint;
1464 client_ops.op_client_dprint_html <- op_client_dprint_html;
1465 client_ops.op_client_browse <- (fun _ _ -> ());
1466 client_ops.op_client_files <- (fun _ -> []);
1467 client_ops.op_client_clear_files <- (fun _ -> ());
1469 CommonNetwork.register_commands commands;
1471 shared_ops.op_shared_state <- (fun file o ->
1472 if o.conn_output = HTML then
1473 Printf.sprintf "\\<a href
=\\\"submit?q
=print_torrent
+%d
\\\"\\>Details
\\</a\\>"
1475 else Printf.sprintf "Shared using %s
" file.file_torrent_diskname
1477 shared_ops.op_shared_unshare <- (fun file ->
1478 (if !verbose_share then lprintf_file_nl (as_file file) "unshare
file");
1479 BTGlobals.unshare_file file);
1480 shared_ops.op_shared_info <- (fun file ->
1481 let module T = GuiTypes in
1482 match file.file_shared with
1483 None -> assert false
1485 { (impl_shared_info impl) with
1486 T.shared_network = network.network_num;
1487 T.shared_filename = file_best_name (as_file file);
1488 T.shared_uids = [Uid.create (Sha1 file.file_id)];
1489 T.shared_sub_files = file.file_files;