?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
patch #7180
[mldonkey.git] / src / networks / direct_connect / dcInteractive.ml
blob4e3c009c207639dffbd9020a39854c79304aa23a
1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
2 (*
3 This file is part of mldonkey.
4
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.
9
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.
14
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
18 *)
19
20 open Int64ops
21 open Options
22 open Printf2
23 open Md4
24 open BasicSocket
25
26 open GuiTypes
27
28 open CommonInteractive
29 open CommonOptions
30 open CommonGlobals
31 open CommonComplexOptions
32 open CommonClient
33 open CommonFile
34 open CommonUser
35 open CommonNetwork
36 open CommonRoom
37 open CommonServer
38 open CommonResult
39 open CommonTypes
40 open CommonSearch
41
42 open DcTypes
43 open DcOptions
44 open DcGlobals
45 open DcShared
46 open DcProtocol
47 open DcServers
48 open Xml
49
50
51 let log_prefix = "[dcInt]"
52
53 let lprintf_nl fmt =
54 lprintf_nl2 log_prefix fmt
55
56 (* Start new dowload from result *)
57 let start_new_download u tth fdir fname fsize =
58 (try
59 ignore (Hashtbl.find dc_shared_files_by_hash tth);
60 if !verbose_download then lprintf_nl "Shared file with same hash exists (%s) (%s)" fname tth;
61 None
62 with _ ->
63 let f = new_file tth fdir fname fsize in (* ...create new file *)
64 (match (file_state f) with
65 | FileDownloaded | FileShared -> if !verbose_download then lprintf_nl "File already downloaded"; None
66 | FileDownloading -> if !verbose_download then lprintf_nl "File being downloaded"; None
67 | FilePaused -> if !verbose_download then lprintf_nl "File paused"; None
68 | FileAborted _ | FileCancelled | FileQueued ->
69 if !verbose_download then lprintf_nl "File state invalid"; None
70 | FileNew ->
71 file_add f.file_file FileDownloading;
72 let c = new_client_to_user_with_file u f in
73 c.client_state <- DcDownloadWaiting f;
74 if (can_user_start_downloading u) then begin
75 u.user_state <- TryingToSendFirstContact;
76 c.client_state <- DcDownloadConnecting (f,current_time ());
77 ignore (DcClients.try_connect_client c)
78 end;
79 Some f ) )
80
81 (* Start downloading of a file by user selection from resultlist *)
82 let start_result_download r =
83 let filename = List.hd r.result_names in
84 let rinfo = Hashtbl.find dc_result_info r.result_num in
85 let newfile = start_new_download rinfo.user rinfo.tth rinfo.directory filename r.result_size in
86 (match newfile with
87 | Some f -> as_file f.file_file (* return CommonFile.file *)
88 | _ -> raise Not_found )
89
90 (* register DC commands *)
91 let register_commands list =
92 register_commands (List2.tail_map (fun (n,f,h) -> (n, "Direct Connect", f,h)) list)
93
94 (* Print DC hubs header *)
95 let dc_hublist_print_html_header buf ext =
96 html_mods_table_header buf "serversTable" (Printf.sprintf "servers%s" ext) [
97 ( "1", "srh", "Hub number", "#" ) ;
98 ( "0", "srh", "Add hub to servers", "Add" ) ;
99 ( "0", "srh", "Hub name", "Hub name" ) ;
100 ( "0", "srh", "IP address", "IP address" ) ;
101 ( "1", "srh", "Users in hub", "Users" ) ;
102 ( "0", "srh", "Hub info", "Info" ) ]
103
104 (* print in html or txt list of hubs *)
105 let hublist_print h hnum o =
106 let buf = o.conn_buf in
107 let hname = if (String.length h.dc_name > 50) then String.sub h.dc_name 0 49
108 else h.dc_name in
109 let hinfo = if (String.length h.dc_info > 50) then String.sub h.dc_info 0 49
110 else h.dc_info in
111 if use_html_mods o then begin
112 Printf.bprintf buf "
113 \\<tr class=\\\"dl-%d\\\"\\>
114 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
115 %s
116 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
117 \\<td class=\\\"sr\\\"\\>%s:%d\\</td\\>
118 \\<td class=\\\"sr\\\"\\>%d\\</td\\>
119 \\<td width=\\\"100%%\\\" class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>\n"
120 (html_mods_cntr ())
121 hnum
122 (Printf.sprintf
123 "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
124 onMouseOut=\\\"mOut(this);\\\" title=\\\"Add\\\"
125 onClick=\\\"parent.fstatus.location.href='submit?q=dcn+%s+%d'\\\"\\>Add\\</td\\>"
126 (Ip.string_of_addr h.dc_ip) h.dc_port)
127 hname
128 (Ip.string_of_addr h.dc_ip) h.dc_port
129 h.dc_nusers hinfo
130 end else begin
131 Printf.bprintf buf "[%5d] %20s %25s:%-10d Users:%-8d %20s\n"
132 hnum
133 hname
134 (Ip.string_of_addr h.dc_ip) h.dc_port
135 h.dc_nusers
136 hinfo
137 end
138
139 (* Print DC users header *)
140 let dc_user_print_html_header buf =
141 html_mods_table_header buf "serversTable" "servers" [
142 ( "1", "srh", "User number", "#" );
143 ( "1", "srh", "User name", "Name" );
144 ( "1", "srh", "User type", "Type" );
145 ( "1", "srh", "Users slots (all/free)", "Slots" );
146 ( "1", "srh", "Users connected hubs (Normal/Vipped/Opped)", "Hubs" );
147 ( "1", "srh", "Users mode", "Mode" );
148 ( "1", "srh", "Users shared size", "Shared" );
149 ( "1", "srh", "User state", "State" );
150 ( "1", "srh", "User description field", "Description" );
151 ( "1", "srh", "User clients number", "Clients" );
152 ( "1", "srh", "Users servers number", "Servers" );
153 ( "0", "srh", "Download this clients filelist", "Filelist" );
154 ( "0", "srh", "Open chat window with this user. Blinking tells there are new unread messages", "Chat");
155 ( "1", "srh", "User total uploaded bytes", "Up" );
156 ( "1", "srh", "User total downloaded bytes", "Down" );
157 ( "1", "srh", "User client supports", "Supports" ); ];
158 ()
159
160 (* print in html or txt list of users *)
161 let user_print user num o =
162 let buf = o.conn_buf in
163 let utype =
164 (match user.user_type with
165 | Normal -> "Normal"
166 | Vip -> "Vip"
167 | Op -> "Op"
168 (*| Bot -> "Bot"*) )
169 in
170 let state =
171 (match user.user_state with
172 | UserIdle -> "NotDefined"
173 | TryingToSendFirstContact -> "TryingToSendFirstContact"
174 | UserActiveMeInitiating -> "UserActiveMeInitiating"
175 | UserActiveUserInitiating -> "UserActiveUserInitiating"
176 | UserPassiveUserInitiating _ -> "UserPassiveUserInitiating" )
177 in
178 let clients = List.length user.user_clients in
179 let servers = List.length user.user_servers in
180 let messages = user_has_new_messages user in
181 let hasmynick = has_my_nick user in
182 let hubs =
183 let a,b,c = user.user_myinfo.hubs in
184 Printf.sprintf "(%d/%d/%d)" a b c
185 in
186 let supports =
187 if (List.length user.user_clients > 0) then begin
188 let c = List.hd user.user_clients in
189 (match c.client_supports with
190 | Some supports ->
191 DcProtocol.Supports.create_supports_string (ClientSupports supports)
192 | _ -> empty_string )
193 end else empty_string
194 in
195 if use_html_mods o then begin
196 Printf.bprintf buf "
197 \\<tr class=\\\"dl-%d\\\"\\>
198 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
199 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
200 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
201 \\<td class=\\\"sr\\\"\\>%d\\</td\\>
202 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
203 \\<td class=\\\"sr\\\"\\>%c\\</td\\>
204 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
205 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
206 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
207 \\<td class=\\\"sr\\\"\\>%d\\</td\\>
208 \\<td class=\\\"sr\\\"\\>%d\\</td\\>
209 %s%s
210 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
211 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
212 \\<td class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>\n"
213 (html_mods_cntr ()) num user.user_nick utype user.user_myinfo.slots hubs user.user_myinfo.mode
214 (size_of_int64 user.user_myinfo.sharesize) state user.user_myinfo.description clients servers
215 (if not hasmynick && (servers > 0) then (* is connected to any servers with us *)
216 (Printf.sprintf "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
217 onMouseOut=\\\"mOut(this);\\\" title=\\\"Download user filelist\\\"
218 onClick=\\\"parent.fstatus.location.href='submit?q=dcloadfilelist+%s'\\\"\\>Get List\\</td\\>"
219 user.user_nick )
220 else begin
221 let txt =
222 if hasmynick then "Me"
223 else "No connection"
224 in
225 Printf.sprintf "\\<td class=\\\"sr\\\"\\>%s\\</td\\>" txt
226 end )
227 (if not hasmynick then (* not me *)
228 (Printf.sprintf "\\<td class=\\\"srb\\\" %sonMouseOver=\\\"mOvr(this);\\\"
229 onMouseOut=\\\"mOut(this);\\\" title=\\\"Open message window to this user\\\"
230 onClick=\\\"parent.output.location.href='submit?q=dcmessages+%s'\\\"\\>Open chat\\</td\\>"
231 (if messages then "style=\\\"text-decoration:blink\\\" " else "") user.user_nick )
232 else "\\<td class=\\\"sr\\\"\\>\\</td\\>" )
233 (size_of_int64 user.user_uploaded) (size_of_int64 user.user_downloaded) supports
234 end else
235 Printf.bprintf buf "[%5d] %-20s %8s %20s\n" num user.user_nick utype state
236
237 (* Print DC hubs header *)
238 let dc_hub_print_html_header buf =
239 html_mods_table_header buf "serversTable" "servers" [
240 ( "1", "srh", "Hub number", "#" ) ;
241 ( "0", "srh", "Set/UnSet server autoconnection state", "Auto" ) ;
242 ( "0", "srh", "Hub name", "Hub name" ) ;
243 ( "0", "srh", "IP address", "IP address" ) ;
244 ( "0", "srh", "My state in this hub", "State" ) ;
245 ( "1", "srh", "Users in hub", "Users" ) ;
246 ( "0", "srh", "Hub info", "Info" );
247 ( "0", "srh", "Open chat window with this hub. Blinking tells there are new unread message", "Chat" ) ]
248
249 (* Print list of connected hubs *)
250 let hub_print s num o =
251 let buf = o.conn_buf in
252 let sinfo = shorten_string s.server_info 50 in
253 let sname = shorten_string s.server_name 50 in
254 let sip = Ip.to_string s.server_ip in
255 let sport = s.server_port in
256 let susers = List.length s.server_users in
257 let smessages = ((List.length s.server_messages) > s.server_read_messages) in
258 let sstate = dc_hubstate_to_text s in
259 if use_html_mods o then begin
260 Printf.bprintf buf "
261 \\<tr class=\\\"dl-%d\\\"\\>
262 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
263 %s
264 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
265 \\<td class=\\\"sr\\\"\\>%s:%d\\</td\\>
266 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
267 %s
268 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
269 %s\\</tr\\>\n"
270 (html_mods_cntr ())
271 num
272 (Printf.sprintf
273 "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
274 onMouseOut=\\\"mOut(this);\\\" title=\\\"Set this server/hub autoconnection state\\\"
275 onClick=\\\"parent.output.location.href='submit?q=dcautoconnect+%s+%s'\\\"\\>%s\\</td\\>"
276 (if s.server_autoconnect then "false" else "true") sip (if s.server_autoconnect then "UnSet" else "Set") )
277 sname sip sport sstate
278 (Printf.sprintf
279 "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
280 onMouseOut=\\\"mOut(this);\\\" title=\\\"Click to show users for this hub only\\\"
281 onClick=\\\"parent.output.location.href='submit?q=dcusers+%s'\\\"\\>%d\\</td\\>"
282 sip susers )
283 sinfo
284 (Printf.sprintf
285 "\\<td class=\\\"srb\\\" %sonMouseOver=\\\"mOvr(this);\\\"
286 onMouseOut=\\\"mOut(this);\\\" title=\\\"Open this hubs chat windows\\\"
287 onClick=\\\"parent.output.location.href='submit?q=dcmessages+%s+%d'\\\"\\>Open chat\\</td\\>"
288 (if smessages then "style=\\\"text-decoration:blink\\\" " else "") sip sport)
289 end else begin
290 Printf.bprintf buf "[%5d] %20s %25s:%-10d Users:%-8d %20s\n"
291 num
292 sname
293 sip sport
294 susers
295 sinfo
296 end
297
298 (* Print DC clients header *)
299 let dc_client_print_html_header buf =
300 html_mods_table_header buf "serversTable" "servers" [
301 ( "1", "srh", "Client number", "#" );
302 ( "1", "srh", "Remove Client", "Rem" );
303 ( "1", "srh", "Clientname", "Name" );
304 ( "1", "srh", "Client ip/port", "Ip:Port" );
305 ( "1", "srh", "Client state", "State" );
306 ( "1", "srh", "Client connection", "Conn" );
307 ( "1", "srh", "Client last error/count", "Error" );
308 ( "1", "srh", "Client file", "File" ); ];
309 ()
310
311 (* print in html or txt list of clients *)
312 let client_print name client num o =
313 let buf = o.conn_buf in
314 let ip,port =
315 (match client.client_addr with
316 | Some (ip,port) -> Ip.to_string ip,port
317 | None -> "None",0 )
318 in
319 let conn =
320 (match client.client_sock with
321 | Connection _ -> "Connected"
322 | ConnectionWaiting _ -> "Connecting..."
323 | NoConnection -> "NoConnection" )
324 in
325 let state = client_state_to_string client in
326 let error =
327 (match client.client_error with
328 | NoError -> empty_string
329 | NoFreeSlots -> Printf.sprintf "NoFreeSlots %d" client.client_error_count
330 | FileNotAvailable -> Printf.sprintf "FileNotAvailable %d" client.client_error_count
331 | UserNotReachable -> Printf.sprintf "UserNotReachable %d" client.client_error_count
332 | ClosedOnInit -> Printf.sprintf "ClosedOnInit %d" client.client_error_count
333 | ConnectionResetByPeer -> Printf.sprintf "ConnectionResetByPeer %d" client.client_error_count
334 | UploadError -> Printf.sprintf "UploadError %d" client.client_error_count
335 | UserDontReplyOnTime -> Printf.sprintf "UserDontReplyOnTime %d" client.client_error_count )
336 in
337 let fil =
338 (match client.client_state with
339 | DcDownloadWaiting file
340 | DcDownloadConnecting (file,_)
341 | DcDownload file -> file.file_name
342 | DcUpload (_,fd_file,_,_)
343 | DcUploadList fd_file
344 | DcDownloadList fd_file -> Unix32.filename fd_file
345 | DcUploadListStarting filename -> filename
346 | DcUploadStarting (dcsh,_,_) -> dcsh.dc_shared_codedname
347 | _ -> "None" )
348 in
349 if use_html_mods o then begin
350 Printf.bprintf buf "
351 \\<tr class=\\\"dl-%d\\\"\\>
352 \\<td class=\\\"sr\\\" \\>%d\\</td\\>
353 %s
354 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
355 \\<td class=\\\"sr\\\"\\>%s:%d\\</td\\>
356 \\<td class=\\\"sr\\\" \\>%s\\</td\\>
357 \\<td class=\\\"sr\\\" \\>%s\\</td\\>
358 \\<td class=\\\"sr\\\" \\>%s\\</td\\>
359 \\<td class=\\\"sr\\\" \\>%s\\</td\\>\\</tr\\>\n"
360 (html_mods_cntr ()) num
361 (Printf.sprintf
362 "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
363 onMouseOut=\\\"mOut(this);\\\" title=\\\"Remove client\\\"
364 onClick=\\\"parent.fstatus.location.href='submit?q=dcremclient+%d'\\\"\\>Rem\\</td\\>"
365 (client_num (as_client client.client_client)) )
366 name ip port state conn error fil
367 end else
368 Printf.bprintf buf "[%5d] %25s %25s:%-10d S:%15s C:%15s F:%15s\n"
369 num name ip port state conn fil
370
371 (* Print DC files header *)
372 let dc_file_print_html_header buf =
373 html_mods_table_header buf "serversTable" "servers" [
374 ( "1", "srh", "File number", "#" );
375 ( "1", "srh", "File name/path", "File" );
376 ( "1", "srh", "File size", "Size" );
377 ( "1", "srh", "TTH Hash", "Hash" );
378 ( "1", "srh", "Files clients number (sources)", "Clients" );
379 ( "1", "srh", "Autosearches done", "Searches" );
380 ( "1", "srh", "Find new source by tth", "Find TTH" );
381 ( "1", "srh", "Find new source by similar name context", "Find similar" ); ];
382 ()
383
384 (* print in html or txt list of files *)
385 let file_print file num o =
386 let buf = o.conn_buf in
387 let fname = ref (String.copy file.file_name) in
388 String2.replace_char !fname char32 char42; (* to * *)
389 String2.replace_char !fname char39 char58; (* ' to : *)
390 String2.replace_char !fname char60 char38; (* & to < *)
391 if use_html_mods o then begin
392 Printf.bprintf buf "
393 \\<tr class=\\\"dl-%d\\\"\\>
394 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
395 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
396 \\<td class=\\\"srb\\\" \\>%Ld\\</td\\>
397 \\<td class=\\\"srb\\\" \\>%s\\</td\\>
398 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
399 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
400 %s
401 %s\\</tr\\>\n"
402 (html_mods_cntr ()) num file.file_name file.file_file.impl_file_size
403 (file.file_unchecked_tiger_root) (List.length file.file_clients) file.file_autosearch_count
404 (Printf.sprintf
405 "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
406 onMouseOut=\\\"mOut(this);\\\" title=\\\"Find new client for this file by TTH\\\"
407 onClick=\\\"parent.output.location.href='submit?q=dcfindsource+%s'\\\"\\>Find TTH\\</td\\>"
408 file.file_unchecked_tiger_root )
409 (Printf.sprintf
410 "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
411 onMouseOut=\\\"mOut(this);\\\" title=\\\"Find new client for this file by similar name\\\"
412 onClick=\\\"parent.output.location.href='submit?q=dcfindsource+%s'\\\"\\>Find similar\\</td\\>"
413 !fname )
414 end else
415 Printf.bprintf buf "[%5d] %40s %-15Ld %5d\n"
416 num file.file_name file.file_file.impl_file_size (List.length file.file_clients)
417
418 (* Print DC shared files header *)
419 let dc_shared_print_html_header buf =
420 html_mods_table_header buf "serversTable" "servers" [
421 ( "1", "srh", "File number", "#" );
422 ( "1", "srh", "Shared file codedname", "Codedname" );
423 ( "1", "srh", "Shared file size", "Size" );
424 ( "1", "srh", "TTH Hash", "Hash" );
425 (*( "1", "srh", "Shared files Tiger tree array length", "TTree #" );*) ];
426 ()
427
428
429 (* print in html or txt list of shared files *)
430 let shared_print dcsh num o =
431 let buf = o.conn_buf in
432 if use_html_mods o then begin
433 Printf.bprintf buf "
434 \\<tr class=\\\"dl-%d\\\"\\>
435 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
436 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
437 \\<td class=\\\"srb\\\" \\>%Ld\\</td\\>
438 \\<td class=\\\"srb\\\" \\>%s\\</td\\>\\</tr\\>\n"
439 (html_mods_cntr ()) num dcsh.dc_shared_codedname dcsh.dc_shared_size
440 dcsh.dc_shared_tiger_root (*(Array.length dcsh.dc_shared_tiger_array)*)
441 end else
442 Printf.bprintf buf "[%5d] %40s %-15Ld %24s\n"
443 num dcsh.dc_shared_codedname dcsh.dc_shared_size dcsh.dc_shared_tiger_root
444 (*(Array.length dcsh.dc_shared_tiger_array)*)
445
446 type dc_int_groups = G_users|G_hubs|G_clients|G_files|G_shared
447
448 (* register users,clients,files *)
449 let dc_list o group_type group_name =
450 let buf = o.conn_buf in
451 let num = ref 1 in
452 html_mods_cntr_init ();
453 if use_html_mods o then begin
454 (try
455 (match group_type with
456 | G_users ->
457 let new_messages_list = ref [] in (* lets order users with unread messages to the top *)
458 let others_list = ref [] in
459 Hashtbl.iter (fun _ user ->
460 if user_has_new_messages user then new_messages_list := user :: !new_messages_list
461 else others_list := user :: !others_list
462 ) users_by_name;
463 dc_user_print_html_header buf;
464 List.iter (fun user -> user_print user !num o; incr num) !new_messages_list;
465 List.iter (fun user -> user_print user !num o; incr num) !others_list;
466 | G_hubs ->
467 dc_hub_print_html_header buf;
468 Hashtbl.iter (fun _ s -> hub_print s !num o; incr num) servers_by_ip
469 (*List.iter (fun s -> hub_print s !num o; incr num) !connected_servers*)
470 | G_clients ->
471 dc_client_print_html_header buf;
472 List.iter (fun c ->
473 (match c.client_name with
474 | Some n -> client_print n c !num o; incr num
475 | None -> () )
476 ) !clients_list
477 | G_files ->
478 dc_file_print_html_header buf;
479 List.iter (fun file -> file_print file !num o; incr num) !current_files;
480 | G_shared ->
481 dc_shared_print_html_header buf;
482 Hashtbl.iter (fun _ dcsh -> shared_print dcsh !num o; incr num) dc_shared_files_by_codedname;
483 Printf.bprintf buf "\\</table\\>\\</div\\>";
484 num := 1;
485 dc_shared_print_html_header buf;
486 Hashtbl.iter (fun _ dcsh -> shared_print dcsh !num o; incr num) dc_shared_files_by_hash; )
487 with e -> lprintf_nl "Exception %s in printing %s" (Printexc2.to_string e) group_name );
488 Printf.bprintf buf "\\</table\\>\\</div\\>";
489 end;
490 empty_string
491
492 (* Print DC filelist header *)
493 let dc_filelist_print_html_header buf =
494 html_mods_table_header buf "serversTable" "servers" [
495 ( "1", "srh", "Number", "#" ) ;
496 ( "0", "srh", "Filelist name", "Filelist" ) ]
497
498 (* Print one line from filelist *)
499 let filelist_print fname line o =
500 let buf = o.conn_buf in
501 if use_html_mods o then begin
502 Printf.bprintf buf "
503 \\<tr class=\\\"dl-%d\\\"\\>
504 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
505 %s"
506 (html_mods_cntr ())
507 line
508 (Printf.sprintf
509 "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
510 onMouseOut=\\\"mOut(this);\\\" title=\\\"Click to open filelist\\\"
511 onClick=\\\"parent.output.location.href='submit?q=dcshowfilelist+%s'\\\"\\>%s\\</td\\>\\</tr\\>\n"
512 fname fname);
513 end else begin
514 Printf.bprintf buf "[%5d] %s\n" line fname
515 end
516
517 (* Print DC filelist files header *)
518 let dc_filelist_files_print_html_header buf =
519 html_mods_table_header buf "serversTable" (Printf.sprintf "servers") [
520 ( "1", "srh", "Number", "#" );
521 ( "0", "srh", "File/Firectory name", "File/Directory name" );
522 ( "0", "srh", "File Size", "Size" );
523 ( "0", "srh", "Files TTH", "TTH" ) ]
524
525 (* Print one line from filelist file *)
526 let filelist_file_print is_file spaces username dir fname fsize ftth line o =
527 (* is_file = if true, make the whole filename a link with submit command to load a file
528 spaces
529 username = username to submit in command
530 dir = current directory path to submit in command
531 fname = filename from mylist
532 fsize = filesize from mylist
533 ftth = tth from mylist *)
534 let buf = o.conn_buf in
535 let sdir = ref (String.copy dir) in
536 let sname = ref (String.copy fname) in
537 String2.replace_char !sdir char32 char42; (* to * *)
538 String2.replace_char !sdir char39 char58; (* ' to : *)
539 String2.replace_char !sdir char38 char60; (* & to < *)
540 String2.replace_char !sdir char43 char62; (* + to > *)
541 String2.replace_char !sname char32 char42;
542 String2.replace_char !sname char39 char58;
543 String2.replace_char !sname char38 char60;
544 String2.replace_char !sname char43 char62;
545 if use_html_mods o then begin
546 Printf.bprintf buf "
547 \\<tr class=\\\"dl-%d\\\"\\>
548 \\<td class=\\\"srb\\\" \\>%d\\</td\\>
549 %s
550 \\<td class=\\\"srb\\\" \\>%s\\</td\\>
551 \\<td class=\\\"srb\\\" \\>%s\\</td\\>\\</tr\\>\n"
552 (html_mods_cntr ())
553 line
554 (if is_file then
555 (Printf.sprintf
556 "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
557 onMouseOut=\\\"mOut(this);\\\" title=\\\"Click to start loading \\\"
558 onClick=\\\"parent.fstatus.location.href='submit?q=dcloadfile+%s+%s+%s+%s+%s'\\\"\\>%s%s\\</td\\>"
559 username ftth !sdir !sname fsize spaces fname )
560 else
561 (Printf.sprintf "\\<td class=\\\"srb\\\" \\>\\<b\\>%s%s\\</b\\>\\</td\\>" spaces fname)
562 )
563 fsize
564 ftth
565 end else begin
566 Printf.bprintf buf "%30s %10s %30s\n" fname fsize ftth
567 end
568
569 (* Print DC info header *)
570 let dc_info_html_header buf =
571 html_mods_table_header buf "sharesTable" "shares" [
572 ( "0", "srh", "Direct Connect information", "DC Info" ) ;
573 ( "0", "srh", empty_string, empty_string ) ]
574
575 (* Print DC info *)
576 let dc_info_print info data line o =
577 let buf = o.conn_buf in
578 if use_html_mods o then begin
579 Printf.bprintf buf "
580 \\<tr class=\\\"dl-%d\\\"\\>
581 \\<td class=\\\"sr\\\"\\>%s\\</td\\>
582 \\<td class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>"
583 (html_mods_cntr ()) info data
584 end else begin
585 Printf.bprintf buf "%s: %s\n" info data
586 end
587
588
589 (* List of commands to register *)
590 let commands = [
591
592 "dc", Arg_none (fun o ->
593 let buf = o.conn_buf in
594 if use_html_mods o then begin
595 Printf.bprintf buf "\\<table\\>\\<tr\\>\\<form style=\\\"margin: 0px;\\\" id=\\\"users\\\" name=\\\"users\\\"
596 action=\\\"javascript:parent.output.location.href='submit?q=dcusers+all'\\\"\\>
597 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
598 Value=\\\"Users\\\"\\>\\</td\\>\\</form\\>";
599 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"clients\\\" name=\\\"clients\\\"
600 action=\\\"javascript:parent.output.location.href='submit?q=dcclients'\\\"\\>
601 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
602 Value=\\\"Clients\\\"\\>\\</td\\>\\</form\\>";
603 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"hubs\\\" name=\\\"hubs\\\"
604 action=\\\"javascript:parent.output.location.href='submit?q=dchubs'\\\"\\>
605 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
606 Value=\\\"Hubs\\\"\\>\\</td\\>\\</form\\>";
607 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"shared\\\" name=\\\"shared\\\"
608 action=\\\"javascript:parent.output.location.href='submit?q=dcshared'\\\"\\>
609 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
610 Value=\\\"Shared\\\"\\>\\</td\\>\\</form\\>";
611 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"files\\\" name=\\\"files\\\"
612 action=\\\"javascript:parent.output.location.href='submit?q=dcfiles'\\\"\\>
613 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
614 Value=\\\"Files\\\"\\>\\</td\\>\\</form\\>";
615 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"info\\\" name=\\\"info\\\"
616 action=\\\"javascript:parent.output.location.href='submit?q=dcinfo'\\\"\\>
617 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
618 Value=\\\"DC Info\\\"\\>\\</td\\>\\</form\\>";
619 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"hublistshow\\\" name=\\\"hublistshow\\\"
620 action=\\\"javascript:parent.output.location.href='submit?q=dchublist'\\\"\\>
621 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
622 Value=\\\"Show hublist\\\"\\>\\</td\\>\\</form\\>";
623 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"filelists\\\" name=\\\"filelists\\\"
624 action=\\\"javascript:parent.output.location.href='submit?q=dcfilelists'\\\"\\>
625 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
626 Value=\\\"Filelists\\\"\\>\\</td\\>\\</form\\>";
627 Printf.bprintf buf "\\</tr\\>\\</table\\>";
628 end else
629 Printf.bprintf buf "Received command dc\n";
630 empty_string
631 ), ": Show direct connect buttons";
632
633 (* 'dcn address [port]' Add a new DC server with optional port (default 411) *)
634 "dcn", Arg_multiple (fun args o ->
635 let ip, port =
636 (match args with
637 | [ip ; port] -> ip, port
638 | [ip] -> ip, "411"
639 | _ -> failwith "dcn <ip> [<port>]: bad argument number" )
640 in
641 let ip_addr = Ip.addr_of_string ip in
642 Ip.async_ip_of_addr ip_addr (fun t -> (* do DNS check here *)
643 let port = int_of_string port in
644 if !verbose_msg_servers then lprintf_nl "New server being added: (%s) (%s) (%d)" ip (Ip.to_string t) port;
645 if (Ip.valid t) && (port>0) && (port<65536) then
646 ignore (new_server ip_addr t port) ) (fun _ -> ());
647 empty_string
648 ), "<ip> [<port>] : Add a server. Default port number is 411";
649
650 (* List connected hubs for chatting *)
651 "dchubs", Arg_none (fun o -> dc_list o G_hubs "hubs"
652 ), ": Show connected DC hubs";
653
654 (* List all DC users *)
655 "dcusers", Arg_one (fun args o ->
656 let buf = o.conn_buf in
657 (match args with
658 | "all" -> dc_list o G_users "users"
659 | ip ->
660 (try
661 let s = Hashtbl.find servers_by_ip ip in
662 let num = ref 1 in
663 let new_messages_list = ref [] in (* lets order users with unread messages to the top *)
664 let others_list = ref [] in
665 List.iter (fun user ->
666 if user_has_new_messages user then new_messages_list := user :: !new_messages_list
667 else others_list := user :: !others_list
668 ) s.server_users;
669 dc_user_print_html_header buf;
670 List.iter (fun user -> user_print user !num o; incr num) !new_messages_list;
671 List.iter (fun user -> user_print user !num o; incr num) !others_list;
672 empty_string
673 with _ -> "dcusers <ip> : ip not valid" ) );
674 ), "<all>|<ip> :Show DC users";
675
676 (* List all DC clients *)
677 "dcclients", Arg_none (fun o -> dc_list o G_clients "clients"
678 ), ": Show all DC clients";
679
680 (* List all DC files *)
681 "dcfiles", Arg_none (fun o -> dc_list o G_files "files"
682 ), ": Show all DC files";
683
684 (* List all DC shared files *)
685 "dcshared", Arg_none (fun o -> dc_list o G_shared "shared"
686 ), ": Show all DC shared files. All/Hashed ";
687
688 (* 'dchubs [args]' - Show dchub list with optional filters args (max 5) *)
689 "dchublist", Arg_multiple (fun args o ->
690 let buf = o.conn_buf in
691 let filter = ref [] in
692 let print_hublist () =
693 if use_html_mods o then
694 begin
695 html_mods_table_one_row buf "serversTable" "servers" [
696 (empty_string, "srh", Printf.sprintf "Showing hublist"); ];
697 Printf.bprintf buf "\\</table\\>\\</div\\>"
698 end
699 else
700 Printf.bprintf buf "Showing hublist";
701 html_mods_cntr_init ();
702 let nb_hubs = ref 0 in
703 if use_html_mods o then dc_hublist_print_html_header buf empty_string;
704 let show_all = if (!filter = []) then true else false in
705 List.iter (fun h ->
706 let hub_has_string searched =
707 if String2.contains (Ip.string_of_addr h.dc_ip) searched ||
708 String2.contains (string_of_int h.dc_port) searched ||
709 String2.contains h.dc_info searched ||
710 String2.contains h.dc_name searched then true
711 else false in
712 let print_hub () =
713 (try
714 hublist_print h !nb_hubs o;
715 incr nb_hubs;
716 with e ->
717 if !verbose_msg_servers then
718 lprintf_nl "Exception %s in hub_print\n" (Printexc2.to_string e))
719 in
720 if show_all then
721 print_hub ()
722 else
723 begin
724 let print = ref false in
725 let finished = ref false in
726 let counter = ref 0 in
727 let filters_length = List.length !filter in
728 while (!print = false) && (!finished = false) do
729 if (!counter = filters_length) || (!counter > 5) then
730 finished := true
731 else
732 if (hub_has_string (List.nth !filter !counter)) then print := true;
733 incr counter
734 done;
735 if (!print = true) then print_hub ()
736 end
737 ) !dc_hublist;
738 let txt = if show_all then "(showing all hubs from hublist)" else "(filtered)" in
739 if use_html_mods o then
740 begin
741 Printf.bprintf buf "\\</table\\>\\</div\\>";
742 html_mods_table_one_row buf "serversTable" "servers" [
743 (empty_string, "srh", Printf.sprintf "Hubs: %d known %s" !nb_hubs txt); ]
744 end
745 else
746 Printf.bprintf buf "Hubs: %d known %s" !nb_hubs txt
747 in
748 (match args with
749 | [] -> ()
750 | rest_args -> filter := rest_args
751 );
752 print_hublist ();
753 empty_string
754 ), "[filtertext]: dchublist fin - filters hubs with text fin";
755
756 (* 'dcuserip name' query user-ip from hub *)
757 "dcuserip", Arg_multiple (fun args o ->
758 let buf = o.conn_buf in
759 (match args with
760 | [hub ; port ; name] ->
761 (try
762 let s = Hashtbl.find servers_by_ip hub in
763 (match s.server_sock with
764 | Connection sock -> dc_send_msg sock ( UserIPReq ( [name] ))
765 | _ -> () )
766 with _ ->
767 if !verbose_unexpected_messages then
768 lprintf_nl "dcuserip: No server found by ip (%s) (%s) (%s)" hub port name )
769 | _ -> if !verbose_unexpected_messages then lprintf_nl "dcuserip: Invalid args count (%d)" (List.length args) );
770 Printf.bprintf buf "User query sent to hubs\n";
771 empty_string
772 ), "<user> : Query users ip from hub";
773
774 "dcmsglog", Arg_multiple (fun args o ->
775 let buf = o.conn_buf in
776 let counter = ref 0 in
777 let messages,name,topic =
778 (match args with
779 | delay :: ip :: port :: _ ->
780 (try
781 let s = Hashtbl.find servers_by_ip ip in
782 let topic =
783 (match s.server_sock with
784 | Connection _ -> s.server_topic
785 | _ -> "NOT CONNECTED TO SERVER" )
786 in
787 s.server_read_messages <- List.length s.server_messages; (* messages are set as read before *)
788 s.server_messages, (* they are actually printed to user *)
789 (if (String.length s.server_name > 50) then String.sub s.server_name 0 49 else s.server_name),
790 topic
791 with _ ->
792 if !verbose_unexpected_messages then lprintf_nl "dcmsglog: No server with address found";
793 raise Not_found )
794 | delay :: n :: _ ->
795 (try
796 let u = search_user_by_name n in
797 let connected = ((List.length u.user_servers) > 0) in
798 u.user_read_messages <- List.length u.user_messages; (* messages are set as read before *)
799 u.user_messages, u.user_nick, (* they are actually printed to user *)
800 (if connected then empty_string
801 else "User not connected to any servers at the moment...")
802 with _ ->
803 if !verbose_unexpected_messages then lprintf_nl "dcmsglog: No user found";
804 raise Not_found )
805 | _ ->
806 if !verbose_unexpected_messages then lprintf_nl "dcmsglog: Invalid args count (%d)" (List.length args);
807 raise Not_found )
808 in
809 if use_html_mods o then begin
810 Printf.bprintf buf "\\<div class=\\\"messages\\\"\\>";
811 Printf.bprintf buf "\\<div\\>Chatting with \\<b\\>%s\\</b\\> - %d logged messages\\</div\\>"
812 name (List.length messages);
813 Printf.bprintf buf "\\<div\\>\\<i\\>%s\\</i\\>\\</div\\>" topic
814 end else
815 Printf.bprintf buf "%d logged messages\n" (List.length messages);
816 if use_html_mods o then html_mods_table_header buf "serversTable" "servers" [
817 ( "0", "srh", "Timestamp", "Time" );
818 ( "0", "srh", "Who message is from", "From" );
819 ( "0", "srh", "Message text", "Message" ) ];
820 List.iter (fun (t,f,m) ->
821 let msg =
822 (match m with
823 | PrivateMessage (_, msg) -> msg
824 | PublicMessage (_, msg) -> msg
825 | ServerMessage msg -> msg )
826 in
827 if use_html_mods o then begin
828 Printf.bprintf buf "\\<tr class=\\\"%s\\\"\\>"
829 (if (!counter mod 2 == 0) then "dl-1" else "dl-2");
830 html_mods_td buf [
831 (empty_string, "sr", Date.simple (BasicSocket.date_of_int t));
832 (empty_string, "sr", f);
833 (empty_string, "srw", msg) ];
834 Printf.bprintf buf "\\</tr\\>"
835 end else begin
836 Printf.bprintf buf "\n%s [%s] : %s\n" (Date.simple (BasicSocket.date_of_int t)) f msg
837 end;
838 incr counter
839 ) messages;
840 if use_html_mods o then Printf.bprintf buf "\\</table\\>\\</div\\>\\</div\\>";
841 empty_string
842 ), "<refresh> <user> | <refresh> <serverip> <serverport>";
843
844 "dcmessages", Arg_multiple (fun args o ->
845 let buf = o.conn_buf in
846 let s,u =
847 (match args with
848 | ip :: port :: _ ->
849 (try
850 let s = Hashtbl.find servers_by_ip ip in
851 Some s, None
852 with _ ->
853 if !verbose_unexpected_messages then lprintf_nl "dcmessages: No server with address found";
854 raise Not_found )
855 | n :: _ ->
856 (try
857 let u = search_user_by_name n in
858 None, Some u
859 with _ ->
860 if !verbose_unexpected_messages then lprintf_nl "dcmessages: No user found";
861 raise Not_found )
862 | _ ->
863 if !verbose_unexpected_messages then lprintf_nl "dcmessages: No user or server";
864 raise Not_found )
865 in
866 if use_html_mods o then begin
867 Printf.bprintf buf "\\<script type=\\\"text/javascript\\\"\\>
868 \\<!--
869 function submitCmd() {
870 var formID = document.getElementById(\\\"msgForm\\\")
871 parent.output.location.href='submit?q=dcmessages+'+formID.sendCmd.value
872 }
873 function submitMessageForm() {
874 var formID = document.getElementById(\\\"msgForm\\\")
875 var regExp = new RegExp (' ', 'gi')
876 var msgTextOut = formID.msgText.value.replace(regExp, '+')
877 parent.fstatus.location.href='submit?q=dcsendmsg+'+formID.sendCmd.value+\\\"+\\\"+msgTextOut
878 formID.msgText.value=\\\"\\\"
879 msgWindow.location.reload();
880 }
881 //--\\>
882 \\</script\\>";
883 let sendmsg,namelist,first =
884 (match s with
885 | Some s ->
886 let ip,port = (Ip.to_string s.server_ip),(string_of_int s.server_port) in
887 Printf.sprintf "dcmsglog+20+%s+%s" ip port, s.server_users, Printf.sprintf "%s %s" ip port
888 | None ->
889 (match u with
890 | Some u ->
891 Printf.sprintf "dcmsglog+20+%s" u.user_nick, [], u.user_nick
892 | None ->
893 if !verbose_unexpected_messages then lprintf_nl "dcmessages: No user or server";
894 raise Not_found )
895 )
896 in
897 Printf.bprintf buf "\\<iframe id=\\\"msgWindow\\\" name=\\\"msgWindow\\\" height=\\\"80%%\\\"
898 width=\\\"100%%\\\" scrolling=yes src=\\\"submit?q=%s\\\"\\>\\</iframe\\>" sendmsg;
899 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" name=\\\"msgForm\\\" id=\\\"msgForm\\\" action=\\\"javascript:submitMessageForm()\\\"\\>";
900 Printf.bprintf buf "\\<table width=100%% cellspacing=0 cellpadding=0 border=0\\>\\<tr\\>\\<td\\>";
901 Printf.bprintf buf "\\<select style=\\\"font-family: verdana; font-size: 12px; width: 150px;\\\" id=\\\"sendCmd\\\" name=\\\"sendCmd\\\" \\>";
902 Printf.bprintf buf "\\<option value=\\\"%s\\\"\\>%s" first first;
903 List.iter (fun u ->
904 if not (has_my_nick u) then
905 Printf.bprintf buf "\\<option value=\\\"%s\\\"\\>%s" u.user_nick u.user_nick
906 ) namelist;
907 Printf.bprintf buf "\\</select\\>\\</td\\>";
908 Printf.bprintf buf "\\<td width=100%%\\>\\<input style=\\\"width: 99%%; font-family: verdana; font-size: 12px;\\\"
909 type=text id=\\\"msgText\\\" name=\\\"msgText\\\" size=50 \\>\\</td\\>";
910 Printf.bprintf buf "\\<td\\>\\<input style=\\\"font-family: verdana;
911 font-size: 12px;\\\" type=submit value=\\\"Send\\\"\\>\\</td\\>\\</form\\>";
912 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"refresh\\\" name=\\\"refresh\\\"
913 action=\\\"javascript:msgWindow.location.reload();\\\"\\>
914 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
915 Value=\\\"Refresh\\\"\\>\\</td\\>\\</form\\>\\</tr\\>\\</table\\>";
916 Printf.bprintf buf "\\<table\\>\\<tr\\>\\<form style=\\\"margin: 0px;\\\" id=\\\"users\\\" name=\\\"users\\\"
917 action=\\\"javascript:parent.output.location.href='submit?q=dcusers'\\\"\\>
918 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
919 Value=\\\"Users\\\"\\>\\</td\\>\\</form\\>";
920 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"hubs\\\" name=\\\"hubs\\\"
921 action=\\\"javascript:parent.output.location.href='submit?q=dchubs'\\\"\\>
922 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
923 Value=\\\"Hubs\\\"\\>\\</td\\>\\</form\\>";
924 Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"hubs\\\" name=\\\"hubs\\\"
925 action=\\\"javascript:submitCmd()\\\"\\>
926 \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\" type=submit
927 Value=\\\"Open chat\\\"\\>\\</td\\>\\</form\\>";
928 Printf.bprintf buf "\\</tr\\>\\</table\\>";
929 empty_string
930 end else
931 _s "Usage: dcmessages <username> | <serverip> <serverport>\n"
932 ), "<username> | <serverip> <serverport> : Show user or server messages ";
933
934
935 (* message type = (int * room_message) list
936 room_message type = | ServerMessage of string
937 | PublicMessage of int * string
938 | PrivateMessage of int * string *)
939 (* 'dcsendmsg hub port user message' - send message to specific user *)
940 "dcsendmsg", Arg_multiple (fun args o ->
941 let buf = o.conn_buf in
942 (*let failtxt = "dcsendmsg <user> <message> | <serverip> <serverport> <message> : bad arguments" in*)
943 let u = (* check if first argument is valid user *)
944 (try
945 let u = search_user_by_name (List.hd args) in
946 Some u
947 with _ -> None )
948 in
949 let s =
950 (try
951 let s = Hashtbl.find servers_by_ip (List.hd args) in
952 Some s
953 with _ -> None )
954 in
955 (match u with
956 | Some u -> (* message is private usermessage *)
957 (match args with
958 | _ :: messages ->
959 if not (has_my_nick u) && ((List.length u.user_servers) > 0) then begin
960 let sent = ref false in
961 List.iter (fun s -> (* find a server we are connected to with this user *)
962 (match s.server_sock with
963 | Connection sock ->
964 if not !sent then begin
965 let msg = String2.unsplit messages ' 'in
966 dc_send_msg sock (
967 ToReq { To.dest = u.user_nick;
968 To.from = s.server_last_nick;
969 To.message = msg } );
970 sent := true;
971 u.user_messages <- u.user_messages @ [
972 (int_of_float (current_time ()), s.server_last_nick, PrivateMessage (0, msg))];
973 end
974 | _ -> () )
975 ) u.user_servers
976 end
977 | _ -> () )
978 | None ->
979 (match s with (* message is probably hub chatmessage but check ip *)
980 | None -> if !verbose_unexpected_messages then lprintf_nl "dcsendmsg: No User or Server found"
981 | Some s ->
982 (match args with
983 | _ :: _ :: messages ->
984 (match s.server_sock with
985 | Connection sock ->
986 let msg = String2.unsplit messages ' 'in
987 dc_send_msg sock ( MessageReq { Message.from = s.server_last_nick; Message.message = msg } );
988 (* don't save this message, it is echoed from hub back to us and saved then *)
989 (* message window is refreshed too quickly to show this *)
990 | _ -> () )
991 | _ -> () )
992 )
993 );
994 Printf.bprintf buf "User query sent to hubs\n";
995 empty_string
996 ), "<user> <message> : Send message to user";
997
998 (* Try to load file from filelist *)
999 "dcloadfile", Arg_multiple (fun args o ->
1000 let buf = o.conn_buf in
1001 (match args with
1002 | [uname ; tth ; dir ; fname ; fsize] -> (* convert filenames back to normal *)
1003 if !verbose_download then lprintf_nl "dcloadfile: (%s) (%s) (%s)" dir fname tth;
1004 let sdir = ref (String.copy dir) in
1005 let sname = ref (String.copy fname) in
1006 String2.replace_char !sdir char42 char32; (* * to *)
1007 String2.replace_char !sdir char58 char39; (* : to ' *)
1008 String2.replace_char !sdir char60 char38; (* < to & *)
1009 String2.replace_char !sdir char62 char43; (* > to + *)
1010 String2.replace_char !sname char42 char32;
1011 String2.replace_char !sname char58 char39;
1012 String2.replace_char !sname char60 char38;
1013 String2.replace_char !sname char62 char43;
1014 Printf.bprintf buf "Trying to download file: %s from user: %s\n" !sname uname;
1015 (try
1016 let u = search_user_by_name uname in
1017 ignore (start_new_download u tth !sdir !sname (Int64.of_string fsize))
1018 with _ -> if !verbose_download then lprintf_nl "dcloadfile: No user found" )
1019 | _ ->
1020 if !verbose_unexpected_messages then
1021 lprintf_nl "dcloadfile: bad arguments count (%d)" (List.length args) );
1022 empty_string
1023 ), "<username> <tth> <directory> <filename> : Load a file";
1024
1025 (* load filelist from user *)
1026 "dcloadfilelist", Arg_one (fun args o ->
1027 let buf = o.conn_buf in
1028 (match args with
1029 | name ->
1030 (try
1031 let u = search_user_by_name name in
1032 if ((List.length u.user_servers) > 0) then begin
1033 if not (filelist_already_downloading u) then begin (* and is connected to server with us *)
1034 if !verbose_msg_clients || !verbose_download then
1035 lprintf_nl "Loading filelist from user %s" name; (* not already loading filelist *)
1036 let c = new_client () in
1037 c.client_name <- Some u.user_nick;
1038 add_client_to_user c u;
1039 c.client_state <- DcDownloadListWaiting;
1040 if (can_user_start_downloading u) then begin
1041 u.user_state <- TryingToSendFirstContact;
1042 c.client_state <- DcDownloadListConnecting (0,!!firewalled,current_time ()); (* level is set later *)
1043 ignore (DcClients.try_connect_client c);
1044 end
1045 end
1046 end
1047 with _ ->
1048 if !verbose_unexpected_messages then lprintf_nl "dcloadfilelist: No user (%s) found" name) );
1049 Printf.bprintf buf "Trying to download filelist\n";
1050 empty_string
1051 ), "<name> : Download filelist from user";
1052
1053 "dcfilelists", Arg_none (fun o ->
1054 let buf = o.conn_buf in
1055 html_mods_cntr_init ();
1056 let line = ref 1 in
1057 if use_html_mods o then dc_filelist_print_html_header buf;
1058 let filelist = Unix2.list_directory filelist_directory in
1059 List.iter (fun fname ->
1060 filelist_print fname !line o;
1061 incr line
1062 ) filelist;
1063 if use_html_mods o then Printf.bprintf buf "\\</table\\>\\</div\\>";
1064 empty_string
1065 ), ": List all filelists on disk";
1066
1067 "dcremclient", Arg_one (fun args o ->
1068 let buf = o.conn_buf in
1069 (match args with
1070 | num ->
1071 (try
1072 let cc = CommonClient.client_find (int_of_string num) in
1073 let impl = as_client_impl cc in
1074 let c = impl.impl_client_val in
1075 (match c.client_state with
1076 | DcDownloadWaiting _ | DcDownloadListWaiting ->
1077 Printf.bprintf buf "Removing one client by name %s" (clients_username c);
1078 remove_client c
1079 | _ -> () )
1080 with _ ->
1081 if !verbose_msg_clients then lprintf_nl "dcremclient: bad arguments (internal command)" ) );
1082 empty_string
1083 ), "<num> : Remove client by num";
1084
1085 "dcfindsource", Arg_one (fun args o ->
1086 (match args with
1087 | tth_or_filename ->
1088 (*lprintf_nl "Got dcfindsource command: (%s)" tth_or_filename;*)
1089 let tth_or_filename = ref (String.copy tth_or_filename) in
1090 String2.replace_char !tth_or_filename char42 char32;
1091 String2.replace_char !tth_or_filename char58 char39;
1092 String2.replace_char !tth_or_filename char38 char60;
1093 if (is_valid_tiger_hash !tth_or_filename) then begin
1094 let query = QAnd (QHasField (Field_Type , "TTH") , (QHasWord !tth_or_filename)) in
1095 let search = CommonSearch.new_search o.conn_user
1096 (let module G = GuiTypes in
1097 { G.search_num = 0;
1098 G.search_query = query;
1099 G.search_max_hits = 10000;
1100 G.search_type = RemoteSearch;
1101 G.search_network = network.network_num;
1102 } )
1103 in
1104 dc_with_connected_servers (fun s -> DcClients.server_send_search s search 9 !tth_or_filename);
1105 dc_last_manual_search := current_time ();
1106 end else begin
1107 let fname = Filename.basename !tth_or_filename in
1108 let words = clean_string fname in
1109 let words_list = String2.split_simplify words ' ' in
1110 let rec add_query list =
1111 (match list with
1112 | hd :: [] -> QHasWord hd
1113 | hd :: tail -> QAnd ((QHasWord hd) , (add_query tail))
1114 | [] -> failwith "No words to search")
1115 in
1116 let query = add_query words_list in
1117 let search = CommonSearch.new_search o.conn_user
1118 (let module G = GuiTypes in
1119 { G.search_num = 0;
1120 G.search_query = query;
1121 G.search_max_hits = 10000;
1122 G.search_type = RemoteSearch;
1123 G.search_network = network.network_num;
1124 } )
1125 in
1126 dc_with_connected_servers (fun s -> DcClients.server_send_search s search 1 !tth_or_filename);
1127 dc_last_manual_search := current_time ();
1128 end );
1129 empty_string
1130 ), ": Find new source for a file";
1131
1132 "dcinfo", Arg_none (fun o ->
1133 let buf = o.conn_buf in
1134 let server_list =
1135 let lst = ref [] in
1136 List.iter (fun s ->
1137 let data =
1138 String.sub s.server_name 0 (if (String.length s.server_name > 20) then 20 else
1139 String.length s.server_name) ^ " (nick = " ^ s.server_last_nick ^ ") (uptime = " ^
1140 (Date.time_to_string (int_of_float (current_time ()) -
1141 int_of_float (s.server_connection_time)) "verbose") ^
1142 (string_of_int (List.length s.server_users)) ^ ")"
1143 in
1144 lst := !lst @ [ (empty_string, data) ]
1145 ) !connected_servers;
1146 !lst
1147 in
1148 let norm_hubs,reg_hubs,opped_hubs = get_myhubs_info () in
1149 html_mods_cntr_init ();
1150 if use_html_mods o then dc_info_html_header buf;
1151 let nservers = List.length !connected_servers in
1152 let list = [
1153 ("Hub supports", (DcProtocol.Supports.create_supports_string (HubSupports mldonkey_dc_hub_supports)) );
1154 ("Client supports", (DcProtocol.Supports.create_supports_string (ClientSupports mldonkey_dc_client_supports)) );
1155 ("All/Open slots", Printf.sprintf "%d / %d" (open_slots ()) (current_slots ()) );
1156 ("Mode", (if !!firewalled then "Passive" else "Active") );
1157 ("Connected servers", (if nservers > 0 then string_of_int nservers else ""));
1158 (" Server list:", empty_string ); ]
1159 @ server_list @ [
1160 ("Hubs", (Printf.sprintf "Normal:%d Vipped:%d Opped:%d" norm_hubs reg_hubs opped_hubs) ); ]
1161 in
1162 let counter = ref 0 in
1163 List.iter (fun (info,data) ->
1164 dc_info_print info data line o;
1165 incr counter
1166 ) list;
1167 if use_html_mods o then Printf.bprintf buf "\\</table\\>\\</div\\>";
1168 empty_string
1169 ), ": Direct Connect info";
1170
1171 (* load filelist from user *)
1172 "dcshowfilelist", Arg_one (fun args o ->
1173 let buf = o.conn_buf in
1174 (match args with
1175 | filename ->
1176 let username, extension =
1177 (try
1178 if (Filename.check_suffix filename mylist_ext) then (* if extension is DcLst ... *)
1179 Filename.chop_suffix filename mylist_ext,mylist_ext (* return filename without it and ext *)
1180 else if (Filename.check_suffix filename bz2_ext) then begin (* else if extension is bz2 ... *)
1181 let filename = Filename.chop_suffix filename bz2_ext in (* chop it off *)
1182 if (Filename.check_suffix filename xml_ext) then (* check if there is extension xml ...*)
1183 Filename.chop_suffix filename xml_ext,mylistxmlbz2_ext (* return filename without it and ext *)
1184 else raise Not_found
1185 end else raise Not_found
1186 with _ -> filename, empty_string)
1187 in
1188 let spaces num = (* add as many "...":s to string that counter num *)
1189 let s = ref "" in
1190 let rec iter num =
1191 if (num <> 0) then begin
1192 s := !s ^ "...";
1193 iter (num-1)
1194 end
1195 in iter num;
1196 !s
1197 in
1198 if (extension = mylist_ext) then begin (* parse MyList.DcLst *)
1199 (try
1200 let s = file_to_che3_to_string (Filename.concat filelist_directory filename) in
1201 if not (Charset.is_utf8 s) then lprintf_nl "not utf8 : %S" s;
1202 let s = Charset.Locale.to_utf8 s in (* really needed? *)
1203 (try
1204 String2.replace_char s char13 '\n';
1205 let lines = String2.split_simplify s '\n' in
1206 let mlist = ref ([] : dc_mylistnode list) in (* root node of the MyList *)
1207 let tablist = ref [(-1, mlist)] in (* list of previous open directory node for every tab *)
1208 (* [(0 , list ref); (1 , list ref) ... *)
1209 let rec count_tabs line pos = (* count current lines tabs *)
1210 if line.[pos] <> '\t' then pos else
1211 count_tabs line (pos+1)
1212 in
1213 let add_dir name tabs list =
1214 let newlist = ref ([] : dc_mylistnode list) in
1215 list := !list @ [MylistDirectory (name, newlist)]; (* add this dir node to current list *)
1216 if (List.mem_assq tabs !tablist) then begin (* check if a directory exists already for this tab *)
1217 tablist := List.remove_assq tabs !tablist; (* remove existing previous tab *)
1218 end;
1219 tablist := !tablist @ [(tabs, newlist)]; (* add current list to this tab *)
1220 in
1221 let add_file name size list =
1222 list := !list @ [MylistFile (name, size)]; (*add this file to current node *)
1223 in
1224 let find_tab_dir tabs = (* find the node of last directory for this tab *)
1225 let nlist = List.assq tabs !tablist in
1226 nlist (* return list ref *)
1227 in
1228 let rec parse lines ctabs clist =
1229 (match lines with
1230 | first :: tail ->
1231 let ltabs = count_tabs first 0 in (* count lines tabs *)
1232 (match (String2.split first '|') with
1233 | dir :: [] -> (* if line is directory *)
1234 let dir = String2.after dir ltabs in
1235 if ltabs = ctabs then begin
1236 let nlist = find_tab_dir (ltabs-1) in
1237 add_dir dir ltabs nlist;
1238 if (tail <> []) then begin
1239 let nlist = find_tab_dir ltabs in
1240 parse tail ltabs nlist
1241 end
1242 end else if ltabs > ctabs then begin
1243 add_dir dir ltabs clist;
1244 let nlist = find_tab_dir ltabs in
1245 if (tail <> []) then parse tail ltabs nlist
1246 end else begin
1247 let nlist = find_tab_dir ltabs in
1248 parse lines ltabs nlist
1249 end
1250 | name :: size :: [] -> (* if line is file *)
1251 let name = String2.after name ltabs in
1252 if ltabs > ctabs then begin
1253 add_file name size clist;
1254 if (tail <> []) then parse tail ctabs clist
1255 end else if ltabs <= ctabs then begin
1256 let nlist = find_tab_dir (ltabs-1) in
1257 add_file name size nlist;
1258 parse tail (ltabs-1) nlist
1259 end
1260 | _ -> failwith (Printf.sprintf "Unknown line (%s)" first ) )
1261 | [] -> () )
1262 in
1263 parse lines (pred 0) mlist;
1264
1265 html_mods_cntr_init ();
1266 let line = ref 0 in
1267 if use_html_mods o then dc_filelist_files_print_html_header buf;
1268 let rec print node dir tabs =
1269 incr line;
1270 (match node with
1271 | MylistFile (name, size) ->
1272 filelist_file_print true (spaces tabs) username dir name size empty_string !line o;
1273 (*lprintf_nl "(%s) (%s)" (!spaces ^ name) (Int64.to_string size);*)
1274 | MylistDirectory (name, nlist) ->
1275 let dir =
1276 if dir = "" then name
1277 else dir ^ "/" ^ name
1278 in
1279 filelist_file_print false (spaces tabs) username dir name empty_string empty_string !line o;
1280 (*lprintf_nl "(%s) list_count=(%d)" (!spaces ^ dir) (List.length !nlist);*)
1281
1282 List.iter (fun node -> print node dir (tabs+1)) !nlist )
1283 in
1284 List.iter (fun node -> print node empty_string 0) !mlist;
1285 if use_html_mods o then Printf.bprintf buf "\\</table\\>\\</div\\>";
1286 with e ->
1287 if !verbose_unexpected_messages then
1288 lprintf_nl "dcshowfilelist: (%s) in .DcLst parsing" (Printexc2.to_string e) )
1289 with _ -> if !verbose_unexpected_messages then lprintf_nl "Error in che3 decompressing" )
1290
1291 end else if (extension = mylistxmlbz2_ext) then begin (* parse .xml.bz2 *)
1292 (try (* try to unzip *)
1293 let s = Buffer.contents (file_to_bz2_to_buffer (Filename.concat filelist_directory filename)) in
1294 (try (* try to parse xml and make a www page *)
1295 let xml = Xml.parse_string s in
1296 let parse_xml_chars s = (* in xml there are html-escapes mixed in *)
1297 let s = dc_replace_str_to_str s "&amp;" "&" in
1298 s
1299 in
1300 if ((Xml.tag xml) <> "FileListing") then failwith "Xml-file don't start with FileListing";
1301 html_mods_cntr_init ();
1302 let line = ref 1 in
1303 if use_html_mods o then dc_filelist_files_print_html_header buf;
1304 let rec parse x dir ndirs = (* iterate this with all xml elements (one node with tag and attributes *)
1305 let tag = Xml.tag x in
1306 let dir =
1307 if tag = "File" then dir (* if tag of element is file, return existing dir name *)
1308 else begin (* else this is "probably" a directory *)
1309 let newdir = Xml.attrib x "Name" in (* get dir name *)
1310 if dir = "" then newdir (* if this is first dir to add, don't add the "/" *)
1311 else dir ^ "/" ^ newdir (* else add this new dir path name to existing dir *)
1312 end
1313 in
1314 (match tag with
1315 | "File" -> (* is this xml element is a file element, add its line to http-page *)
1316 let fname = Xml.attrib x "Name" in
1317 let fname = parse_xml_chars fname in
1318 let fsize = Xml.attrib x "Size" in
1319 let ftth = Xml.attrib x "TTH" in
1320 let dir = dir in
1321 filelist_file_print true (spaces ndirs) username dir fname fsize ftth !line o;
1322 | "Directory" -> (* or if it is a directory element, add its line to http-page *)
1323 let fname = Xml.attrib x "Name" in
1324 let fname = parse_xml_chars fname in
1325 let fsize = empty_string in
1326 let ftth = empty_string in
1327 let dir = dir in
1328 filelist_file_print false (spaces ndirs) username dir fname fsize ftth !line o;
1329 | _ -> failwith "Tag not File or Directory" );
1330 incr line;
1331 Xml.iter (fun x -> parse x dir (ndirs+1)) x
1332 in
1333 Xml.iter (fun x -> parse x empty_string 0) xml;
1334 if use_html_mods o then Printf.bprintf buf "\\</table\\>\\</div\\>";
1335 with
1336 | Error e -> if !verbose_unexpected_messages then lprintf_nl "%s" (Xml.error e)
1337 | e -> if !verbose_unexpected_messages then
1338 lprintf_nl "dcshowfilelist: (%s) in xml parsing" (Printexc2.to_string e) )
1339 with _ -> if !verbose_unexpected_messages then lprintf_nl "Error in bz2 unzipping" )
1340 end else if !verbose_unexpected_messages then lprintf_nl "dcshowfilelist: Filelist extension not valid" );
1341 empty_string
1342 ), "<name> : Show filelist for user";
1343
1344 "dcautoconnect", Arg_two (fun arg1 arg2 o ->
1345 (try
1346 let s = Hashtbl.find servers_by_ip arg2 in
1347 let auto = bool_of_string arg1 in
1348 s.server_autoconnect <- auto;
1349 server_must_update s
1350 with _ -> () );
1351 "ok"
1352 ), "<true/false> <ip> : Set/unset the server autoconnection state";
1353
1354 ] (* end of let commands = *)
1355
1356 module P = GuiTypes
1357
1358 (* register user operations *)
1359 let _ =
1360 register_commands commands;
1361
1362 user_ops.op_user_info <- (fun user -> (* CHECK *)
1363 {
1364 P.user_num = user.user_user.impl_user_num;
1365 P.user_md4 = Md4.null;
1366 P.user_name = user.user_nick;
1367 P.user_ip = Ip.null;
1368 P.user_port = 0;
1369 P.user_tags =
1370 (let list =
1371 if user.user_data > 1. then
1372 [ { tag_name = Field_UNKNOWN "link"; tag_value = String user.user_link };
1373 { tag_name = Field_UNKNOWN "shared"; tag_value = String (
1374 Printf.sprintf "%12.0f" user.user_data) } ]
1375 else []
1376 in
1377 (match user.user_type with
1378 | Normal | Vip -> list
1379 | Op -> { tag_name = Field_UNKNOWN "admin"; tag_value = String "admin" } :: list ) );
1380 P.user_server =
1381 (match user.user_servers with
1382 | [] -> 0
1383 | s :: _ -> s.server_server.impl_server_num );
1384 }
1385 );
1386 user_ops.op_user_remove <- (fun user -> () )
1387 (*
1388 user_ops.op_user_browse_files <- (fun user ->
1389 let c = client_of_user user in
1390 contact_add (as_client c.client_client)
1391 );
1392 user_ops.op_user_set_friend <- (fun user ->
1393 let c = client_of_user user in
1394 friend_add (as_client c.client_client)
1395 )
1396
1397 mutable op_user_network : network;
1398 mutable op_user_set_friend : ('a -> unit);
1399 mutable op_user_browse_files : ('a -> unit);
1400
1401
1402 *)
1403
1404 (*module C = CommonTypes
1405 let _ =
1406 result_ops.op_result_info <- (fun r ->
1407 {
1408 C.result_num = r.result_result.impl_result_num;
1409 C.result_network = network.network_num;
1410
1411 C.result_names = [r.result_name];
1412 C.result_md4 = Md4.null;
1413 C.result_size = r.result_size;
1414 C.result_format = result_format_of_name r.result_name;
1415 C.result_type = result_media_of_name r.result_name;
1416 C.result_tags = [];
1417 C.result_comment = "";
1418 C.result_done = false;
1419 }
1420 )
1421 *)
1422
1423
1424 (* register file operations *)
1425 let _ =
1426 file_ops.op_file_info <- (fun file ->
1427 {
1428 P.file_fields = Fields_file_info.all;
1429 P.file_comment = empty_string;
1430 P.file_name = file.file_name;
1431 P.file_num = (file_num file);
1432 P.file_network = network.network_num;
1433 P.file_names = [file.file_name];
1434 P.file_md4 = Md4.null;
1435 P.file_size = file_size file;
1436 P.file_downloaded = file_downloaded file;
1437 P.file_all_sources = 0;
1438 P.file_active_sources = 0;
1439 P.file_state = file_state file;
1440 P.file_sources = None;
1441 P.file_download_rate = file_download_rate file.file_file;
1442 P.file_chunks = None;
1443 P.file_chunk_size = None;
1444 P.file_availability = [network.network_num, "0"];
1445 P.file_format = FormatUnknown;
1446 P.file_chunks_age = [|0|];
1447 P.file_age = file_age file;
1448 P.file_last_seen = BasicSocket.last_time ();
1449 P.file_priority = file_priority (as_file file.file_file);
1450 P.file_uids = [];
1451 P.file_sub_files = [];
1452 P.file_comments = [];
1453 P.file_magic = None;
1454 P.file_user = empty_string;
1455 P.file_group = empty_string;
1456 P.file_release = false;
1457 }
1458 );
1459 file_ops.op_file_all_sources <- (fun file ->
1460 List2.tail_map (fun c -> as_client c.client_client)
1461 file.file_clients
1462 );
1463 file_ops.op_file_active_sources <- file_ops.op_file_all_sources;
1464 file_ops.op_file_cancel <- (fun file ->
1465 let remove_files_clients_not_downloading () =
1466 List.iter (fun c ->
1467 (match c.client_state with
1468 | DcDownload f -> () (* only one client should be in this state *)
1469 | _ ->
1470 remove_client c )
1471 ) file.file_clients;
1472 in
1473 (try
1474 List.iter (fun c -> (* find one files client that is currently downloading *)
1475 (match c.client_state with
1476 | DcDownload _ -> raise (Found_client c)
1477 | _ -> () )
1478 ) file.file_clients;
1479 raise Not_found
1480 with
1481 | Found_client c -> (* found a download slot tried to continue *)
1482 (match (DcClients.find_next_client c) with (* try to continue slot *)
1483 | Some cl ->
1484 (match c.client_sock with
1485 | Connection sock ->
1486 remove_files_clients_not_downloading ();
1487 remove_file_not_clients file;
1488 c.client_receiving <- Int64.zero;
1489 c.client_pos <- Int64.zero;
1490 TcpBufferedSocket.set_rtimeout sock 30.;
1491 DcClients.next_download false c sock cl (* try to change downloading *)
1492 | _ -> () )
1493 | None ->
1494 remove_files_clients_not_downloading ();
1495 remove_file_not_clients file;
1496 c.client_state <- DcIdle;
1497 (match c.client_sock with
1498 | Connection sock -> TcpBufferedSocket.close sock (Closed_for_error "File cancelled")
1499 | _ -> () )
1500 )
1501 | Not_found ->
1502 remove_file_with_clients file );
1503 if !verbose_download then lprintf_nl "File %s cancelled" file.file_name;
1504 );
1505 file_ops.op_file_commit <- (fun file name ->
1506 remove_file_with_clients file;
1507 );
1508 file_ops.op_file_pause <- (fun file ->
1509 (try
1510 List.iter (fun c ->
1511 (match c.client_state with
1512 | DcDownload f -> if file == f then raise (Found_client c)
1513 | _ -> () )
1514 ) file.file_clients;
1515 raise Not_found
1516 with
1517 | Found_client c ->
1518 (match (DcClients.find_next_client c) with (* try to continue slot *)
1519 | Some cl ->
1520 (match c.client_sock with
1521 | Connection sock ->
1522 DcClients.next_download true c sock cl (* try to change downloading *)
1523 | _ -> () )
1524 | None -> c.client_state <- DcIdle (* DcPaused ? *))
1525 | Not_found -> () ) (* Should not happen *)
1526 );
1527
1528 (*
1529 file_ops.op_file_files <- (fun file impl ->
1530 match file.file_swarmer with
1531 None -> [CommonFile.as_file impl]
1532 | Some swarmer ->
1533 CommonSwarming.subfiles swarmer)
1534 ; *)
1535 (*
1536 file_ops.op_file_save_as <- (fun file new_name ->
1537 match file_state file with
1538 FileDownloaded | FileShared ->
1539 DcClients.save_file_as file new_name
1540 | _ -> ()
1541 );
1542 *)
1543
1544 (*let client_of_user user =
1545 let c = new_client user.user_nick in
1546 c
1547
1548 *)
1549
1550 (*
1551 mutable op_file_network : network; *)
1552 file_ops.op_file_save_as <- (fun _ _ -> ());
1553 file_ops.op_file_resume <- (fun _ -> ());
1554 file_ops.op_file_set_format <- (fun _ _ -> ());
1555 file_ops.op_file_check <- (fun _ -> ());
1556 file_ops.op_file_recover <- (fun _ -> ())
1557 (*file_ops.op_file_print_html <- (fun _ _ -> lprintf_nl "Received (op_file_print_html)"; ());*)
1558 (*file_ops.op_file_print_sources_html <- (fun _ _ -> lprintf_nl "Received (op_file_print_sources_html)"; ())*)
1559 (* mutable op_file_files : ('a -> 'a file_impl -> file list);
1560 mutable op_file_debug : ('a -> string);
1561 mutable op_file_proposed_filenames : ('a -> string list);
1562 *)
1563
1564 let _ =
1565 CommonWeb.add_web_kind "hublist" "DirectConnect hublist"
1566 (fun url filename ->
1567 if !!enable_directconnect then
1568 begin
1569 try
1570 dc_hublist := (
1571 match List.rev (String2.split filename '.') with
1572 | "bz2"::"xml"::_ -> DcServers.make_hublist_from_xml (Xml.parse_file (Misc2.bz2_extract filename))
1573 | "xml"::_ -> DcServers.make_hublist_from_xml (Xml.parse_file filename)
1574 | "bz2"::_ -> DcServers.make_hublist_from_file (Misc2.bz2_extract filename)
1575 | _ -> DcServers.make_hublist_from_file filename);
1576 lprintf_nl "loaded dc++ hublist, %d entries" (List.length !dc_hublist)
1577 with e ->
1578 if !verbose_msg_servers then
1579 lprintf_nl "(%s) in loading/parsing serverlist" (Printexc2.to_string e);
1580 raise Not_found
1581 end
1582 else
1583 begin
1584 lprintf_nl "DirectConnect module is disabled, ignoring...";
1585 raise Not_found
1586 end
1587 )
mldonkey - cross-platform multi-network p2p daemon