1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
3 This file is part of mldonkey.
5 mldonkey is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 mldonkey is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with mldonkey; if not, write to the Free Software
17 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
27 open CommonInteractive
46 let log_prefix = "[dcInt]"
49 lprintf_nl2
log_prefix fmt
51 (* Start new dowload from result *)
52 let start_new_download u tth fdir fname fsize user group
=
54 ignore
(Hashtbl.find dc_shared_files_by_hash tth
);
55 if !verbose_download
then lprintf_nl "Shared file with same hash exists (%s) (%s)" fname tth
;
58 let f = new_file tth fdir fname fsize user group
in (* ...create new file *)
59 match (file_state
f) with
60 | FileDownloaded
| FileShared
-> if !verbose_download
then lprintf_nl "File already downloaded"; None
61 | FileDownloading
-> if !verbose_download
then lprintf_nl "File being downloaded"; None
62 | FilePaused
-> if !verbose_download
then lprintf_nl "File paused"; None
63 | FileAborted _
| FileCancelled
| FileQueued
->
64 if !verbose_download
then lprintf_nl "File state invalid"; None
66 file_add
f.file_file FileDownloading
;
70 let c = new_client_to_user_with_file user
f in
71 c.client_state
<- DcDownloadWaiting
f;
72 if (can_user_start_downloading user
) then begin
73 user
.user_state
<- TryingToSendFirstContact
;
74 c.client_state
<- DcDownloadConnecting
(f,current_time
());
75 ignore
(DcClients.try_connect_client
c)
79 (* Start downloading of a file by user selection from resultlist *)
80 let start_result_download r user group
=
81 let filename = List.hd r
.result_names
in
82 let rinfo = Hashtbl.find dc_result_info r
.result_num
in
83 let newfile = start_new_download (Some
rinfo.user
) rinfo.tth
rinfo.directory
filename r
.result_size user group
in
85 | Some
f -> as_file
f.file_file
(* return CommonFile.file *)
86 | _
-> raise Not_found
)
88 let exn_catch f x
= try `Ok
(f x
) with exn
-> `Exn exn
89 let opt_default default
= function None
-> default
| Some v
-> v
91 let parse_url url user group
=
92 match exn_catch parse_magnet_url url
with
93 | `Exn _
-> "Not a magnet url", false
96 lprintf_nl "Got magnet url %S" url
;
97 (* TODO multiple TTHs, multiple xt, automatic merge of downloads from different networks (?!) *)
98 match List2.filter_map
(function TigerTree tth
-> Some tth
| _
-> None
) magnet#uids
with
99 | [] -> "No TTH found in magnet url", false
101 let (_
: _
option) = start_new_download None
(TigerTree.to_string tth
) "" magnet#name
(opt_default 0L magnet#size
) user group
in
104 (* register DC commands *)
105 let register_commands list
=
106 register_commands (List2.tail_map
(fun (n
,f,h
) -> (n
, "Direct Connect", f,h
)) list
)
108 let command l
= String.concat
"+" (List.map
Url.encode l
)
110 let td_command text title ?
(blink
=false) ?
(target
=`Output
) cmd
=
112 "\\<td class=\\\"srb\\\" %sonMouseOver=\\\"mOvr(this);\\\"
113 onMouseOut=\\\"mOut(this);\\\" title=\\\"%s\\\"
114 onClick=\\\"parent.%s.location.href='submit?q=%s'\\\"\\>%s\\</td\\>"
115 (if blink
then "style=\\\"text-decoration:blink\\\" " else "")
116 title
(match target
with `Output
-> "output" | `Status
-> "fstatus")
120 (* Print DC hubs header *)
121 let dc_hublist_print_html_header buf ext
=
122 html_mods_table_header buf
"serversTable" (Printf.sprintf
"servers%s" ext
) [
123 ( Num
, "srh", "Hub number", "#" ) ;
124 ( Str
, "srh", "Add hub to servers", "Add" ) ;
125 ( Str
, "srh", "Hub name", "Hub name" ) ;
126 ( Str
, "srh", "IP address", "IP address" ) ;
127 ( Num
, "srh", "Users in hub", "Users" ) ;
128 ( Str
, "srh", "Hub info", "Info" ) ]
130 (* print in html or txt list of hubs *)
131 let hublist_print h hnum o
=
132 let buf = o
.conn_buf
in
133 let hname = shorten_string h
.dc_name
50 in
134 let hinfo = shorten_string h
.dc_info
50 in
135 if use_html_mods o
then begin
137 \\<tr class=\\\"dl-%d\\\"\\>
138 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
140 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
141 \\<td class=\\\"sr\\\"\\>%s:%d\\</td\\>
142 \\<td class=\\\"sr\\\"\\>%d\\</td\\>
143 \\<td width=\\\"100%%\\\" class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>\n"
146 (td_command "Add" "Add" ~target
:`Status
147 ["dcn"; Ip.string_of_addr h
.dc_ip
; string_of_int h
.dc_port
])
149 (Ip.string_of_addr h
.dc_ip
) h
.dc_port
152 Printf.bprintf
buf "[%5d] %20s %25s:%-10d Users:%-8d %20s\n"
155 (Ip.string_of_addr h
.dc_ip
) h
.dc_port
160 (* Print DC users header *)
161 let dc_user_print_html_header buf =
162 html_mods_table_header
buf "serversTable" "servers" [
163 ( Num
, "srh", "User number", "#" );
164 ( Str
, "srh", "User name", "Name" );
165 ( Str
, "srh", "User type", "Type" );
166 ( Num
, "srh", "Users slots (all/free)", "Slots" );
167 ( Num
, "srh", "Users connected hubs (Normal/Vipped/Opped)", "Hubs" );
168 ( Str
, "srh", "Users mode", "Mode" );
169 ( Num
, "srh", "Users shared size", "Shared" );
170 ( Str
, "srh", "User state", "State" );
171 ( Str
, "srh", "User description field", "Description" );
172 ( Num
, "srh", "User clients number", "Clients" );
173 ( Num
, "srh", "Users servers number", "Servers" );
174 ( Str
, "srh", "Download this clients filelist", "Filelist" );
175 ( Str
, "srh", "Open chat window with this user. Blinking tells there are new unread messages", "Chat");
176 ( Num
, "srh", "User total uploaded bytes", "Up" );
177 ( Num
, "srh", "User total downloaded bytes", "Down" );
178 ( Str
, "srh", "User client supports", "Supports" ); ];
181 (* print in html or txt list of users *)
182 let user_print user num o
=
183 let buf = o
.conn_buf
in
185 (match user
.user_type
with
192 (match user
.user_state
with
193 | UserIdle
-> "NotDefined"
194 | TryingToSendFirstContact
-> "TryingToSendFirstContact"
195 | UserActiveMeInitiating
-> "UserActiveMeInitiating"
196 | UserActiveUserInitiating
-> "UserActiveUserInitiating"
197 | UserPassiveUserInitiating _
-> "UserPassiveUserInitiating" )
199 let clients = List.length user
.user_clients
in
200 let servers = List.length user
.user_servers
in
201 let messages = user_has_new_messages user
in
202 let hasmynick = has_my_nick user
in
204 let a,b
,c = user
.user_myinfo
.hubs in
205 Printf.sprintf
"(%d/%d/%d)" a b
c
208 if (List.length user
.user_clients
> 0) then begin
209 let c = List.hd user
.user_clients
in
210 (match c.client_supports
with
212 DcProtocol.Supports.create_supports_string
(ClientSupports
supports)
213 | _
-> empty_string
)
214 end else empty_string
216 if use_html_mods o
then begin
218 \\<tr class=\\\"dl-%d\\\"\\>
219 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
220 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
221 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
222 \\<td class=\\\"sr\\\"\\>%d\\</td\\>
223 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
224 \\<td class=\\\"sr\\\"\\>%c\\</td\\>
225 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
226 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
227 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
228 \\<td class=\\\"sr\\\"\\>%d\\</td\\>
229 \\<td class=\\\"sr\\\"\\>%d\\</td\\>
231 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
232 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
233 \\<td class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>\n"
234 (html_mods_cntr
()) num user
.user_nick
utype user
.user_myinfo
.slots
hubs user
.user_myinfo
.mode
235 (size_of_int64 user
.user_myinfo
.sharesize
) state user
.user_myinfo
.description
clients servers
236 (if not
hasmynick && (servers > 0) then (* is connected to any servers with us *)
237 td_command "Get List" "Download user filelist" ~target
:`Status
["dcloadfilelist"; user
.user_nick
]
240 if hasmynick then "Me"
243 Printf.sprintf
"\\<td class=\\\"sr\\\"\\>%s\\</td\\>" txt
245 (if not
hasmynick then (* not me *)
246 td_command "Open chat" "Open message window to this user" ~blink
:messages ["dcmessages"; user
.user_nick
]
248 "\\<td class=\\\"sr\\\"\\>\\</td\\>" )
249 (size_of_int64 user
.user_uploaded
) (size_of_int64 user
.user_downloaded
) supports
251 Printf.bprintf
buf "[%5d] %-20s %8s %20s\n" num user
.user_nick
utype state
253 (* Print DC hubs header *)
254 let dc_hub_print_html_header buf =
255 html_mods_table_header
buf "serversTable" "servers" [
256 ( Num
, "srh", "Hub number", "#" ) ;
257 ( Str
, "srh", "Set/UnSet server autoconnection state", "Auto" ) ;
258 ( Str
, "srh", "Hub name", "Hub name" ) ;
259 ( Str
, "srh", "IP address", "IP address" ) ;
260 ( Str
, "srh", "My state in this hub", "State" ) ;
261 ( Num
, "srh", "Users in hub", "Users" ) ;
262 ( Str
, "srh", "Hub info", "Info" );
263 ( Str
, "srh", "Open chat window with this hub. Blinking tells there are new unread message", "Chat" ) ]
265 (* Print list of connected hubs *)
266 let hub_print s num o
=
267 let buf = o
.conn_buf
in
268 let sinfo = shorten_string s
.server_info
50 in
269 let sname = shorten_string s
.server_name
50 in
270 let sip = Ip.to_string s
.server_ip
in
271 let sport = s
.server_port
in
272 let susers = List.length s
.server_users
in
273 let smessages = ((List.length s
.server_messages
) > s
.server_read_messages
) in
274 let sstate = dc_hubstate_to_text s
in
275 if use_html_mods o
then begin
277 \\<tr class=\\\"dl-%d\\\"\\>
278 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
280 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
281 \\<td class=\\\"sr\\\"\\>%s:%d\\</td\\>
282 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
284 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
289 (if s
.server_autoconnect
then "UnSet" else "Set")
290 "Set this hub autoconnection state"
291 ["dcautoconnect"; (if s
.server_autoconnect
then "false" else "true"); sip] )
292 sname sip sport sstate
293 (td_command (string_of_int
susers) "Show users for this hub only" ["dcusers";sip] )
295 (td_command "Open chat" "Open this hubs chat windows" ~blink
:smessages ["dcmessages";sip;string_of_int
sport])
297 Printf.bprintf
buf "[%5d] %20s %25s:%-10d Users:%-8d %20s\n"
305 (* Print DC clients header *)
306 let dc_client_print_html_header buf =
307 html_mods_table_header
buf "serversTable" "servers" [
308 ( Num
, "srh", "Client number", "#" );
309 ( Str
, "srh", "Remove Client", "Rem" );
310 ( Str
, "srh", "Client name", "Name" );
311 ( Str
, "srh", "Client ip/port", "Ip:Port" );
312 ( Str
, "srh", "Client state", "State" );
313 ( Str
, "srh", "Client connection", "Conn" );
314 ( Str
, "srh", "Client last error/count", "Error" );
315 ( Str
, "srh", "Client file", "File" ); ];
318 (* print in html or txt list of clients *)
319 let client_print name client num o
=
320 let buf = o
.conn_buf
in
322 (match client
.client_addr
with
323 | Some
(ip,port
) -> Ip.to_string
ip,port
327 (match client
.client_sock
with
328 | Connection _
-> "Connected"
329 | ConnectionWaiting _
-> "Connecting..."
330 | NoConnection
-> "NoConnection" )
332 let state = client_state_to_string client
in
334 (match client
.client_error
with
335 | NoError
-> empty_string
336 | NoFreeSlots
-> Printf.sprintf
"NoFreeSlots %d" client
.client_error_count
337 | FileNotAvailable
-> Printf.sprintf
"FileNotAvailable %d" client
.client_error_count
338 | UserNotReachable
-> Printf.sprintf
"UserNotReachable %d" client
.client_error_count
339 | ClosedOnInit
-> Printf.sprintf
"ClosedOnInit %d" client
.client_error_count
340 | ConnectionResetByPeer
-> Printf.sprintf
"ConnectionResetByPeer %d" client
.client_error_count
341 | UploadError
-> Printf.sprintf
"UploadError %d" client
.client_error_count
342 | UserDontReplyOnTime
-> Printf.sprintf
"UserDontReplyOnTime %d" client
.client_error_count
)
345 (match client
.client_state
with
346 | DcDownloadWaiting file
347 | DcDownloadConnecting
(file
,_
)
348 | DcDownload file
-> file
.file_name
349 | DcUpload
(_
,fd_file
,_
,_
)
350 | DcUploadList fd_file
351 | DcDownloadList fd_file
-> Unix32.filename fd_file
352 | DcUploadListStarting
filename -> filename
353 | DcUploadStarting
(dcsh
,_
,_
) -> dcsh
.dc_shared_codedname
356 if use_html_mods o
then begin
358 \\<tr class=\\\"dl-%d\\\"\\>
359 \\<td class=\\\"sr\\\" \\>%d\\</td\\>
361 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
362 \\<td class=\\\"sr\\\"\\>%s:%d\\</td\\>
363 \\<td class=\\\"sr\\\" \\>%s\\</td\\>
364 \\<td class=\\\"sr\\\" \\>%s\\</td\\>
365 \\<td class=\\\"sr\\\" \\>%s\\</td\\>
366 \\<td class=\\\"sr\\\" \\>%s\\</td\\>\\</tr\\>\n"
367 (html_mods_cntr
()) num
368 (td_command "Rem" "Remove client" ~target
:`Status
369 ["dcremclient"; string_of_int
(client_num
(as_client client
.client_client
))] )
370 name
ip port
state conn error fil
372 Printf.bprintf
buf "[%5d] %25s %25s:%-10d S:%15s C:%15s F:%15s\n"
373 num name
ip port
state conn fil
375 (* Print DC files header *)
376 let dc_file_print_html_header buf =
377 html_mods_table_header
buf "serversTable" "servers" [
378 ( Num
, "srh", "File number", "#" );
379 ( Str
, "srh", "File name/path", "File" );
380 ( Num
, "srh", "File size", "Size" );
381 ( Str
, "srh", "Tiger Tree Hash and magnet url", "TTH and magnet" );
382 ( Num
, "srh", "Files clients number (sources)", "Clients" );
383 ( Num
, "srh", "Autosearches done", "Searches" );
384 ( Str
, "srh", "Find new source by tth", "Find TTH" );
385 ( Str
, "srh", "Find new source by similar name context", "Find similar" ); ];
388 let html_show_tth file size tth
=
389 begin match exn_catch TigerTree.of_string tth
with
393 method name
= Filename.basename file
394 method size
= match size
with 0L -> None
| _
-> Some size
(* do not report size if not available *)
395 method uids
= [TigerTree hash
]
397 Printf.sprintf
"\\<a href=\\\"%s\\\"\\>%s\\</a\\>" (show_magnet_url
magnet) tth
400 let html_show_shared dcsh
=
401 html_show_tth dcsh
.dc_shared_fullname dcsh
.dc_shared_size dcsh
.dc_shared_tiger_root
403 let html_show_file file
=
404 html_show_tth file
.file_name file
.file_file
.impl_file_size file
.file_unchecked_tiger_root
408 let s = String2.replace_char
s char32 char42
in (* to * *)
409 let s = String2.replace_char
s char39 char58
in (* ' to : *)
410 let s = String2.replace_char
s char38 char60
in (* & to < *)
414 String2.replace_char
(translate'
s) char43 char62
(* + to > *)
417 let s = String2.replace_char
s char42 char32
in (* * to *)
418 let s = String2.replace_char
s char58 char39
in (* : to ' *)
419 let s = String2.replace_char
s char60 char38
in (* < to & *)
423 String2.replace_char
(untranslate'
s) char62 char43
(* > to + *)
425 (* print in html or txt list of files *)
426 let file_print file num o
=
427 let buf = o
.conn_buf
in
428 if use_html_mods o
then begin
430 \\<tr class=\\\"dl-%d\\\"\\>
431 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
432 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
433 \\<td class=\\\"srb\\\" \\>%Ld\\</td\\>
434 \\<td class=\\\"srb\\\" \\>%s\\</td\\>
435 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
436 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
439 (html_mods_cntr
()) num file
.file_name file
.file_file
.impl_file_size
440 (html_show_file file
) (List.length file
.file_clients
) file
.file_autosearch_count
441 (td_command "Find TTH" "Find new client for this file by TTH" ["dcfindsource"; file
.file_unchecked_tiger_root
])
442 (td_command "Find similar" "Find new client for this file by similar name" ["dcfindsource"; translate' file
.file_name
])
444 Printf.bprintf
buf "[%5d] %40s %-15Ld %5d\n"
445 num file
.file_name file
.file_file
.impl_file_size
(List.length file
.file_clients
)
447 (* Print DC shared files header *)
448 let dc_shared_print_html_header buf =
449 html_mods_table_header
buf "serversTable" "servers" [
450 ( Num
, "srh", "File number", "#" );
451 ( Str
, "srh", "Shared file name", "Name" );
452 ( Num
, "srh", "Shared file size", "Size" );
453 ( Str
, "srh", "Tiger Tree Hash and magnet url", "TTH and magnet" );
454 (*( Num, "srh", "Shared files Tiger tree array length", "TTree #" );*) ];
458 (* print in html or txt list of shared files *)
459 let shared_print dcsh num o
=
460 let buf = o
.conn_buf
in
461 if use_html_mods o
then begin
463 \\<tr class=\\\"dl-%d\\\"\\>
464 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
465 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
466 \\<td class=\\\"srb\\\" \\>%Ld\\</td\\>
467 \\<td class=\\\"srb\\\" \\>%s\\</td\\>\\</tr\\>\n"
468 (html_mods_cntr
()) num dcsh
.dc_shared_codedname dcsh
.dc_shared_size
469 (html_show_shared dcsh
)
471 Printf.bprintf
buf "[%5d] %40s %-15Ld %24s\n"
472 num dcsh
.dc_shared_codedname dcsh
.dc_shared_size dcsh
.dc_shared_tiger_root
474 (* Print DC filelist header *)
475 let dc_filelist_print_html_header buf =
476 html_mods_table_header
buf "serversTable" "servers" [
477 ( Num
, "srh", "Number", "#" ) ;
478 ( Str
, "srh", "Filelist name", "Filelist" ) ]
480 (* Print one line from filelist *)
481 let filelist_print fname line o
=
482 let buf = o
.conn_buf
in
483 if use_html_mods o
then begin
485 \\<tr class=\\\"dl-%d\\\"\\>
486 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
491 (td_command fname
"Open filelist" ["dcshowfilelist"; fname
])
493 Printf.bprintf
buf "[%5d] %s\n" line fname
496 type dc_int_groups
= G_users
|G_hubs
|G_clients
|G_files
|G_shared
|G_filelists
498 (* register users,clients,files *)
499 let dc_list o group_type group_name
=
500 let buf = o
.conn_buf
in
502 html_mods_cntr_init
();
503 let html f = if use_html_mods o
then f buf else () in
505 begin match group_type
with
507 let new_messages_list = ref [] in (* lets order users with unread messages to the top *)
508 let others_list = ref [] in
509 Hashtbl.iter
(fun _ user
->
510 if user_has_new_messages user
then new_messages_list := user
:: !new_messages_list
511 else others_list := user
:: !others_list
513 html dc_user_print_html_header;
514 List.iter
(fun user
-> user_print user
!num o
; incr
num) !new_messages_list;
515 List.iter
(fun user
-> user_print user
!num o
; incr
num) !others_list;
517 html dc_hub_print_html_header;
518 Hashtbl.iter
(fun _
s -> hub_print s !num o
; incr
num) servers_by_ip
519 (*List.iter (fun s -> hub_print s !num o; incr num) !connected_servers*)
521 html dc_client_print_html_header;
523 (match c.client_name
with
524 | Some n
-> client_print n
c !num o
; incr
num
528 html dc_file_print_html_header;
529 List.iter
(fun file
-> file_print file
!num o
; incr
num) !current_files
;
531 html dc_shared_print_html_header;
532 Hashtbl.iter
(fun _ dcsh
-> shared_print dcsh
!num o
; incr
num) dc_shared_files_by_codedname
534 html dc_filelist_print_html_header;
535 let filelist = Unix2.list_directory filelist_directory
in
536 List.iter
(fun fname
-> filelist_print fname
!num o
; incr
num) filelist;
538 if use_html_mods o
then
539 Printf.bprintf
buf "\\</table\\>\\</div\\>";
541 lprintf_nl "Exception %s in printing %s" (Printexc2.to_string e
) group_name
545 (* Print DC filelist files header *)
546 let dc_filelist_files_print_html_header buf =
547 html_mods_table_header
buf "serversTable" (Printf.sprintf
"servers") [
548 ( Num
, "srh", "Number", "#" );
549 ( Str
, "srh", "File/Directory name", "File/Directory name" );
550 ( Num
, "srh", "File Size", "Size" );
551 ( Str
, "srh", "Files TTH", "TTH" ) ]
553 (* Print one line from filelist file *)
554 let filelist_file_print is_file spaces username dir fname fsize ftth line o
=
555 (* is_file = if true, make the whole filename a link with submit command to load a file
557 username = username to submit in command
558 dir = current directory path to submit in command
559 fname = filename from mylist
560 fsize = filesize from mylist
561 ftth = tth from mylist *)
562 let buf = o
.conn_buf
in
563 if use_html_mods o
then begin
565 \\<tr class=\\\"dl-%d\\\"\\>
566 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
568 \\<td class=\\\"srb\\\" \\>%s\\</td\\>
569 \\<td class=\\\"srb\\\" \\>%s\\</td\\>\\</tr\\>\n"
573 td_command (spaces^fname
) "Start downloading" ~target
:`Status
574 ["dcloadfile"; username
; ftth
; translate dir
; translate fname
; fsize
]
576 Printf.sprintf
"\\<td class=\\\"srb\\\" \\>\\<b\\>%s%s\\</b\\>\\</td\\>" spaces fname
581 Printf.bprintf
buf "%30s %10s %30s\n" fname fsize ftth
584 (* Print DC info header *)
585 let dc_info_html_header buf =
586 html_mods_table_header
buf "sharesTable" "shares" [
587 ( Str
, "srh", "Direct Connect information", "DC Info" ) ;
588 ( Str
, "srh", empty_string
, empty_string
) ]
591 let dc_info_print info data line o
=
592 let buf = o
.conn_buf
in
593 if use_html_mods o
then begin
595 \\<tr class=\\\"dl-%d\\\"\\>
596 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
597 \\<td class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>"
598 (html_mods_cntr
()) info data
600 Printf.bprintf
buf "%s: %s\n" info data
603 let show_dc_buttons o
=
604 let buf = o
.conn_buf
in
605 let button id ?
(cmd
="dc"^id
) ?
(txt=String.capitalize id
) () =
606 Printf.bprintf
buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"%s\\\" name=\\\"%s\\\"
607 action=\\\"javascript:parent.output.location.href='submit?q=%s'\\\"\\>
608 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
609 Value=\\\"%s\\\"\\>\\</td\\>\\</form\\>" id id cmd
txt
611 if use_html_mods o
then
613 Printf.bprintf
buf "\\<table\\>\\<tr\\>";
614 button "users" ~cmd
:"dcusers+all" ();
615 button "clients" ~cmd
:"dcclients" ();
619 button "info" ~
txt:"DC Info" ();
620 button "hublistshow" ~cmd
:"dchublist" ~
txt:"Show hublist" ();
621 button "filelists" ();
622 Printf.bprintf
buf "\\</tr\\>\\</table\\>";
625 (* List of commands to register *)
628 "dc", Arg_none
(fun o
->
629 if use_html_mods o
then
632 Printf.bprintf
buf "Try `?? dc` for more commands\n";
633 dc_list o G_hubs
"hubs"
634 ), ": Show Direct Connect buttons";
636 (* 'dcn address [port]' Add a new DC server with optional port (default 411) *)
637 "dcn", Arg_multiple
(fun args o
->
640 | [ip ; port
] -> ip, port
642 | _
-> failwith
"dcn <ip> [<port>]: bad argument number" )
644 let ip_addr = Ip.addr_of_string
ip in
645 Ip.async_ip_of_addr
ip_addr (fun t
-> (* do DNS check here *)
646 let port = int_of_string
port in
647 if !verbose_msg_servers
then lprintf_nl "New server being added: (%s) (%s) (%d)" ip (Ip.to_string t
) port;
648 if (Ip.valid t
) && (port>0) && (port<65536) then
649 ignore
(new_server
ip_addr t
port) ) (fun _
-> ());
651 ), "<ip> [<port>] : Add a server. Default port number is 411";
653 (* List connected hubs for chatting *)
654 "dchubs", Arg_none
(fun o
-> show_dc_buttons o
; dc_list o G_hubs
"hubs"
655 ), ": Show connected DC hubs";
657 (* List all DC users *)
658 "dcusers", Arg_one
(fun args o
->
660 let buf = o
.conn_buf
in
662 | "all" -> dc_list o G_users
"users"
665 let s = Hashtbl.find servers_by_ip
ip in
667 let new_messages_list = ref [] in (* lets order users with unread messages to the top *)
668 let others_list = ref [] in
669 List.iter
(fun user
->
670 if user_has_new_messages user
then new_messages_list := user
:: !new_messages_list
671 else others_list := user
:: !others_list
673 dc_user_print_html_header buf;
674 List.iter
(fun user
-> user_print user
!num o
; incr
num) !new_messages_list;
675 List.iter
(fun user
-> user_print user
!num o
; incr
num) !others_list;
677 with _
-> "dcusers <ip> : ip not valid" ) );
678 ), "<all>|<ip> :Show DC users";
680 (* List all DC clients *)
681 "dcclients", Arg_none
(fun o
-> show_dc_buttons o
; dc_list o G_clients
"clients"
682 ), ": Show all DC clients";
684 (* List all DC files *)
685 "dcfiles", Arg_none
(fun o
-> show_dc_buttons o
; dc_list o G_files
"files"
686 ), ": Show all DC files";
688 (* List all DC shared files *)
689 "dcshared", Arg_none
(fun o
-> show_dc_buttons o
; dc_list o G_shared
"shared"
690 ), ": Show all DC shared files. All/Hashed ";
692 (* 'dchublist [args]' - Show dchub list with optional filters args (max 5) *)
693 "dchublist", Arg_multiple
(fun args o
->
695 let buf = o
.conn_buf
in
696 let filter = ref [] in
697 let print_hublist () =
698 if use_html_mods o
then
700 html_mods_table_one_row
buf "serversTable" "servers" [
701 (empty_string
, "srh", Printf.sprintf
"Showing hublist"); ];
702 Printf.bprintf
buf "\\</table\\>\\</div\\>"
705 Printf.bprintf
buf "Showing hublist";
706 html_mods_cntr_init
();
707 let nb_hubs = ref 0 in
708 if use_html_mods o
then dc_hublist_print_html_header buf empty_string
;
709 let show_all = if (!filter = []) then true else false in
711 let hub_has_string searched
=
712 if String2.contains
(Ip.string_of_addr h
.dc_ip
) searched
||
713 String2.contains
(string_of_int h
.dc_port
) searched
||
714 String2.contains h
.dc_info searched
||
715 String2.contains h
.dc_name searched
then true
719 hublist_print h
!nb_hubs o
;
722 if !verbose_msg_servers
then
723 lprintf_nl "Exception %s in hub_print\n" (Printexc2.to_string e
))
729 let print = ref false in
730 let finished = ref false in
731 let counter = ref 0 in
732 let filters_length = List.length
!filter in
733 while (!print = false) && (!finished = false) do
734 if (!counter = filters_length) || (!counter > 5) then
737 if (hub_has_string (List.nth
!filter !counter)) then print := true;
740 if (!print = true) then print_hub ()
743 let txt = if show_all then "(showing all hubs from hublist)" else "(filtered)" in
744 if use_html_mods o
then
746 Printf.bprintf
buf "\\</table\\>\\</div\\>";
747 html_mods_table_one_row
buf "serversTable" "servers" [
748 (empty_string
, "srh", Printf.sprintf
"Hubs: %d known %s" !nb_hubs txt); ]
751 Printf.bprintf
buf "Hubs: %d known %s" !nb_hubs txt
755 | rest_args
-> filter := rest_args
759 ), "[filtertext]: dchublist fin - filters hubs with text fin";
761 (* 'dcuserip name' query user-ip from hub *)
762 "dcuserip", Arg_multiple
(fun args o
->
763 let buf = o
.conn_buf
in
765 | [hub
; port ; name
] ->
767 let s = Hashtbl.find servers_by_ip hub
in
768 (match s.server_sock
with
769 | Connection sock
-> dc_send_msg sock
( UserIPReq
( [name
] ))
772 if !verbose_unexpected_messages
then
773 lprintf_nl "dcuserip: No server found by ip (%s) (%s) (%s)" hub
port name
)
774 | _
-> if !verbose_unexpected_messages
then lprintf_nl "dcuserip: Invalid args count (%d)" (List.length args
) );
775 Printf.bprintf
buf "User query sent to hubs\n";
777 ), "<user> : Query users ip from hub";
779 "dcmsglog", Arg_multiple
(fun args o
->
780 let buf = o
.conn_buf
in
781 let counter = ref 0 in
782 let messages,name
,topic
=
784 | delay
:: ip :: port :: _
->
786 let s = Hashtbl.find servers_by_ip
ip in
788 (match s.server_sock
with
789 | Connection _
-> s.server_topic
790 | _
-> "NOT CONNECTED TO SERVER" )
792 s.server_read_messages
<- List.length
s.server_messages
; (* messages are set as read before *)
793 s.server_messages
, (* they are actually printed to user *)
794 (shorten_string
s.server_name
50),
797 if !verbose_unexpected_messages
then lprintf_nl "dcmsglog: No server with address found";
801 let u = search_user_by_name n
in
802 let connected = ((List.length
u.user_servers
) > 0) in
803 u.user_read_messages
<- List.length
u.user_messages
; (* messages are set as read before *)
804 u.user_messages
, u.user_nick
, (* they are actually printed to user *)
805 (if connected then empty_string
806 else "User not connected to any servers at the moment...")
808 if !verbose_unexpected_messages
then lprintf_nl "dcmsglog: No user found";
811 if !verbose_unexpected_messages
then lprintf_nl "dcmsglog: Invalid args count (%d)" (List.length args
);
814 if use_html_mods o
then begin
815 Printf.bprintf
buf "\\<div class=\\\"messages\\\"\\>";
816 Printf.bprintf
buf "\\<div\\>Chatting with \\<b\\>%s\\</b\\> - %d logged messages\\</div\\>"
817 name
(List.length
messages);
818 Printf.bprintf
buf "\\<div\\>\\<i\\>%s\\</i\\>\\</div\\>" topic
820 Printf.bprintf
buf "%d logged messages\n" (List.length
messages);
821 if use_html_mods o
then html_mods_table_header
buf "serversTable" "servers" [
822 ( Str
, "srh", "Timestamp", "Time" );
823 ( Str
, "srh", "Who message is from", "From" );
824 ( Str
, "srh", "Message text", "Message" ) ];
825 List.iter
(fun (t
,f,m
) ->
828 | PrivateMessage
(_
, msg) -> msg
829 | PublicMessage
(_
, msg) -> msg
830 | ServerMessage
msg -> msg )
832 if use_html_mods o
then begin
833 Printf.bprintf
buf "\\<tr class=\\\"%s\\\"\\>"
834 (if (!counter mod 2 == 0) then "dl-1" else "dl-2");
836 (empty_string
, "sr", Date.simple
(BasicSocket.date_of_int t
));
837 (empty_string
, "sr", f);
838 (empty_string
, "srw", String2.replace
msg '
\r'
"\\<br/\\>") ];
839 Printf.bprintf
buf "\\</tr\\>"
841 Printf.bprintf
buf "\n%s [%s] : %s\n" (Date.simple
(BasicSocket.date_of_int t
)) f msg
845 if use_html_mods o
then Printf.bprintf
buf "\\</table\\>\\</div\\>\\</div\\>";
847 ), "<refresh> <user> | <refresh> <serverip> <serverport>";
849 "dcmessages", Arg_multiple
(fun args o
->
851 let buf = o
.conn_buf
in
856 let s = Hashtbl.find servers_by_ip
ip in
859 if !verbose_unexpected_messages
then lprintf_nl "dcmessages: No server with address found";
863 let u = search_user_by_name n
in
866 if !verbose_unexpected_messages
then lprintf_nl "dcmessages: No user found";
869 if !verbose_unexpected_messages
then lprintf_nl "dcmessages: No user or server";
872 if use_html_mods o
then begin
873 Printf.bprintf
buf "\\<script type=\\\"text/javascript\\\"\\>
875 function submitCmd() {
876 var formID = document.getElementById(\\\"msgForm\\\")
877 parent.output.location.href='submit?q=dcmessages+'+encodeURIComponent(formID.sendCmd.value)
879 function submitMessageForm() {
880 var formID = document.getElementById(\\\"msgForm\\\")
881 var msgTextOut = encodeURIComponent(formID.msgText.value)
882 var msgUserOut = encodeURIComponent(formID.sendCmd.value)
883 parent.fstatus.location.href='submit?q=dcsendmsg+'+msgUserOut+\\\"+\\\"+msgTextOut
884 formID.msgText.value=\\\"\\\"
885 msgWindow.location.reload();
889 let sendmsg,namelist
,first
=
892 let ip,port = (Ip.to_string
s.server_ip
),(string_of_int
s.server_port
) in
893 command ["dcmsglog";"20";ip;port], s.server_users
, Printf.sprintf
"%s %s" ip port
897 command ["dcmsglog";"20";u.user_nick
], [], u.user_nick
899 if !verbose_unexpected_messages
then lprintf_nl "dcmessages: No user or server";
903 Printf.bprintf
buf "\\<iframe id=\\\"msgWindow\\\" name=\\\"msgWindow\\\" height=\\\"80%%\\\"
904 width=\\\"100%%\\\" scrolling=yes src=\\\"submit?q=%s\\\"\\>\\</iframe\\>" sendmsg;
905 Printf.bprintf
buf "\\<form style=\\\"margin: 0px;\\\" name=\\\"msgForm\\\" id=\\\"msgForm\\\" action=\\\"javascript:submitMessageForm()\\\"\\>";
906 Printf.bprintf
buf "\\<table width=100%% cellspacing=0 cellpadding=0 border=0\\>\\<tr\\>\\<td\\>";
907 Printf.bprintf
buf "\\<select style=\\\"font-family: verdana; font-size: 12px; width: 150px;\\\" id=\\\"sendCmd\\\" name=\\\"sendCmd\\\" \\>";
908 Printf.bprintf
buf "\\<option value=\\\"%s\\\"\\>%s" first first
;
910 if not
(has_my_nick
u) then
911 Printf.bprintf
buf "\\<option value=\\\"%s\\\"\\>%s" u.user_nick
u.user_nick
913 Printf.bprintf
buf "\\</select\\>\\</td\\>";
914 Printf.bprintf
buf "\\<td width=100%%\\>\\<input style=\\\"width: 99%%; font-family: verdana; font-size: 12px;\\\"
915 type=text id=\\\"msgText\\\" name=\\\"msgText\\\" size=50 \\>\\</td\\>";
916 Printf.bprintf
buf "\\<td\\>\\<input style=\\\"font-family: verdana;
917 font-size: 12px;\\\" type=submit value=\\\"Send\\\"\\>\\</td\\>\\</form\\>";
918 Printf.bprintf
buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"refresh\\\" name=\\\"refresh\\\"
919 action=\\\"javascript:msgWindow.location.reload();\\\"\\>
920 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
921 Value=\\\"Refresh\\\"\\>\\</td\\>\\</form\\>\\</tr\\>\\</table\\>";
922 Printf.bprintf
buf "\\<table\\>\\<tr\\>\\<form style=\\\"margin: 0px;\\\" id=\\\"users\\\" name=\\\"users\\\"
923 action=\\\"javascript:parent.output.location.href='submit?q=dcusers'\\\"\\>
924 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
925 Value=\\\"Users\\\"\\>\\</td\\>\\</form\\>";
926 Printf.bprintf
buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"hubs\\\" name=\\\"hubs\\\"
927 action=\\\"javascript:parent.output.location.href='submit?q=dchubs'\\\"\\>
928 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
929 Value=\\\"Hubs\\\"\\>\\</td\\>\\</form\\>";
930 Printf.bprintf
buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"hubs\\\" name=\\\"hubs\\\"
931 action=\\\"javascript:submitCmd()\\\"\\>
932 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
933 Value=\\\"Open chat\\\"\\>\\</td\\>\\</form\\>";
934 Printf.bprintf
buf "\\</tr\\>\\</table\\>";
937 _s
"Usage: dcmessages <username> | <serverip> <serverport>\n"
938 ), "<username> | <serverip> <serverport> : Show user or server messages ";
941 (* message type = (int * room_message) list
942 room_message type = | ServerMessage of string
943 | PublicMessage of int * string
944 | PrivateMessage of int * string *)
945 (* 'dcsendmsg hub port user message' - send message to specific user *)
946 "dcsendmsg", Arg_multiple
(fun args o
->
947 let buf = o
.conn_buf
in
948 (*let failtxt = "dcsendmsg <user> <message> | <serverip> <serverport> <message> : bad arguments" in*)
949 let u = (* check if first argument is valid user *)
951 let u = search_user_by_name
(List.hd args
) in
957 let s = Hashtbl.find servers_by_ip
(List.hd args
) in
962 | Some
u -> (* message is private usermessage *)
965 if not
(has_my_nick
u) && ((List.length
u.user_servers
) > 0) then begin
966 let sent = ref false in
967 List.iter
(fun s -> (* find a server we are connected to with this user *)
968 (match s.server_sock
with
970 if not
!sent then begin
971 let msg = String2.unsplit
messages ' '
in
973 ToReq
{ To.dest
= u.user_nick
;
974 To.from
= s.server_last_nick
;
975 To.message
= msg } );
977 u.user_messages
<- u.user_messages
@ [
978 (int_of_float
(current_time
()), s.server_last_nick
, PrivateMessage
(0, msg))];
985 (match s with (* message is probably hub chatmessage but check ip *)
986 | None
-> if !verbose_unexpected_messages
then lprintf_nl "dcsendmsg: No User or Server found"
989 | _
:: _
:: messages ->
990 (match s.server_sock
with
992 let msg = String2.unsplit
messages ' '
in
993 dc_send_msg sock
( MessageReq
{ Message.from
= s.server_last_nick
; Message.message
= msg } );
994 (* don't save this message, it is echoed from hub back to us and saved then *)
995 (* message window is refreshed too quickly to show this *)
1000 Printf.bprintf
buf "User query sent to hubs\n";
1002 ), "<user> <message> : Send message to user";
1004 (* Try to load file from filelist *)
1005 "dcloadfile", Arg_multiple
(fun args o
->
1006 let buf = o
.conn_buf
in
1008 | [uname
; tth
; dir
; fname
; fsize
] -> (* convert filenames back to normal *)
1009 if !verbose_download
then lprintf_nl "dcloadfile: (%s) (%s) (%s)" dir fname tth
;
1010 Printf.bprintf
buf "Trying to download file: %s from user: %s\n" fname uname
;
1012 let u = search_user_by_name uname
in
1013 let user = o
.conn_user
.ui_user
in
1014 let (_
: _
option) = start_new_download (Some
u) tth
(untranslate dir
) (untranslate fname
) (Int64.of_string fsize
) user user.user_default_group
in
1016 with _
-> if !verbose_download
then lprintf_nl "dcloadfile: No user found" )
1018 if !verbose_unexpected_messages
then
1019 lprintf_nl "dcloadfile: bad arguments count (%d)" (List.length args
) );
1021 ), "<username> <tth> <directory> <filename> : Load a file";
1023 (* load filelist from user *)
1024 "dcloadfilelist", Arg_one
(fun args o
->
1025 let buf = o
.conn_buf
in
1029 let u = search_user_by_name name
in
1030 if ((List.length
u.user_servers
) > 0) then begin
1031 if not
(filelist_already_downloading
u) then begin (* and is connected to server with us *)
1032 if !verbose_msg_clients
|| !verbose_download
then
1033 lprintf_nl "Loading filelist from user %s" name
; (* not already loading filelist *)
1034 let c = new_client
() in
1035 c.client_name
<- Some
u.user_nick
;
1036 add_client_to_user
c u;
1037 c.client_state
<- DcDownloadListWaiting
;
1038 if (can_user_start_downloading
u) then begin
1039 u.user_state
<- TryingToSendFirstContact
;
1040 c.client_state
<- DcDownloadListConnecting
(0,!!firewalled
,current_time
()); (* level is set later *)
1041 ignore
(DcClients.try_connect_client
c);
1046 if !verbose_unexpected_messages
then lprintf_nl "dcloadfilelist: No user (%s) found" name
) );
1047 Printf.bprintf
buf "Trying to download filelist\n";
1049 ), "<name> : Download filelist from user";
1051 "dcfilelists", Arg_none
(fun o
-> show_dc_buttons o
; dc_list o G_filelists
"filelists"
1052 ), ": List all filelists on disk";
1054 "dcremclient", Arg_one
(fun args o
->
1055 let buf = o
.conn_buf
in
1059 let cc = CommonClient.client_find
(int_of_string
num) in
1060 let impl = as_client_impl
cc in
1061 let c = impl.impl_client_val
in
1062 (match c.client_state
with
1063 | DcDownloadWaiting _
| DcDownloadListWaiting
->
1064 Printf.bprintf
buf "Removing one client by name %s" (clients_username
c);
1068 if !verbose_msg_clients
then lprintf_nl "dcremclient: bad arguments (internal command)" ) );
1070 ), "<num> : Remove client by num";
1072 "dcfindsource", Arg_one
(fun args o
->
1074 | tth_or_filename
->
1075 (*lprintf_nl "Got dcfindsource command: (%s)" tth_or_filename;*)
1076 let tth_or_filename = untranslate'
tth_or_filename in
1077 if (is_valid_tiger_hash
tth_or_filename) then begin
1078 let query = QAnd
(QHasField
(Field_Type
, "TTH") , (QHasWord
tth_or_filename)) in
1079 let search = CommonSearch.new_search o
.conn_user
1080 (let module G
= GuiTypes
in
1082 G.search_query
= query;
1083 G.search_max_hits
= 10000;
1084 G.search_type
= RemoteSearch
;
1085 G.search_network
= network
.network_num
;
1088 dc_with_connected_servers
(fun s -> DcClients.server_send_search
s search 9 tth_or_filename);
1089 dc_last_manual_search
:= current_time
();
1091 let fname = Filename.basename
tth_or_filename in
1092 let words = clean_string
fname in
1093 let words_list = String2.split_simplify
words ' '
in
1094 let rec add_query list
=
1096 | hd
:: [] -> QHasWord hd
1097 | hd
:: tail
-> QAnd
((QHasWord hd
) , (add_query tail
))
1098 | [] -> failwith
"No words to search")
1100 let query = add_query words_list in
1101 let search = CommonSearch.new_search o
.conn_user
1102 (let module G
= GuiTypes
in
1104 G.search_query
= query;
1105 G.search_max_hits
= 10000;
1106 G.search_type
= RemoteSearch
;
1107 G.search_network
= network
.network_num
;
1110 dc_with_connected_servers
(fun s -> DcClients.server_send_search
s search 1 tth_or_filename);
1111 dc_last_manual_search
:= current_time
();
1114 ), ": Find new source for a file";
1116 "dcinfo", Arg_none
(fun o
->
1118 let buf = o
.conn_buf
in
1123 shorten_string
s.server_name
20 ^
" (nick = " ^
s.server_last_nick ^
") (uptime = " ^
1124 (Date.time_to_string
(int_of_float
(current_time
()) -
1125 int_of_float
(s.server_connection_time
)) "verbose") ^
1126 (string_of_int
(List.length
s.server_users
)) ^
")"
1128 lst := !lst @ [ (empty_string
, data) ]
1129 ) !connected_servers
;
1132 let norm_hubs,reg_hubs
,opped_hubs
= get_myhubs_info
() in
1133 html_mods_cntr_init
();
1134 if use_html_mods o
then dc_info_html_header buf;
1135 let nservers = List.length
!connected_servers
in
1137 [ Printf.sprintf
"%d files" (Hashtbl.length dc_shared_files_by_hash
) ] @
1138 match !dc_files_to_hash
with [] -> [] | l
-> [ Printf.sprintf
"%d queued" (List.length l
) ] @
1139 match !dc_tiger_computing
with
1140 | Some dcsh
when dcsh
.dc_shared_size
> 0L ->
1141 let progress = Int64.to_float dcsh
.dc_shared_pos
/. Int64.to_float dcsh
.dc_shared_size
*. 100. in
1142 [ Printf.sprintf
"hashing: %s (%3.0f%%)" (Filename.basename dcsh
.dc_shared_fullname
) progress ]
1146 ("Hub supports", (DcProtocol.Supports.create_supports_string
(HubSupports mldonkey_dc_hub_supports
)) );
1147 ("Client supports", (DcProtocol.Supports.create_supports_string
(ClientSupports mldonkey_dc_client_supports
)) );
1148 ("All/Open slots", Printf.sprintf
"%d / %d" (open_slots
()) (current_slots
()) );
1149 ("Mode", (if !!firewalled
then "Passive" else "Active") );
1150 ("Connected servers", (if nservers > 0 then string_of_int
nservers else ""));
1151 (" Server list:", empty_string
); ]
1153 ("Hubs", (Printf.sprintf
"Normal:%d Vipped:%d Opped:%d" norm_hubs reg_hubs opped_hubs
) );
1154 ("Hashed", String.concat
", " hashed);
1156 let counter = ref 0 in
1157 List.iter
(fun (info
,data) ->
1158 dc_info_print info
data line o
;
1161 if use_html_mods o
then Printf.bprintf
buf "\\</table\\>\\</div\\>";
1163 ), ": Direct Connect info";
1165 (* load filelist from user *)
1166 "dcshowfilelist", Arg_one
(fun args o
->
1168 let buf = o
.conn_buf
in
1171 let username, extension
=
1173 if (Filename.check_suffix
filename mylist_ext
) then (* if extension is DcLst ... *)
1174 Filename.chop_suffix
filename mylist_ext
,mylist_ext
(* return filename without it and ext *)
1175 else if (Filename.check_suffix
filename bz2_ext
) then begin (* else if extension is bz2 ... *)
1176 let filename = Filename.chop_suffix
filename bz2_ext
in (* chop it off *)
1177 if (Filename.check_suffix
filename xml_ext
) then (* check if there is extension xml ...*)
1178 Filename.chop_suffix
filename xml_ext
,mylistxmlbz2_ext
(* return filename without it and ext *)
1179 else raise Not_found
1180 end else raise Not_found
1181 with _
-> filename, empty_string
)
1183 let spaces num = (* add as many "...":s to string that counter num *)
1186 if (num <> 0) then begin
1193 if (extension
= mylist_ext
) then begin (* parse MyList.DcLst *)
1195 let s = file_to_che3_to_string
(Filename.concat filelist_directory
filename) in
1196 if not
(Charset.is_utf8
s) then lprintf_nl "not utf8 : %S" s;
1197 let s = Charset.Locale.to_utf8
s in (* really needed? *)
1198 let s = String2.replace_char
s char13 '
\n'
in
1200 let lines = String2.split_simplify
s '
\n'
in
1201 let mlist = ref ([] : dc_mylistnode
list) in (* root node of the MyList *)
1202 let tablist = ref [(-1, mlist)] in (* list of previous open directory node for every tab *)
1203 (* [(0 , list ref); (1 , list ref) ... *)
1204 let rec count_tabs line pos
= (* count current lines tabs *)
1205 if line
.[pos
] <> '
\t'
then pos
else
1206 count_tabs line
(pos
+1)
1208 let add_dir name tabs
list =
1209 let newlist = ref ([] : dc_mylistnode
list) in
1210 list := !list @ [MylistDirectory
(name
, newlist)]; (* add this dir node to current list *)
1211 if (List.mem_assq tabs
!tablist) then begin (* check if a directory exists already for this tab *)
1212 tablist := List.remove_assq tabs
!tablist; (* remove existing previous tab *)
1214 tablist := !tablist @ [(tabs
, newlist)]; (* add current list to this tab *)
1216 let add_file name size
list =
1217 list := !list @ [MylistFile
(name
, size
)]; (*add this file to current node *)
1219 let find_tab_dir tabs
= (* find the node of last directory for this tab *)
1220 let nlist = List.assq tabs
!tablist in
1221 nlist (* return list ref *)
1223 let rec parse lines ctabs clist
=
1226 let ltabs = count_tabs first
0 in (* count lines tabs *)
1227 (match (String2.split first '
|'
) with
1228 | dir
:: [] -> (* if line is directory *)
1229 let dir = String2.after
dir ltabs in
1230 if ltabs = ctabs
then begin
1231 let nlist = find_tab_dir (ltabs-1) in
1232 add_dir dir ltabs nlist;
1233 if (tail
<> []) then begin
1234 let nlist = find_tab_dir ltabs in
1235 parse tail
ltabs nlist
1237 end else if ltabs > ctabs
then begin
1238 add_dir dir ltabs clist
;
1239 let nlist = find_tab_dir ltabs in
1240 if (tail
<> []) then parse tail
ltabs nlist
1242 let nlist = find_tab_dir ltabs in
1243 parse lines ltabs nlist
1245 | name
:: size
:: [] -> (* if line is file *)
1246 let name = String2.after
name ltabs in
1247 if ltabs > ctabs
then begin
1248 add_file name size clist
;
1249 if (tail
<> []) then parse tail ctabs clist
1250 end else if ltabs <= ctabs
then begin
1251 let nlist = find_tab_dir (ltabs-1) in
1252 add_file name size
nlist;
1253 parse tail
(ltabs-1) nlist
1255 | _
-> failwith
(Printf.sprintf
"Unknown line (%s)" first
) )
1258 parse lines (pred
0) mlist;
1260 html_mods_cntr_init
();
1262 if use_html_mods o
then dc_filelist_files_print_html_header buf;
1263 let rec print node
dir tabs
=
1266 | MylistFile
(name, size
) ->
1267 filelist_file_print true (spaces tabs
) username dir name size empty_string
!line o
;
1268 (*lprintf_nl "(%s) (%s)" (!spaces ^ name) (Int64.to_string size);*)
1269 | MylistDirectory
(name, nlist) ->
1271 if dir = "" then name
1272 else dir ^
"/" ^
name
1274 filelist_file_print false (spaces tabs
) username dir name empty_string empty_string
!line o
;
1275 (*lprintf_nl "(%s) list_count=(%d)" (!spaces ^ dir) (List.length !nlist);*)
1277 List.iter (fun node
-> print node
dir (tabs
+1)) !nlist )
1279 List.iter (fun node
-> print node empty_string
0) !mlist;
1280 if use_html_mods o
then Printf.bprintf
buf "\\</table\\>\\</div\\>";
1282 if !verbose_unexpected_messages
then
1283 lprintf_nl "dcshowfilelist: (%s) in .DcLst parsing" (Printexc2.to_string e
) )
1284 with _
-> if !verbose_unexpected_messages
then lprintf_nl "Error in che3 decompressing" )
1286 end else if (extension
= mylistxmlbz2_ext
) then begin (* parse .xml.bz2 *)
1287 (try (* try to unzip *)
1288 let s = Buffer.contents
(file_to_bz2_to_buffer
(Filename.concat filelist_directory
filename)) in
1289 (try (* try to parse xml and make a www page *)
1290 let xml = Xml.parse_string
s in
1291 let parse_xml_chars s = (* in xml there are html-escapes mixed in *)
1292 let s = dc_replace_str_to_str
s "&" "&" in
1295 if ((Xml.tag
xml) <> "FileListing") then failwith
"Xml-file don't start with FileListing";
1296 html_mods_cntr_init
();
1298 if use_html_mods o
then dc_filelist_files_print_html_header buf;
1299 let rec parse x
dir ndirs
= (* iterate this with all xml elements (one node with tag and attributes *)
1300 let tag = Xml.tag x
in
1302 if tag = "File" then dir (* if tag of element is file, return existing dir name *)
1303 else begin (* else this is "probably" a directory *)
1304 let newdir = Xml.attrib x
"Name" in (* get dir name *)
1305 if dir = "" then newdir (* if this is first dir to add, don't add the "/" *)
1306 else dir ^
"/" ^
newdir (* else add this new dir path name to existing dir *)
1310 | "File" -> (* is this xml element is a file element, add its line to http-page *)
1311 let fname = Xml.attrib x
"Name" in
1312 let fname = parse_xml_chars fname in
1313 let fsize = Xml.attrib x
"Size" in
1314 let ftth = Xml.attrib x
"TTH" in
1316 filelist_file_print true (spaces ndirs
) username dir fname fsize ftth !line o
;
1317 | "Directory" -> (* or if it is a directory element, add its line to http-page *)
1318 let fname = Xml.attrib x
"Name" in
1319 let fname = parse_xml_chars fname in
1320 let fsize = empty_string
in
1321 let ftth = empty_string
in
1323 filelist_file_print false (spaces ndirs
) username dir fname fsize ftth !line o
;
1324 | _
-> failwith
"Tag not File or Directory" );
1326 Xml.iter (fun x
-> parse x
dir (ndirs
+1)) x
1328 Xml.iter (fun x
-> parse x empty_string
0) xml;
1329 if use_html_mods o
then Printf.bprintf
buf "\\</table\\>\\</div\\>";
1331 | Error e
-> if !verbose_unexpected_messages
then lprintf_nl "%s" (Xml.error e
)
1332 | e
-> if !verbose_unexpected_messages
then
1333 lprintf_nl "dcshowfilelist: (%s) in xml parsing" (Printexc2.to_string e
) )
1334 with _
-> if !verbose_unexpected_messages
then lprintf_nl "Error in bz2 unzipping" )
1335 end else if !verbose_unexpected_messages
then lprintf_nl "dcshowfilelist: Filelist extension not valid" );
1337 ), "<name> : Show filelist for user";
1339 "dcautoconnect", Arg_two
(fun arg1 arg2 o
->
1342 let s = Hashtbl.find servers_by_ip arg2
in
1343 let auto = bool_of_string arg1
in
1344 s.server_autoconnect
<- auto;
1345 server_must_update
s;
1347 with exn
-> Printf.sprintf
"Failed : %s" (Printexc2.to_string exn
)
1348 ), "<true/false> <ip> : Set/unset the server autoconnection state";
1350 ] (* end of let commands = *)
1354 (* register user operations *)
1356 register_commands commands;
1358 user_ops
.op_user_info
<- (fun user -> (* CHECK *)
1360 P.user_num
= user.user_user
.impl_user_num
;
1361 P.user_md4
= Md4.null
;
1362 P.user_name
= user.user_nick
;
1363 P.user_ip
= Ip.null
;
1367 if user.user_data
> 1. then
1368 [ { tag_name
= Field_UNKNOWN
"link"; tag_value
= String
user.user_link
};
1369 { tag_name
= Field_UNKNOWN
"shared"; tag_value
= String
(
1370 Printf.sprintf
"%12.0f" user.user_data
) } ]
1373 (match user.user_type
with
1374 | Normal
| Vip
-> list
1375 | Op
-> { tag_name
= Field_UNKNOWN
"admin"; tag_value
= String
"admin" } :: list ) );
1377 (match user.user_servers
with
1379 | s :: _ -> s.server_server
.impl_server_num
);
1382 user_ops
.op_user_remove
<- (fun user -> () )
1384 user_ops.op_user_browse_files <- (fun user ->
1385 let c = client_of_user user in
1386 contact_add (as_client c.client_client)
1388 user_ops.op_user_set_friend <- (fun user ->
1389 let c = client_of_user user in
1390 friend_add (as_client c.client_client)
1393 mutable op_user_network : network;
1394 mutable op_user_set_friend : ('a -> unit);
1395 mutable op_user_browse_files : ('a -> unit);
1400 (*module C = CommonTypes
1402 result_ops.op_result_info <- (fun r ->
1404 C.result_num = r.result_result.impl_result_num;
1405 C.result_network = network.network_num;
1407 C.result_names = [r.result_name];
1408 C.result_md4 = Md4.null;
1409 C.result_size = r.result_size;
1410 C.result_format = result_format_of_name r.result_name;
1411 C.result_type = result_media_of_name r.result_name;
1413 C.result_comment = "";
1414 C.result_done = false;
1420 (* register file operations *)
1422 file_ops
.op_file_info
<- (fun file
->
1424 P.file_fields
= Fields_file_info.all
;
1425 P.file_comment
= empty_string
;
1426 P.file_name
= file
.file_name
;
1427 P.file_num
= (file_num file
);
1428 P.file_network
= network
.network_num
;
1429 P.file_names
= [file
.file_name
];
1430 P.file_md4
= Md4.null
;
1431 P.file_size
= file_size file
;
1432 P.file_downloaded
= file_downloaded file
;
1433 P.file_all_sources
= 0;
1434 P.file_active_sources
= 0;
1435 P.file_state
= file_state file
;
1436 P.file_sources
= None
;
1437 P.file_download_rate
= file_download_rate file
.file_file
;
1438 P.file_chunks
= None
;
1439 P.file_chunk_size
= None
;
1440 P.file_availability
= [network
.network_num
, "0"];
1441 P.file_format
= FormatUnknown
;
1442 P.file_chunks_age
= [|0|];
1443 P.file_age
= file_age file
;
1444 P.file_last_seen
= BasicSocket.last_time
();
1445 P.file_priority
= file_priority
(as_file file
.file_file
);
1447 P.file_sub_files
= [];
1448 P.file_comments
= [];
1449 P.file_magic
= None
;
1450 P.file_user
= empty_string
;
1451 P.file_group
= empty_string
;
1452 P.file_release
= false;
1455 file_ops
.op_file_all_sources
<- (fun file
->
1456 List2.tail_map
(fun c -> as_client
c.client_client
)
1459 file_ops
.op_file_active_sources
<- file_ops
.op_file_all_sources
;
1460 file_ops
.op_file_cancel
<- (fun file
->
1461 let remove_files_clients_not_downloading () =
1463 (match c.client_state
with
1464 | DcDownload
f -> () (* only one client should be in this state *)
1467 ) file
.file_clients
;
1470 List.iter (fun c -> (* find one files client that is currently downloading *)
1471 (match c.client_state
with
1472 | DcDownload
_ -> raise
(Found_client
c)
1474 ) file
.file_clients
;
1477 | Found_client
c -> (* found a download slot tried to continue *)
1478 (match (DcClients.find_next_client
c) with (* try to continue slot *)
1480 (match c.client_sock
with
1481 | Connection sock
->
1482 remove_files_clients_not_downloading ();
1483 remove_file_not_clients file
;
1484 c.client_receiving
<- Int64.zero
;
1485 c.client_pos
<- Int64.zero
;
1486 TcpBufferedSocket.set_rtimeout sock
30.;
1487 DcClients.next_download
false c sock cl
(* try to change downloading *)
1490 remove_files_clients_not_downloading ();
1491 remove_file_not_clients file
;
1492 c.client_state
<- DcIdle
;
1493 (match c.client_sock
with
1494 | Connection sock
-> TcpBufferedSocket.close sock
(Closed_for_error
"File cancelled")
1498 remove_file_with_clients file
);
1499 if !verbose_download
then lprintf_nl "File %s cancelled" file
.file_name
;
1501 file_ops
.op_file_commit
<- (fun file
name ->
1502 remove_file_with_clients file
;
1504 file_ops
.op_file_pause
<- (fun file
->
1507 (match c.client_state
with
1508 | DcDownload
f -> if file
== f then raise
(Found_client
c)
1510 ) file
.file_clients
;
1514 (match (DcClients.find_next_client
c) with (* try to continue slot *)
1516 (match c.client_sock
with
1517 | Connection sock
->
1518 DcClients.next_download
true c sock cl
(* try to change downloading *)
1520 | None
-> c.client_state
<- DcIdle
(* DcPaused ? *))
1521 | Not_found
-> () ) (* Should not happen *)
1525 file_ops.op_file_files <- (fun file impl ->
1526 match file.file_swarmer with
1527 None -> [CommonFile.as_file impl]
1529 CommonSwarming.subfiles swarmer)
1532 file_ops.op_file_save_as <- (fun file new_name ->
1533 match file_state file with
1534 FileDownloaded | FileShared ->
1535 DcClients.save_file_as file new_name
1540 (*let client_of_user user =
1541 let c = new_client user.user_nick in
1547 mutable op_file_network : network; *)
1548 file_ops
.op_file_save_as
<- (fun _ _ -> ());
1549 file_ops
.op_file_resume
<- (fun _ -> ());
1550 file_ops
.op_file_set_format
<- (fun _ _ -> ());
1551 file_ops
.op_file_check
<- (fun _ -> ());
1552 file_ops
.op_file_recover
<- (fun _ -> ());
1553 file_ops
.op_file_print
<- (fun file o
->
1554 let buf = o
.conn_buf
in
1555 if use_html_mods o
then
1558 Printf.bprintf
buf "\\</tr\\>\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr
());
1562 ("Directory", "sr br", "Directory");
1563 ("", "sr", file
.file_directory
) ];
1565 ("Filename", "sr br", "Filename");
1566 ("", "sr", file
.file_name
) ];
1568 ("Tiger tree hash and magnet url", "sr", "TTH and magnet");
1569 ("", "sr", html_show_file file
) ];
1571 ("Automatic TTH searches performed", "sr", "Autosearches");
1572 ("", "sr", string_of_int file
.file_autosearch_count
) ];
1576 (*file_ops.op_file_print_html <- (fun _ _ -> lprintf_nl "Received (op_file_print_html)"; ());*)
1577 (*file_ops.op_file_print_sources_html <- (fun _ _ -> lprintf_nl "Received (op_file_print_sources_html)"; ())*)
1578 (* mutable op_file_files : ('a -> 'a file_impl -> file list);
1579 mutable op_file_debug : ('a -> string);
1580 mutable op_file_proposed_filenames : ('a -> string list);
1584 CommonWeb.add_web_kind
"hublist" "DirectConnect hublist"
1585 (fun url
filename ->
1586 if !!enable_directconnect
then
1590 match List.rev
(String2.split
filename '
.'
) with
1591 | "bz2"::"xml"::_ ->
1592 Unix2.with_remove
(Misc2.bz2_extract
filename) (fun filename ->
1593 DcServers.make_hublist_from_xml
(Xml.parse_file
filename))
1594 | "xml"::_ -> DcServers.make_hublist_from_xml
(Xml.parse_file
filename)
1595 | "bz2"::_ -> Unix2.with_remove
(Misc2.bz2_extract
filename) DcServers.make_hublist_from_file
1596 | _ -> DcServers.make_hublist_from_file
filename);
1597 lprintf_nl "Loaded DC hublist, %d entries" (List.length
!dc_hublist
)
1599 lprintf_nl "Exception while parsing hublist from %S : %s" url
(Printexc2.to_string e
);
1604 lprintf_nl "DirectConnect module is disabled, ignoring...";