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
"Remote service error (%d)" code
);
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 let op_file_print file o
=
214 let buf = o
.conn_buf
in
215 if use_html_mods o
then
217 let emit text ?
(desc
=text
) value =
218 Printf.bprintf
buf "\\</tr\\>\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr
());
220 (desc
, "sr br", text
);
225 emit (_s"Filename") file
.file_name
;
226 emit (_s"Hash") ~desc
:(_s"Torrent metadata hash") (Sha1.to_hexa file
.file_id
);
227 emit (_s"Torrent search") ~desc
:(_s"Search for similar torrent files") (Printf.sprintf
228 "\\<a target=\\\"_blank\\\" href=\\\"http://isohunt.com/%s\\\"\\>IsoHunt\\</a\\>" file
.file_name
);
230 let tracker_header_printed = ref false in
231 List.iter
(fun tracker
->
232 let tracker_url = show_tracker_url tracker
.tracker_url in
234 if not
!!use_trackers
then
235 Printf.sprintf
"disabled: %s" tracker_url
237 match tracker
.tracker_status
with
238 | Disabled s
| Disabled_mld s
->
239 Printf.sprintf
"\\<font color=\\\"red\\\"\\>disabled: %s\\<br\\>\\--error: %s\\</font\\>"
241 | Disabled_failure
(i
,s
) ->
242 Printf.sprintf
"\\<font color=\\\"red\\\"\\>disabled: %s\\<br\\>\\--error: %s (try %d)\\</font\\>"
245 Printf.sprintf
"enabled: %s" tracker_url
247 let text = if not
!tracker_header_printed then _s"Tracker(s)" else "" in
248 emit text tracker_text;
249 tracker_header_printed := true;
250 ) file
.file_trackers
;
252 emit (_s"Torrent filename") file
.file_torrent_diskname
;
253 emit (_s"Comment") (match file
.file_comment
with "" -> "-" | s
-> auto_links s
);
254 emit (_s"Created by") (match file
.file_created_by
with "" -> "-" | s
-> auto_links s
);
255 emit (_s"Creation date") (Date.to_string
(Int64.to_float file
.file_creation_date
));
256 emit (_s"Modified by") (match file
.file_modified_by
with "" -> "-" | s
-> auto_links s
);
257 emit (_s"Encoding") (match file
.file_encoding
with "" -> "-" | s
-> s
);
258 emit (_s"Piece size") (Int64.to_string file
.file_piece_size
);
259 emit (_s"Private") ~desc
:(_s"Private torrents get peers only via trackers")
260 (if file
.file_private
then _s "yes" else _s "no");
261 if !bt_dht
<> None
then
262 emit (_s"Last DHT announce") ~desc
:(_s"Last time this torrent was announced in DHT")
263 (string_of_date file
.file_last_dht_announce
);
265 let rec print_first_tracker l
=
269 if not
(tracker_is_enabled t
) then
270 print_first_tracker q
272 emit (_s"Last announce") ~desc
:(_s"Last time this torrent was announced to the tracker")
273 (string_of_date t
.tracker_last_conn
);
275 if t
.tracker_last_conn
> 1 then
276 emit (_s"Next announce") ~desc
:(_s"Time of the next announce to the tracker (planned)")
277 (string_of_date
(t
.tracker_last_conn
+ t
.tracker_interval
));
279 emit (_s"Announce interval") ~desc
:(_s"Tracker announce interval")
280 (Printf.sprintf
"%d seconds" t
.tracker_interval
);
282 emit (_s"Min announce interval") ~desc
:(_s"Minimum tracker announce interval")
283 (Printf.sprintf
"%d seconds" t
.tracker_min_interval
);
285 (* show only interesting answers*)
286 if t
.tracker_torrent_downloaded
> 0 then
287 emit (_s"Downloaded") (string_of_int t
.tracker_torrent_downloaded
);
289 if t
.tracker_torrent_complete
> 0 then
290 emit (_s"Seeders") ~desc
:(_s"Peers that have complete download")
291 (string_of_int t
.tracker_torrent_complete
);
293 if t
.tracker_torrent_incomplete
> 0 then
294 emit (_s"Leechers") ~desc
:(_s"Peers that have incomplete download")
295 (string_of_int t
.tracker_torrent_incomplete
);
297 if t
.tracker_torrent_total_clients_count
> 0 then
298 emit (_s"Peers") ~desc
:(_s"Total clients count")
299 (string_of_int t
.tracker_torrent_total_clients_count
);
301 if t
.tracker_torrent_last_dl_req
> 0 then
302 emit (_s"Latest request") (Printf.sprintf
"%ds" t
.tracker_torrent_last_dl_req
);
304 if String.length t
.tracker_id
> 0 then
305 emit (_s"Tracker id") t
.tracker_id
;
307 if String.length t
.tracker_key
> 0 then
308 emit (_s"Tracker key") t
.tracker_key
;
311 print_first_tracker file
.file_trackers
;
313 (* This is bad. Magic info should be automatically filled in when
314 the corresponding chunks complete. (see CommonSwarming)
316 This code only fills in the magic info for subfiles when a user
317 manually performs a "vd #". (interfaces out of sync)
319 Magic info for shared files with subfiles is missing as well?
321 if !Autoconf.magic_works
then begin
322 let check_magic file
=
323 match Magic.M.magic_fileinfo file
false with
325 | Some s
-> Some
(intern s
)
327 let fdn = file_disk_name file
in
328 let new_file_files = ref [] in
330 List.iter
(fun (f
, s
, m
) ->
331 let subfile = Filename.concat
fdn f
in
332 new_file_files := (f
,s
, check_magic subfile) :: !new_file_files;
335 file
.file_files
<- List.rev
!new_file_files;
336 file_must_update file
; (* Send update to guis *)
342 List.iter
(fun (filename
, size
, magic
) ->
343 let fs = Printf.sprintf
"File %d" !cntr in
347 | Some m
-> Printf.sprintf
" / %s" m
;
349 emit fs (Printf.sprintf
"%s (%Ld bytes)%s" filename size
magic_string);
352 end (* use_html_mods *)
355 Printf.bprintf
buf "Trackers:\n";
356 List.iter
(fun tracker
->
357 let tracker_url = show_tracker_url tracker
.tracker_url in
358 match tracker
.tracker_status
with
359 | Disabled s
| Disabled_mld s
->
360 Printf.bprintf
buf "%s, disabled: %s\n" tracker_url s
361 | Disabled_failure
(i
,s
) ->
362 Printf.bprintf
buf "%s, disabled (try %d): %s\n" tracker_url i s
363 | _
-> Printf.bprintf
buf "%s\n" tracker_url
364 ) file
.file_trackers
;
365 if file
.file_torrent_diskname
<> "" then
366 Printf.bprintf
buf "Torrent diskname: %s\n" file
.file_torrent_diskname
;
367 if file
.file_comment
<> "" then Printf.bprintf
buf "Comment: %s\n" file
.file_comment
;
368 if file
.file_created_by
<> "" then Printf.bprintf
buf "Created by %s\n" file
.file_created_by
;
369 let s = Date.to_string
(Int64.to_float file
.file_creation_date
) in
370 if s <> "" then Printf.bprintf
buf "Creation date: %s\n" s;
371 if file
.file_modified_by
<> "" then Printf.bprintf
buf "Modified by %s\n" file
.file_modified_by
;
372 if file
.file_encoding
<> "" then Printf.bprintf
buf "Encoding: %s\n" file
.file_encoding
;
373 if file
.file_files
<> [] then Printf.bprintf
buf "Subfiles: %d\n" (List.length file
.file_files
);
375 List.iter
(fun (filename
, size
, magic
) ->
380 | Some m
-> Printf.sprintf
" / %s" m
;
382 Printf.bprintf
buf "File %d: %s (%Ld bytes)%s\n" !cntr filename size
magic_string
386 let op_file_print_sources file o
=
387 let buf = o
.conn_buf
in
389 (* redefine functions for telnet output *)
390 let html_mods_td buf l
=
391 if use_html_mods o
then
395 List.iter
(fun (t
,c
,d
) ->
396 (* Title Class Value *)
397 Printf.bprintf
buf "%s "
401 let html_mods_table_header buf n c l
=
402 if use_html_mods o
then
403 html_mods_table_header buf n c l
405 if List.length l
> 0 then begin
406 Printf.bprintf
buf "\n";
407 List.iter
(fun (w
,x
,y
,z
) ->
408 (* Sort Class Title Value *)
409 Printf.bprintf
buf "%s "
412 Printf.bprintf
buf "\n"
416 if Hashtbl.length file
.file_clients
> 0 then begin
419 ( Num
, "srh br ac", "Client number", "Num" ) ;
420 ( Str
, "srh br", "Client UID", "UID" ) ;
421 ( Str
, "srh br", "Client software", "Soft" ) ;
422 ( Str
, "srh", "IP address", "IP address" ) ;
423 ( Num
, "srh br ar", "Port", "Port" ) ;
424 ] @ (if Geoip.active
() then [( Str
, "srh br ar", "Country Code/Name", "CC" )] else []) @ [
425 ( Num
, "srh ar", "Total UL bytes to this client for all files", "tUL" ) ;
426 ( Num
, "srh ar br", "Total DL bytes from this client for all files", "tDL" ) ;
427 ( Num
, "srh ar", "Session UL bytes to this client for all files", "sUL" ) ;
428 ( Num
, "srh ar br", "Session DL bytes from this client for all files", "sDL" ) ;
429 ( Str
, "srh ar", "Interested [T]rue, [F]alse", "I" ) ;
430 ( Str
, "srh ar", "Choked [T]rue, [F]alse", "C" ) ;
431 ( Num
, "srh br ar", "Allowed to write", "A" ) ;
432 ( Str
, "srh ar", "Interesting [T]rue, [F]alse", "I" );
433 ( Str
, "srh ar", "Already sent interested [T]rue, [F]alse", "A" );
434 ( Str
, "srh br ar", "Already sent not interested [T]rue, [F]alse", "N" );
436 ( Str
, "srh ar", "Good [T]rue, [F]alse", "G" );
437 ( Str
, "srh ar", "Incoming [T]rue, [F]alse", "I" );
438 ( Str
, "srh br ar", "Registered bitfield [T]rue, [F]alse", "B" );
440 ( Num
, "srh ar", "Connection Time", "T" );
441 ( Str
, "srh ar", "Last optimistic unchoke", "L.Opt" );
442 ( Num
, "srh br ar", "Number of tries", "N" );
444 ( Str
, "srh", "DHT [T]rue, [F]alse", "D" );
445 ( Str
, "srh", "Cache extensions [T]rue, [F]alse", "C" );
446 ( Str
, "srh", "Fast extensions [T]rue, [F]alse", "F" );
447 ( Str
, "srh", "uTorrent extensions [T]rue, [F]alse", "U" );
448 ( Str
, "srh br", "Azureus messaging protocol [T]rue, [F]alse", "A" );
450 ( Str, "srh", "Bitmap (absent|partial|present|verified)", (colored_chunks
451 (Array.init (String.length info.G.file_chunks)
452 (fun i -> ((int_of_char info.G.file_chunks.[i])-48)))) ) ;
454 ( Num
, "srh ar", "Number of full chunks", (Printf.sprintf
"%d"
455 (match file
.file_swarmer
with
459 CommonSwarming.chunks_verified_bitmap swarmer
in
460 VB.fold_lefti
(fun acc _
s ->
461 if s = VB.State_verified
then acc
+ 1 else acc
) 0 bitmap)))
464 html_mods_table_header buf "sourcesTable" "sources al" header_list;
466 Hashtbl.iter
(fun _ c
->
467 let cinfo = client_info
(as_client c
) in
468 if use_html_mods o
then
469 Printf.bprintf
buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr
());
471 let btos b
= if b
then "T" else "F" in
472 let cc,cn
= Geoip.get_country_code_name
cinfo.GuiTypes.client_country_code
in
474 ("", "sr br ar", Printf.sprintf
"%d" (client_num c
));
475 ("", "sr br", (Sha1.to_string c
.client_uid
));
476 ("", "sr br", Printf.sprintf
"%s %s" (brand_to_string c
.client_brand
) c
.client_release
);
477 ("", "sr", (Ip.to_string
(fst c
.client_host
)));
478 ("", "sr br ar", Printf.sprintf
"%d" (snd c
.client_host
));
479 ] @ (if Geoip.active
() then
480 [( cn
, "sr br", if use_html_mods o
then CommonPictures.flag_html
cc else cc)]
482 ("", "sr ar", (size_of_int64 c
.client_total_uploaded
));
483 ("", "sr ar br", (size_of_int64 c
.client_total_downloaded
));
484 ("", "sr ar", (size_of_int64 c
.client_session_uploaded
));
485 ("", "sr ar br", (size_of_int64 c
.client_session_downloaded
));
486 ("", "sr", (btos c
.client_interested
));
487 ("", "sr", (btos c
.client_choked
));
488 ("", "sr br ar", (Int64.to_string c
.client_allowed_to_write
));
489 (* This is way too slow for 1000's of chunks on a page with 100's of sources
490 ("", "sr", (CommonFile.colored_chunks (Array.init (String.length c.client_bitmap)
491 (fun i -> (if c.client_bitmap.[i] = '1' then 2 else 0)) )) );
493 ("", "sr", (btos c
.client_interesting
));
494 ("", "sr", (btos c
.client_alrd_sent_interested
));
495 ("", "br sr", (btos c
.client_alrd_sent_notinterested
));
497 ("", "sr", (btos c
.client_good
));
498 ("", "sr", (btos c
.client_incoming
));
499 ("", "br sr", (btos c
.client_registered_bitfield
));
501 ("", "sr", Printf.sprintf
"%d" ((last_time
() - c
.client_connect_time
) / 60));
502 ("", "ar sr", string_of_date c
.client_last_optimist
);
503 ("", "br sr", Printf.sprintf
"%d" c
.client_num_try
);
505 ("", "sr", (btos c
.client_dht
));
506 ("", "sr", (btos c
.client_cache_extension
));
507 ("", "sr", (btos c
.client_fast_extension
));
508 ("", "sr", (btos c
.client_utorrent_extension
));
509 ("", "br sr", (btos c
.client_azureus_messaging_protocol
));
511 ("", "sr ar", (let fc = ref 0 in
512 (match c
.client_bitmap
with
515 Bitv.iter
(fun s -> if s then incr
fc) bitmap);
516 (Printf.sprintf
"%d" !fc) ) )
519 html_mods_td buf td_list;
520 if use_html_mods o
then Printf.bprintf
buf "\\</tr\\>"
521 else Printf.bprintf
buf "\n";
525 if use_html_mods o
then Printf.bprintf
buf "\\</table\\>\\</div\\>\\<br\\>"
526 else Printf.bprintf
buf "\n";
530 let op_file_check file
=
531 lprintf_file_nl
(as_file file
) "Checking chunks of %s" file
.file_name
;
532 match file
.file_swarmer
with
534 lprintf_file_nl
(as_file file
) "verify_chunks: no swarmer to verify chunks"
536 CommonSwarming.verify_all_chunks_immediately swarmer
538 let remove_all_clients file
=
539 Hashtbl.clear file
.file_clients
;
540 file
.file_clients_num
<- 0
542 let op_file_cancel file
=
543 CommonSwarming.remove_swarmer file
.file_swarmer
;
544 file
.file_swarmer
<- None
;
545 BTClients.file_stop file
;
547 BTClients.disconnect_clients file
;
548 remove_all_clients file
;
549 if Sys.file_exists file
.file_torrent_diskname
then Sys.remove file
.file_torrent_diskname
551 let op_ft_cancel ft
=
552 Hashtbl.remove ft_by_num ft
.ft_id
554 let op_ft_commit ft newname
=
555 Hashtbl.remove ft_by_num ft
.ft_id
557 let op_file_info file
=
559 let module P
= GuiTypes
in
561 let last_seen = match file
.file_swarmer
with
562 None
-> [| last_time
() |]
563 | Some swarmer
-> CommonSwarming.compute_last_seen swarmer
in
565 { (impl_file_info file
.file_file
) with
567 P.file_name
= file
.file_name
;
568 P.file_network
= network
.network_num
;
569 P.file_chunks
= (match file
.file_swarmer
with
571 | Some swarmer
-> Some
(CommonSwarming.chunks_verified_bitmap swarmer
));
572 P.file_chunk_size
= (match file
.file_swarmer
with
574 | Some t
-> Some
(List.map
(fun t
-> t
.CommonSwarming.t_chunk_size
) t
.CommonSwarming.t_s
.CommonSwarming.s_networks
));
575 P.file_availability
=
576 [network
.network_num
,(match file
.file_swarmer
with
577 None
-> "" | Some swarmer
->
578 CommonSwarming.chunks_availability swarmer
)];
580 P.file_chunks_age
= last_seen;
581 P.file_uids
= [Uid.create
(BTUrl file
.file_id
)];
582 P.file_sub_files
= file
.file_files
;
583 P.file_active_sources
= List.length
(op_file_active_sources file
);
584 P.file_all_sources
= (Hashtbl.length file
.file_clients
);
585 P.file_comment
= file
.file_comment
;
590 let module P
= GuiTypes
in
593 P.file_fields
= P.Fields_file_info.all
;
595 P.file_comment
= file_comment
(as_ft ft
);
596 P.file_name
= ft
.ft_filename
;
597 P.file_num
= ft_num ft
;
598 P.file_network
= network
.network_num
;
599 P.file_names
= [ft
.ft_filename
];
600 P.file_md4
= Md4.null
;
601 P.file_size
= ft_size ft
;
602 P.file_downloaded
= zero
;
603 P.file_all_sources
= 0;
604 P.file_active_sources
= 0;
605 P.file_state
= ft_state ft
;
606 P.file_sources
= None
;
607 P.file_download_rate
= 0.;
608 P.file_chunks
= None
;
609 P.file_chunk_size
= None
;
610 P.file_availability
= [network
.network_num
, ""];
611 P.file_format
= FormatNotComputed
0;
612 P.file_chunks_age
= [| last_time
() |];
614 P.file_last_seen
= BasicSocket.last_time
();
617 P.file_sub_files
= [];
619 P.file_comments
= [];
622 P.file_release
= file_release
(as_ft ft
);
627 let load_torrent_string s user group
=
628 if !verbose
then lprintf_nl
"load_torrent_string";
629 let file_id, torrent
= BTTorrent.decode_torrent
s in
631 (* Save the torrent, because we later want to put
632 it in the seeded directory. *)
633 let torrent_diskname = CommonFile.concat_file downloads_directory
(torrent
.torrent_name ^
".torrent") in
634 if Sys.file_exists
torrent_diskname then
636 if !verbose
then lprintf_nl
"load_torrent_string: %s already exists, ignoring" torrent_diskname;
637 raise
(Torrent_already_exists torrent
.torrent_name
)
639 File.from_string
torrent_diskname s;
642 lprintf_nl
"Starting torrent download with diskname: %s"
644 let file = new_download
file_id torrent
torrent_diskname user group
in
645 BTClients.talk_to_tracker
file true;
646 CommonInteractive.start_download
(file_find
(file_num
file));
649 let load_torrent_file filename user group
=
651 lprintf_nl
"load_torrent_file %s" filename
;
652 let s = File.to_string filename
in
653 (* Delete the torrent if it is in the downloads dir. because it gets saved
654 again under the torrent name and we don't want to clutter up this dir. .*)
655 if Sys.file_exists filename
656 && (Filename.dirname filename
) = downloads_directory
then
658 ignore
(load_torrent_string s user group
)
661 let parse_tracker_reply file t filename =
662 (*This is the function which will be called by the http client
663 for parsing the response*)
664 (* Interested only in interval*)
665 if !verbose_msg_servers
then lprintf_file_nl
(as_file
file) "Filename %s" filename
;
668 File.to_string filename
669 with e
-> lprintf_file_nl
(as_file
file) "Empty reply from tracker"; ""
672 match tracker_reply with
674 if !verbose_connect
then
675 lprintf_file_nl
(as_file
file) "Empty reply from tracker";
677 | _
-> Bencode.decode
tracker_reply
679 if !verbose_msg_servers
then lprintf_file_nl
(as_file
file) "Received: %s" (Bencode.print
v);
680 t
.tracker_interval
<- 600;
683 List.iter
(fun (key
,value) ->
684 match (key
, value) with
685 String
"interval", Int n
->
686 t
.tracker_interval
<- Int64.to_int n
;
687 if !verbose_msg_servers
then lprintf_file_nl
(as_file
file) ".. interval %d .." t
.tracker_interval
688 | String
"failure reason", String failure
->
689 lprintf_file_nl
(as_file
file) "Failure from Tracker in file: %s Reason: %s" file.file_name failure
690 (*TODO: merge with f from get_sources_from_tracker and parse the rest of the answer, too.
691 also connect to the sources we receive or instruct tracker to send none, perhaps based
692 on an config option. firewalled people could activate the option and then seed torrents, too.*)
698 let try_share_file torrent_diskname =
699 if !verbose_share
then lprintf_nl
"try_share_file: %s" torrent_diskname;
700 let s = File.to_string
torrent_diskname in
701 let file_id, torrent
= BTTorrent.decode_torrent
s in
707 [] -> raise Not_found
709 let s = sharing_strategy sh
.shdir_strategy
in
710 if match torrent
.torrent_files
with
711 [] -> not
s.sharing_directories
712 | _
-> s.sharing_directories
then
714 Filename.concat sh
.shdir_dirname torrent
.torrent_name
716 if !verbose_share
then lprintf_nl
"Checking for %s" filename;
717 if Sys.file_exists
filename then filename else
722 iter (shared_directories_including_user_commit
())
725 let user = CommonUserDb.admin_user
() in
726 let file = new_file
file_id torrent
torrent_diskname
727 filename FileShared
user user.user_default_group
in
729 if !verbose_share
then
730 lprintf_file_nl
(as_file
file) "Sharing file %s" filename;
731 BTClients.talk_to_tracker
file false;
735 (* if the torrent is still there while the file is gone, remove the torrent *)
736 if !verbose_share
then lprintf_nl
"Removing torrent for %s" s;
737 let new_torrent_diskname =
738 Filename.concat old_directory
739 (Filename.basename
torrent_diskname)
742 Unix2.rename
torrent_diskname new_torrent_diskname;
743 `Ok
new_torrent_diskname
745 let msg = Printf.sprintf
"Failed to rename %S to %S" torrent_diskname new_torrent_diskname in
750 let msg = Printf.sprintf
"Cannot share %S - exn %s" torrent_diskname (Printexc2.to_string e
) in
754 (* Call one minute after start, and then every 20 minutes. Should
755 automatically contact the tracker. *)
757 if !verbose_share
then lprintf_nl
"share_files";
758 List.iter (fun file ->
759 ignore
(try_share_file (Filename.concat seeded_directory
file))
760 ) (Unix2.list_directory seeded_directory
);
761 let shared_files_copy = !current_files
in
762 (* if the torrent is gone while the file is still shared, remove the share *)
763 List.iter (fun file ->
764 (* if !verbose_share then lprintf_nl "Checking torrent share for %s" file.file_torrent_diskname; *)
765 if not
(Sys.file_exists
file.file_torrent_diskname
) &&
766 file_state
file = FileShared
then
768 if !verbose_share
then lprintf_nl
"Removing torrent share for %s" file.file_torrent_diskname
;
769 BTClients.file_stop
file;
771 BTClients.disconnect_clients
file;
772 remove_all_clients file;
776 (** talk_to_tracker maintains timers and will connect to trackers only when allowed by rules *)
777 let announce_shared_files () =
778 List.iter (fun file -> if file_state
file = FileShared
then BTClients.talk_to_tracker
file false) !current_files
780 let scan_new_torrents_directory () =
781 let filenames = Unix2.list_directory new_torrents_directory
in
782 List.iter (fun file ->
783 let file = Filename.concat new_torrents_directory
file in
784 let file_basename = Filename.basename
file in
785 if not
(Unix2.is_directory
file) then
787 let file_owner = fst
(Unix32.owner
file) in
790 CommonUserDb.user2_user_find
file_owner
791 with Not_found
-> CommonUserDb.admin_user
()
793 load_torrent_file file user user.user_default_group
;
794 (try Sys.remove
file with _
-> ())
797 Unix2.rename
file (Filename.concat old_directory
file_basename);
798 lprintf_nl
"Error %s in scan_new_torrents_directory for %s, moved to torrents/old ..."
799 (Printexc2.to_string e
) file_basename
802 let retry_all_ft () =
803 Hashtbl.iter (fun _ ft
->
804 try ft
.ft_retry ft
with e
->
805 lprintf_nl
"ft_retry: exception %s" (Printexc2.to_string e
)
808 let load_torrent_from_web r user group ft
=
809 let module H
= Http_client
in
810 H.wget
r (fun filename ->
811 if ft_state ft
= FileDownloading
then begin
812 load_torrent_file filename user group
;
813 file_cancel
(as_ft ft
) (CommonUserDb.admin_user
())
816 let valid_torrent_extension url
=
817 let ext = String.lowercase
(Filename2.last_extension url
) in
818 ext = ".torrent" || ext = ".tor"
820 let get_regexp_string text r =
821 ignore
(Str.search_forward
r text 0);
822 let a = Str.group_beginning
1 in
823 let b = Str.group_end
1 in
824 String.sub
text a (b - a)
826 let op_network_parse_url url
user group
=
827 let location_regexp = "Location: \\(.*\\)" in
829 let real_url = get_regexp_string url
(Str.regexp
location_regexp) in
830 if (valid_torrent_extension real_url)
831 || (String2.contains url
"Content-Type: application/x-bittorrent")
833 let u = Url.of_string
real_url in
834 let module H
= Http_client
in
838 H.req_proxy
= !CommonOptions.http_proxy
;
839 H.req_user_agent
= get_user_agent
();
841 let (rule_search
,rule_value
) =
842 try (List.find
(fun (rule_search
,rule_value
) ->
843 Str.string_match
(Str.regexp rule_search
) real_url 0
845 with Not_found
-> ("",real_url) in
846 Some
(Url.of_string rule_value
) );
848 let cookies = List.assoc
u.Url.server
!!cookies in
849 [ ( "Cookie", List.fold_left
(fun res
(key
, value) ->
853 res ^
"; " ^ key ^
"=" ^
value
856 with Not_found
-> []);
857 H.req_max_retry
= 10;
860 let file_diskname = Filename.basename
u.Url.short_file
in
861 let ft = new_ft
file_diskname user in
862 ft.ft_retry
<- (load_torrent_from_web r user group
);
863 load_torrent_from_web r user group
ft;
864 "started download", true
870 if (valid_torrent_extension url
) then
872 if !verbose
then lprintf_nl
"Not_found and trying to load %s" url
;
874 load_torrent_file url
user group
;
877 Torrent_already_exists _
-> "A torrent with this name is already in the download queue", false
879 lprintf_nl
"Exception %s while 2nd loading" (Printexc2.to_string e
);
880 let s = Printf.sprintf
"Can not load load torrent file: %s"
881 (Printexc2.to_string e
) in
885 if !verbose
then lprintf_nl
"Not_found and url has non valid torrent extension: %s" url
;
886 "Not_found and url has non valid torrent extension", false
889 lprintf_nl
"Exception %s while loading" (Printexc2.to_string e
);
890 let s = Printf.sprintf
"Can not load load torrent file: %s"
891 (Printexc2.to_string e
) in
894 let op_client_info c
=
895 check_client_country_code c
;
896 let module P
= GuiTypes
in
897 let (ip
,port
) = c
.client_host
in
898 { (impl_client_info c
.client_client
) with
900 P.client_network
= network
.network_num
;
901 P.client_kind
= Known_location
(ip
,port
);
902 P.client_country_code
= c
.client_country_code
;
903 P.client_state
= client_state
(as_client c
);
904 P.client_type
= client_type c
;
905 P.client_name
= (Printf.sprintf
"%s:%d" (Ip.to_string ip
) port
);
906 P.client_software
= (brand_to_string c
.client_brand
);
907 P.client_release
= c
.client_release
;
908 P.client_total_downloaded
= c
.client_total_downloaded
;
909 P.client_total_uploaded
= c
.client_total_uploaded
;
910 P.client_session_downloaded
= c
.client_session_downloaded
;
911 P.client_session_uploaded
= c
.client_session_uploaded
;
912 P.client_upload
= Some
(c
.client_file
.file_name
);
913 P.client_connect_time
= c
.client_connect_time
;
917 let op_client_connect c
=
918 BTClients.connect_client c
920 let op_client_disconnect c
=
921 BTClients.disconnect_client c Closed_by_user
923 let op_client_bprint c
buf =
924 let cc = as_client c
in
925 let cinfo = client_info
cc in
926 Printf.bprintf
buf "%s (%s)\n"
927 cinfo.GuiTypes.client_name
928 (Sha1.to_string c
.client_uid
)
930 let op_client_dprint c o
file =
931 let info = file_info
file in
932 let buf = o
.conn_buf
in
933 let cc = as_client c
in
935 Printf.bprintf
buf (_b "\n%18sDown : %-10s Uploaded: %-10s Ratio: %s%1.1f (%s)\n") ""
936 (Int64.to_string c
.client_total_downloaded
)
937 (Int64.to_string c
.client_total_uploaded
)
938 (if c
.client_total_downloaded
> c
.client_total_uploaded
then "-" else "+")
939 (if c
.client_total_uploaded
> Int64.zero
then
940 Int64.to_float
(c
.client_total_downloaded
// c
.client_total_uploaded
)
943 (Printf.bprintf
buf (_b "%18sFile : %s\n") "" info.GuiTypes.file_name
)
945 let op_client_dprint_html c o
file str
=
946 let info = file_info
file in
947 let buf = o
.conn_buf
in
948 let ac = as_client c
in
949 let cinfo = client_info
ac in
950 Printf.bprintf
buf " \\<tr onMouseOver=\\\"mOvr(this);\\\"
951 onMouseOut=\\\"mOut(this);\\\" class=\\\"%s\\\"\\>" str
;
953 let show_emulemods_column = ref false in
954 if Autoconf.donkey
= "yes" then begin
955 if !!emule_mods_count
then
956 show_emulemods_column := true
959 let cc,cn
= Geoip.get_country_code_name
cinfo.GuiTypes.client_country_code
in
962 ("", "srb ar", Printf.sprintf
"%d" (client_num c
));
963 ((string_of_connection_state
(client_state
ac)), "sr",
964 (short_string_of_connection_state
(client_state
ac)));
965 ((Sha1.to_string c
.client_uid
), "sr", cinfo.GuiTypes.client_name
);
966 ("", "sr", (brand_to_string c
.client_brand
)); (* cinfo.GuiTypes.client_software *)
967 ("", "sr", c
.client_release
);
969 (if !show_emulemods_column then [("", "sr", "")] else [])
972 ("", "sr ar", Printf.sprintf
"%d"
973 (((last_time
()) - cinfo.GuiTypes.client_connect_time
) / 60));
976 ("", "sr", (Ip.to_string
(fst c
.client_host
)));
977 ] @ (if Geoip.active
() then [(cn
, "sr", CommonPictures.flag_html
cc)] else []) @ [
978 ("", "sr ar", (size_of_int64 c
.client_total_uploaded
));
979 ("", "sr ar", (size_of_int64 c
.client_total_downloaded
));
980 ("", "sr ar", (size_of_int64 c
.client_session_uploaded
));
981 ("", "sr ar", (size_of_int64 c
.client_session_downloaded
));
982 ("", "sr", info.GuiTypes.file_name
); ]);
985 let op_network_connected _
= true
987 let compute_torrent filename announce comment
=
988 let announce = if announce = "" then BTTracker.get_default_tracker
() else announce in
989 if !verbose
then lprintf_nl
"compute_torrent: [%s] [%s] [%s]"
990 filename announce comment
;
991 let basename = Printf.sprintf
"%s.torrent" (Filename.basename filename) in
992 let torrent = Filename.concat seeded_directory
basename in
993 let is_private = false in
994 let file_id = BTTorrent.generate_torrent
announce torrent comment
is_private filename in
995 match try_share_file torrent with
996 | `Err
msg -> failwith
msg
997 | `Ok torrent_path
->
998 Filename.concat
(Sys.getcwd
()) torrent_path
,
999 try `Ok
(BTTracker.track_torrent
basename file_id) with exn
-> `Err
(Printexc2.to_string exn
)
1001 (* let text fmt = Printf.ksprintf (fun s -> `Text s) fmt *)
1003 OCaml 3.08.3 compatibility (ksprintf not available)
1004 http://mldonkey.sourceforge.net/phpBB2/viewtopic.php?p=30453
1006 let text s = `Text
s
1007 let link name url
= `Link
(name
,url
)
1009 let output buf typ elements
=
1010 let f = match typ
with
1011 | HTML
| XHTML
| XML
->
1013 | `Text
s -> Xml.buffer_escape
buf s
1014 | `Link
(name
,url
) ->
1015 Printf.bprintf
buf "<a href=\"%s\">%s</a>"
1016 (Xml.escape url
) (Xml.escape
(match name
with "" -> url
| s -> s))
1017 | `Break
-> Buffer.add_string
buf "<br/>"
1021 | `Text
s -> Buffer.add_string
buf s
1022 | `Link
("",url
) -> Printf.bprintf
buf "%s" url
1023 | `Link
(name
,url
) -> Printf.bprintf
buf "%s <%s>" name url
1024 | `Break
-> Buffer.add_string
buf "\n"
1027 List.iter f elements
1031 match o
.conn_output
with
1032 | ANSI
| TEXT
-> output o
.conn_buf o
.conn_output l
1033 | HTML
| XHTML
| XML
->
1034 let buf = Buffer.create
1024 in
1035 output buf o
.conn_output l
;
1036 let s = Buffer.contents
buf in
1037 for i
= 0 to String.length
s - 1 do
1038 begin match s.[i
] with
1039 | '
<'
| '
>'
| '
\\'
| '
"' | '&' -> Buffer.add_char o.conn_buf '\\'
1041 Buffer.add_char o.conn_buf s.[i]
1047 "compute_torrent", "Network
/Bittorrent
", Arg_multiple (fun args o ->
1050 let filename = ref "" in
1051 let comment = ref "" in
1053 fname :: [comm] -> filename := fname; comment := comm
1054 | [fname] -> filename := fname
1055 | _ -> raise Not_found);
1057 let (path,url) = compute_torrent !filename "" !comment in
1059 text (Printf.sprintf "Torrent
file generated
: %s
" path);
1062 | `Ok url -> link "Download
" url
1063 | `Err s -> text (Printf.sprintf "Not tracked
: %s
" s));
1067 | Not_found -> [text "Not enough parameters
"; `Break]
1068 | exn -> [text (Printf.sprintf "Error
: %s
" (Printexc2.to_string exn)); `Break]
1071 ), _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
/";
1073 "torrents
", "Network
/Bittorrent
", Arg_none (fun o ->
1076 BTTracker.check_tracker ();
1077 let files_tracked = Unix2.list_directory tracked_directory in
1078 let files_downloading = Unix2.list_directory downloads_directory in
1079 let files_seeded = Unix2.list_directory seeded_directory in
1080 let files_old = Unix2.list_directory old_directory in
1081 let all_torrents_files = files_tracked @ files_downloading @ files_seeded @ files_old in
1083 let l = List.map (fun file -> [link file (BTTracker.tracker_url file); `Break]) all_torrents_files in
1085 (`Text (_s ".torrent files available
:")) :: `Break :: List.flatten l
1088 [`Text (Printexc2.to_string exn); `Break]
1091 ), _s ":\t\t\t\tprint all
.torrent files on this server
";
1093 "print_torrent
", "Network
/Bittorrent
", Arg_one (fun arg o ->
1094 if CommonUserDb.user2_is_admin o.conn_user.ui_user then begin
1097 Some (as_file_impl (file_find (int_of_string arg)))
1101 | None -> Printf.sprintf "file %s not found
" arg
1104 if use_html_mods o then begin
1105 html_mods_cntr_init ();
1106 html_mods_table_header o.conn_buf "sourcesInfo
" "sourcesInfo
" [
1107 ( Str, "srh br
", "File Info
", "Info
" ) ;
1108 ( Str, "srh
", "Value
", "Value
" ) ]
1110 op_file_print file.impl_file_val o;
1111 if use_html_mods o then begin
1112 Printf.bprintf o.conn_buf "\\</tr
\\>\\</table
\\>\\</div
\\>";
1113 Printf.bprintf o.conn_buf "\\</td
\\>\\</tr
\\>\\</table
\\>\\</div
\\>\\<br
\\>"
1118 begin print_command_result o "You are not allowed
to use print_torrent
";
1120 ), _s "<num
> :\t\t\tshow internal data
of .torrent file";
1122 "seeded_torrents
", "Network
/Bittorrent
", Arg_none (fun o ->
1123 if CommonUserDb.user2_is_admin o.conn_user.ui_user then begin
1124 List.iter (fun file ->
1125 if file_state file = FileShared then
1126 Printf.bprintf o.conn_buf "%s
[U %Ld
u/d %Ld
/%Ld
]\n"
1127 file.file_name file.file_uploaded file.file_session_uploaded file.file_session_downloaded
1131 begin print_command_result o "You are not allowed
to use seeded_torrents
";
1133 ), _s ":\t\t\tprint all seeded
.torrent files on this server
(output: name
, total upload
, session upload
, session download
)";
1135 "reshare_torrents
", "Network
/Bittorrent
", Arg_none (fun o ->
1138 ), _s ":\t\t\trecheck torrents
/* directories
for changes
";
1140 "rm_old_torrents
", "Network
/Bittorrent
", Arg_none (fun o ->
1141 let files_outdated = Unix2.list_directory old_directory in
1142 let buf = o.conn_buf in
1143 if o.conn_output = HTML then begin
1144 (* TODO: really htmlize it *)
1145 Printf.bprintf buf "Removing old torrents
...";
1146 List.iter (fun file ->
1147 Printf.bprintf buf "%s
"
1152 Printf.bprintf buf "Removing old torrents
...\n";
1153 List.iter (fun file ->
1154 Printf.bprintf buf "%s
\n"
1158 List.iter (fun file ->
1159 Sys.remove (Filename.concat old_directory file)
1162 ), _s ":\t\t\tremove all old
.torrent files
";
1164 "startbt
", "Network
/Bittorrent
", Arg_one (fun url o ->
1165 let buf = o.conn_buf in
1166 if Sys.file_exists url then
1168 load_torrent_file url o.conn_user.ui_user o.conn_user.ui_user.user_default_group;
1169 Printf.bprintf buf "loaded
file %s
\n" url
1173 let url = "Location
: " ^ url ^ "\nContent
-Type
: application
/x
-bittorrent
" in
1174 let result = fst (op_network_parse_url url o.conn_user.ui_user o.conn_user.ui_user.user_default_group) in
1175 Printf.bprintf buf "%s
\n" result
1178 ), "<url|file> :\t\t\tstart BT download
";
1180 "stop_all_bt
", "Network
/Bittorrent
", Arg_none (fun o ->
1181 List.iter (fun file -> BTClients.file_stop file ) !current_files;
1182 let buf = o.conn_buf in
1183 if o.conn_output = HTML then
1184 (* TODO: really htmlize it *)
1185 Printf.bprintf buf "started sending stops
..."
1187 Printf.bprintf buf "started sending stops
...\n";
1189 ), _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
:)";
1191 "tracker
", "Network
/Bittorrent
", Arg_multiple (fun args o ->
1194 let urls = ref [] in
1196 | nums :: [] -> raise Not_found
1197 | nums :: rest -> num := nums; urls := rest
1198 | _ -> raise Not_found);
1200 let num = int_of_string !num in
1201 Hashtbl.iter (fun _ file ->
1202 if file_num file = num then begin
1204 lprintf_file_nl (as_file file) "adding trackers
for file %i
" num;
1205 set_trackers file !urls;
1209 let buf = o.conn_buf in
1210 if o.conn_output = HTML then
1211 html_mods_table_one_row buf "serversTable
" "servers
" [
1212 ("", "srh
", "file not found
"); ]
1214 Printf.bprintf buf "file not found
";
1218 let buf = o.conn_buf in
1219 if o.conn_output = HTML then
1220 html_mods_table_one_row buf "serversTable
" "servers
" [
1221 ("", "srh
", "tracker added
"); ]
1223 Printf.bprintf buf "tracker added
";
1227 lprintf_nl "Not enough
or wrong parameters
.";
1228 let buf = o.conn_buf in
1229 if o.conn_output = HTML then
1230 html_mods_table_one_row buf "serversTable
" "servers
" [
1231 ("", "srh
", "Not enough
or wrong parameters
."); ]
1233 Printf.bprintf buf "Not enough
or wrong parameters
.";
1235 ), "<num> <url> <url>... :\t\tadd URLs
as trackers
for num";
1237 (* TODO : add some code from make_torrent
1238 "print_torrent
", Arg_one (fun filename o ->
1240 ".torrent file printed
"
1241 ), "<filename.torrent> :\t\tprint the content
of filename"
1249 let op_gui_message s user =
1250 match get_int16 s 0 with
1252 let text = String.sub s 2 (String.length s - 2) in
1253 if !verbose then lprintf_nl "received
torrent from gui
...";
1255 let file = load_torrent_string text user user.user_default_group in
1256 raise (Torrent_started file.file_name)
1257 with e -> (match e with
1258 | Torrent_already_exists s -> lprintf_nl "Loading
torrent from GUI
: torrent %s is already
in download queue
" s
1262 let n = get_int s 2 in
1263 let a, pos = get_string s 6 in
1264 let c, pos = get_string s pos in
1265 let sf = CommonShared.shared_find n in
1266 let f = shared_fullname sf in
1267 ignore (compute_torrent f a c)
1268 | opcode -> failwith (Printf.sprintf "[BT
] Unknown message opcode %d
" opcode)
1272 ft_ops.op_file_cancel <- op_ft_cancel;
1273 ft_ops.op_file_commit <- op_ft_commit;
1274 ft_ops.op_file_info <- op_ft_info;
1275 ft_ops.op_file_active_sources <- (fun _ -> []);
1276 ft_ops.op_file_all_sources <- (fun _ -> []);
1278 file_ops.op_file_all_sources <- op_file_all_sources;
1279 file_ops.op_file_files <- op_file_files;
1280 file_ops.op_file_active_sources <- op_file_active_sources;
1281 file_ops.op_file_debug <- op_file_debug;
1282 file_ops.op_file_commit <- op_file_commit;
1283 file_ops.op_file_print <- op_file_print;
1284 file_ops.op_file_print_sources <- op_file_print_sources;
1285 file_ops.op_file_check <- op_file_check;
1286 file_ops.op_file_cancel <- op_file_cancel;
1287 file_ops.op_file_info <- op_file_info;
1288 file_ops.op_file_save_as <- (fun file name -> ());
1289 file_ops.op_file_shared <- (fun file ->
1290 match file.file_shared with
1292 | Some sh -> Some (as_shared sh)
1294 file_ops.op_file_download_order <- (fun file strategy ->
1295 match file.file_swarmer with
1298 (match strategy with
1299 (* return current strategy *)
1300 | None -> Some (CommonSwarming.get_strategy s)
1301 | Some strategy -> CommonSwarming.set_strategy s strategy;
1302 Some (CommonSwarming.get_strategy s))
1305 network.op_network_gui_message <- op_gui_message;
1306 network.op_network_connected <- op_network_connected;
1307 network.op_network_parse_url <- op_network_parse_url;
1308 network.op_network_share <- (fun fullname codedname size -> ());
1309 network.op_network_close_search <- (fun s -> ());
1310 network.op_network_forget_search <- (fun s -> ());
1311 network.op_network_connect_servers <- (fun s -> ());
1312 network.op_network_search <- (fun ss buf -> ());
1313 network.op_network_download <- (fun r user group -> dummy_file);
1314 network.op_network_recover_temp <- (fun s -> ());
1315 let clean_exit_started = ref false in
1316 network.op_network_clean_exit <- (fun s ->
1317 if not !clean_exit_started then
1319 List.iter (fun file -> BTClients.file_stop file) !current_files;
1320 clean_exit_started := true;
1322 List.for_all (fun file -> not file.file_tracker_connected) !current_files;
1324 network.op_network_reset <- (fun _ ->
1325 List.iter (fun file -> BTClients.file_stop file) !current_files);
1326 network.op_network_ports <- (fun _ ->
1328 !!client_port, "client_port TCP
";
1329 !!BTTracker.tracker_port, "tracker_port TCP
";
1330 ] @ (match !bt_dht with None -> [] | Some dht -> [dht.BT_DHT.M.dht_port,"dht_port UDP
"]));
1331 network.op_network_porttest_result <- (fun _ -> !porttest_result);
1332 network.op_network_porttest_start <- (fun _ ->
1333 azureus_porttest_random := (Random.int 100000);
1335 Printf.sprintf "http
://www
.utorrent
.com
/testport?port
=%d
" !!client_port, interpret_utorrent_porttest;
1336 Printf.sprintf "http
://azureus
.aelitis
.com
/natcheck
.php?port
=%d
&check
=azureus_rand_%d
"
1337 !!client_port !azureus_porttest_random, interpret_azureus_porttest;
1339 perform_porttests tests
1341 network.op_network_check_upload_slots <- (fun _ -> check_bt_uploaders ());
1342 client_ops.op_client_info <- op_client_info;
1343 client_ops.op_client_connect <- op_client_connect;
1344 client_ops.op_client_disconnect <- op_client_disconnect;
1345 client_ops.op_client_bprint <- op_client_bprint;
1346 client_ops.op_client_dprint <- op_client_dprint;
1347 client_ops.op_client_dprint_html <- op_client_dprint_html;
1348 client_ops.op_client_browse <- (fun _ _ -> ());
1349 client_ops.op_client_files <- (fun _ -> []);
1350 client_ops.op_client_clear_files <- (fun _ -> ());
1352 CommonNetwork.register_commands commands;
1354 shared_ops.op_shared_state <- (fun file o ->
1355 if o.conn_output = HTML then
1356 Printf.sprintf "\\<a href
=\\\"submit?q
=print_torrent
+%d
\\\"\\>Details
\\</a\\>"
1358 else Printf.sprintf "Shared using %s
" file.file_torrent_diskname
1360 shared_ops.op_shared_unshare <- (fun file ->
1361 (if !verbose_share then lprintf_file_nl (as_file file) "unshare
file");
1362 BTGlobals.unshare_file file);
1363 shared_ops.op_shared_info <- (fun file ->
1364 let module T = GuiTypes in
1365 match file.file_shared with
1366 None -> assert false
1368 { (impl_shared_info impl) with
1369 T.shared_network = network.network_num;
1370 T.shared_filename = file_best_name (as_file file);
1371 T.shared_uids = [Uid.create (Sha1 file.file_id)];
1372 T.shared_sub_files = file.file_files;