?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
patch #7355
[mldonkey.git] / src / daemon / driver / driverControlers.ml
blob8ed3b96144c1be252d2424a5f1e5e19f6c892df6
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 Printf2
22 open CommonResult
23 open CommonInteractive
24 open CommonNetwork
25 open CommonSearch
26 open CommonTypes
27 open CommonGlobals
28 open CommonShared
29 open GuiTypes
30 open CommonComplexOptions
31 open CommonFile
32 open Options
33 open BasicSocket
34 open TcpBufferedSocket
35 open DriverGraphics
36 open DriverInteractive
37 open CommonOptions
38 open CommonUserDb
39
40 let log_prefix = "[dCon]"
41
42 let lprintf_nl fmt =
43 lprintf_nl2 log_prefix fmt
44
45 let lprintf_n fmt =
46 lprintf2 log_prefix fmt
47
48 let rec dollar_escape o with_frames s =
49 String2.convert false (fun b escaped c ->
50 if escaped then
51 match c with
52 | 'O' -> if with_frames then
53 if !!html_mods then Buffer.add_string b "output"
54 else Buffer.add_string b " target=\"output\"";
55 false
56 | 'S' -> if with_frames then
57 if !!html_mods then Buffer.add_string b "fstatus"
58 else Buffer.add_string b " target=\"fstatus\"";
59 false
60 | 'P' -> if with_frames then
61 if !!html_mods then Buffer.add_string b "_parent"
62 else Buffer.add_string b " target=\"_parent\"";
63 false
64 | 'G' -> false
65
66 | 'r' ->
67 if o.conn_output = ANSI then
68 Buffer.add_string b Terminal.ANSI.ansi_RED;
69 false
70
71 | 'b' ->
72 if o.conn_output = ANSI then
73 Buffer.add_string b Terminal.ANSI.ansi_BLUE;
74 false
75
76 | 'g' ->
77 if o.conn_output = ANSI then
78 Buffer.add_string b Terminal.ANSI.ansi_GREEN;
79 false
80
81 | 'c' ->
82 if o.conn_output = ANSI then
83 Buffer.add_string b Terminal.ANSI.ansi_CYAN;
84 false
85
86 | 'n' ->
87 if o.conn_output = ANSI then
88 Buffer.add_string b Terminal.ANSI.ansi_NORMAL;
89 false
90
91 | _ ->
92 (*
93 try
94 Buffer.add_string b (dollar_escape with_frames
95 (CommonNetwork.escape_char c));
96 false
97
98 with _ -> *)
99 Buffer.add_char b '$'; Buffer.add_char b c; false
100 else
101 if c = '$' then true else
102 (Buffer.add_char b c; false)) s
103
104 let eval auth cmd o =
105 let buf = o.conn_buf in
106 let cmd =
107 if String2.check_prefix cmd "ed2k://" ||
108 String2.check_prefix cmd "ftp://" ||
109 String2.check_prefix cmd "http://" then "dllink " ^ cmd
110 else if String2.check_prefix cmd "fha://" then "ovlink " ^ cmd
111 else cmd in
112 let l = String2.tokens cmd in
113 match l with
114 | [] -> ()
115 | "longhelp"::subs | "??"::subs ->
116 let filter cmd = List.for_all (String2.contains cmd) subs in
117 let module M = CommonMessages in
118 if o.conn_output = HTML then begin
119 Buffer.add_string buf "\\<div class=\\\"cs\\\"\\>";
120 html_mods_table_header buf "helpTable" "results" [];
121 Buffer.add_string buf "\\<tr\\>";
122 html_mods_td buf [
123 ("", "srh", M.available_commands_are);
124 ("", "srh", "");
125 ("", "srh", ""); ];
126 Buffer.add_string buf "\\</tr\\>";
127 html_mods_cntr_init ();
128 let show (cmd, _, _, help) =
129 let ncmd = ref cmd in (* why? *)
130 let nhelp = ref help in
131 Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
132 html_mods_td buf [
133 ("", "sr", "\\<a href=\\\"submit?q=" ^ !ncmd ^
134 "\\\"\\>" ^ !ncmd ^ "\\</a\\>");
135 ("", "srw", Str.global_replace (Str.regexp "\n") "\\<br\\>" !nhelp);
136 ("", "sr", "\\<a href=\\\"http://mldonkey.sourceforge.net/" ^ (String2.upp_initial !ncmd) ^
137 "\\\"\\>wiki\\</a\\>"); ];
138 Printf.bprintf buf "\\</tr\\>\n";
139 in
140 List.iter show
141 (List.sort (fun (c1,_, _,_) (c2,_, _,_) -> compare c1 c2)
142 (List.filter (fun (c,_,_,_) -> filter c) !CommonNetwork.network_commands));
143 Printf.bprintf buf "\\</table\\>\\</div\\>";
144 html_mods_table_header buf "helpTable" "results" [];
145 Printf.bprintf buf "\\<tr class=\\\"dl-1\\\"\\>";
146 html_mods_td buf [
147 ("", "sr", "< > : required parameter");
148 ("", "sr", "[< >] : optional parameter");
149 ("", "sr", "< 1 | 2 > : alternative parameter"); ];
150 Printf.bprintf buf "\\</table\\>\\</div\\>\\</div\\>"
151 end else
152 begin
153 Buffer.add_string buf M.available_commands_are;
154 let list = Hashtbl2.to_list2 commands_by_kind in
155 let list = List.sort (fun (s1,_) (s2,_) -> compare s1 s2) list in
156 List.iter (fun (s,list) ->
157 match List.sort (fun (s1,_) (s2,_) -> compare s1 s2) (List.filter (fun (s,_) -> filter s) !list) with
158 | [] -> ()
159 | list ->
160 Printf.bprintf buf "\n $b%s$n:\n" s;
161 List.iter (fun (cmd, help) -> Printf.bprintf buf "$r%s$n %s\n" cmd help) list
162 ) list;
163 end
164
165 | ["help"] | ["?"] | ["man"] ->
166 let module M = CommonMessages in
167 if o.conn_output = HTML then
168 begin
169 Buffer.add_string buf "\\<div class=\\\"cs\\\"\\>";
170 html_mods_table_header buf "helpTable" "results" [];
171 Buffer.add_string buf "\\<tr\\>";
172 html_mods_td buf [
173 ("", "srh", M.main_commands_are);
174 ("", "srh", ""); ];
175 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-1\\\"\\>";
176 html_mods_td buf [
177 ("", "sr", "$bServers:$n");
178 ("", "sr", ""); ];
179 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
180 html_mods_td buf [
181 ("", "sr", "$r\\<a href=\\\"submit?q=vm\\\"\\>" ^
182 "vm\\</a\\>$n");
183 ("", "sr", "list connected servers"); ];
184 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
185 html_mods_td buf [
186 ("", "sr", "$r\\<a href=\\\"submit?q=vma\\\"\\>" ^
187 "vma\\</a\\>$n");
188 ("", "sr", "list all servers"); ];
189 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
190 html_mods_td buf [
191 ("", "sr", "$rc/x <num>$n");
192 ("", "sr", "connect/disconnect from a server"); ];
193 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-1\\\"\\>";
194 html_mods_td buf [
195 ("", "sr", "$bDownloads:$n");
196 ("", "sr", ""); ];
197 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
198 html_mods_td buf [
199 ("", "sr", "$r\\<a href=\\\"submit?q=vd\\\"\\>" ^
200 "vd\\</a\\>$n");
201 ("", "sr", "view current downloads"); ];
202 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
203 html_mods_td buf [
204 ("", "sr", "$rcancel/pause/resume <num>$n");
205 ("", "sr", "cancel/pause/resume download <num>"); ];
206 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-1\\\"\\>";
207 html_mods_td buf [
208 ("", "sr", "$bSearches:$n");
209 ("", "sr", ""); ];
210 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
211 html_mods_td buf [
212 ("", "sr", "$rs <keywords>$n");
213 ("", "sr", "start a search for keywords <keywords> on the network"); ];
214 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
215 html_mods_td buf [
216 ("", "sr", "$r\\<a href=\\\"submit?q=vr\\\"\\>" ^
217 "vr\\</a\\>$n");
218 ("", "sr", "view results of the last search"); ];
219 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
220 html_mods_td buf [
221 ("", "sr", "$rd <num>$n");
222 ("", "sr", "download result number <num>"); ];
223 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
224 html_mods_td buf [
225 ("", "sr", "$r\\<a href=\\\"submit?q=vs\\\"\\>" ^
226 "vs\\</a\\>$n");
227 ("", "sr", "view previous searches"); ];
228 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
229 html_mods_td buf [
230 ("", "sr", "$rvr <num>$n");
231 ("", "sr", "view results of search <num>"); ];
232 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-1\\\"\\>";
233 html_mods_td buf [
234 ("", "sr", "$bGeneral:$n");
235 ("", "sr", ""); ];
236 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
237 html_mods_td buf [
238 ("", "sr", "$r\\<a href=\\\"submit?q=save\\\"\\>" ^
239 "save\\</a\\>$n");
240 ("", "sr", "save configuration files"); ];
241 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
242 html_mods_td buf [
243 ("", "sr", "$rkill$n");
244 ("", "sr", "kill mldonkey properly"); ];
245 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-2\\\"\\>";
246 html_mods_td buf [
247 ("", "sr", "$rq$n");
248 ("", "sr", "quit this interface"); ];
249 Buffer.add_string buf "\\</tr\\>\\</table\\>\\</div\\>\n";
250 html_mods_table_header buf "helpTable" "results" [];
251 Buffer.add_string buf "\\<tr class=\\\"dl-1\\\"\\>";
252 html_mods_td buf [
253 ("", "sr", "Use '$r\\<a href=\\\"submit?q=longhelp\\\"\\>" ^
254 "longhelp\\</a\\>$n' or '$r\\<a href=\\\"submit?q=longhelp\\\"\\>" ^
255 "??\\</a\\>$n' for all commands. Specify substring to filter."); ];
256 Buffer.add_string buf "\\</tr\\>\\<tr class=\\\"dl-1\\\"\\>";
257 html_mods_td buf [
258 ("", "sr", "Use '$rhelp command$n' or '$r? command$n' for help on a command."); ];
259 Buffer.add_string buf "\\</tr\\>\\</table\\>\\</div\\>\\</div\\>\n"
260 end
261 else
262 Buffer.add_string buf
263 "Main commands are:
264
265 $bServers:$n
266 $rvm$n : list connected servers
267 $rvma$n : list all servers
268 $rc/x <num>$n : connect/disconnect from a server
269
270 $bDownloads:$n
271 $rvd$n : view current downloads
272 $rcancel/pause/resume <num>$n : cancel/pause/resume download <num>
273
274 $bSearches:$n
275 $rs <keywords>$n : start a search for keywords <keywords> on the network
276 $rvr$n : view results of the last search
277 $rd <num>$n : download result number <num>
278 $rvs$n : view previous searches
279 $rvr <num>$n : view results of search <num>
280
281 $bGeneral:$n
282 $rsave$n : save configuration files
283 $rkill$n : kill mldonkey properly
284 $rq$n : quit this interface
285
286 Use '$rlonghelp$n' or '$r??$n' for all commands.
287 Use '$rlonghelp str$n' or '$r?? str$n' for all commands that contain specified substring.
288 Use '$rhelp command$n' or '$r? command$n' for help on a command.
289 ";
290 | "?" :: args | "help" :: args | "man" :: args ->
291 List.iter (fun arg ->
292 match List.filter (fun (cmd, _, _, _) -> cmd = arg) !CommonNetwork.network_commands with
293 | [] -> Printf.bprintf buf "Unknown command : %s\n" arg
294 | l -> List.iter (fun (_,_,_,help) -> Printf.bprintf buf "%s %s\n" arg help) l)
295 args
296 | one :: two ->
297 let cmd, args =
298 (try
299 let command = List.assoc one !!alias_commands in
300 match String2.split command ' ' with
301 [] -> raise Not_found (* can't happen *)
302 | [a] -> a, two
303 | a::b -> a, (b @ two)
304 with
305 Not_found -> one, two)
306 in
307 if cmd = "q" then
308 raise CommonTypes.CommandCloseSocket
309 else
310 if cmd = "auth" then
311 let user, pass =
312 match args with
313 [] -> failwith "Usage: auth <user> <password>"
314 | [s1] -> (admin_user ()).CommonTypes.user_name, s1
315 | user :: pass :: _ -> user, pass
316 in
317 if valid_password user pass then begin
318 auth := true;
319 o.conn_user <- find_ui_user user;
320 if not !verbose_no_login then lprintf_nl "Authenticated user: %s" user;
321 let module M = CommonMessages in
322 Buffer.add_string buf M.full_access;
323 (match DriverInteractive.real_startup_message () with
324 Some s -> Buffer.add_string buf ("\n" ^ s);
325 | None -> ());
326 end else
327 let module M = CommonMessages in
328 Buffer.add_string buf M.bad_login
329 else
330 if !auth then
331 DriverCommands.execute_command
332 !CommonNetwork.network_commands o cmd args
333 else
334 let module M = CommonMessages in
335 Buffer.add_string buf M.command_not_authorized
336
337
338 (* This function is called every hour to check if we have something to do
339 just now *)
340
341 let calendar_options = {
342 conn_buf = Buffer.create 1000;
343 conn_output = TEXT;
344 conn_sortvd = NotSorted;
345 conn_filter = (fun _ -> ());
346 conn_user = find_ui_user CommonUserDb.admin_user_name;
347 conn_width = 80; conn_height = 0;
348 conn_info = Some (CALENDAR, (Ip.null, 0));
349 }
350
351 let check_calendar () =
352 let time = last_time () in
353 let tm = Unix.localtime (date_of_int time) in
354 List.iter (fun (days, hours, command) ->
355 if (List.mem tm.Unix.tm_wday days || days = []) &&
356 (List.mem tm.Unix.tm_hour hours || hours = []) then begin
357 lprintf_nl "Calendar execute: %s" command;
358 eval (ref true) command calendar_options;
359 lprintf_nl "Calendar result: %s" (Buffer.contents calendar_options.conn_buf);
360 Buffer.reset calendar_options.conn_buf;
361 end
362 ) !!calendar
363
364
365 (*************************************************************
366
367 The Telnet Server
368
369 **************************************************************)
370
371 let before_telnet_output o sock =
372 if o.conn_output = ANSI && o.conn_height <> 0 then
373 write_string sock (Printf.sprintf
374 "%s%s\n%s%s"
375 (Terminal.gotoxy 0 (o.conn_height-3))
376 Terminal.ANSI.ansi_CLREOL
377 Terminal.ANSI.ansi_CLREOL
378 (Terminal.gotoxy 0 (o.conn_height-3)))
379
380 let after_telnet_output o sock =
381 if o.conn_output = ANSI && o.conn_height <> 0 then
382 write_string sock (Printf.sprintf "\n\n%s"
383 (Terminal.gotoxy 0 (o.conn_height - 2)));
384 if o.conn_output = ANSI then
385 write_string sock (Printf.sprintf "%sMLdonkey command-line:%s\n> "
386 Terminal.ANSI.ansi_REVERSE
387 Terminal.ANSI.ansi_NORMAL)
388
389 (*
390 let user_reader o telnet sock nread =
391 let b = TcpBufferedSocket.buf sock in
392 let end_pos = b.pos + b.len in
393 let new_pos = end_pos - nread in
394 let rec iter i =
395 let end_pos = b.pos + b.len in
396 for i = b.pos to b.pos + b.len - 1 do
397 let c = int_of_char b.buf.[i] in
398 if c <> 13 && c <> 10 && (c < 32 || c > 127) then
399 lprintf "term[%d] = %d\n" i c;
400 done;
401
402 if i < end_pos then
403 let c = b.buf.[i] in
404 let c = int_of_char c in
405 if c = 13 || c = 10 || c = 0 then
406 let len = i - b.pos in
407 let cmd = String.sub b.buf b.pos len in
408 buf_used sock (len+1);
409 if cmd <> "" then begin
410 before_telnet_output o sock;
411 let buf = o.conn_buf in
412 Buffer.reset buf;
413 if o.conn_output = ANSI then Printf.bprintf buf "> $c%s$n\n" cmd;
414 eval telnet.telnet_auth cmd o;
415 Buffer.add_char buf '\n';
416 if o.conn_output = ANSI then Buffer.add_string buf "$n";
417 TcpBufferedSocket.write_string sock
418 (dollar_escape o false (Buffer.contents buf));
419 after_telnet_output o sock;
420 end;
421 iter b.pos
422 else
423 iter (i+1)
424 in
425 try
426 iter new_pos
427 with
428 | CommonTypes.CommandCloseSocket ->
429 (try
430 shutdown sock "user quit";
431 with _ -> ());
432 | e ->
433 before_telnet_output o sock;
434 TcpBufferedSocket.write_string sock
435 (Printf.sprintf "exception [%s]\n" (Printexc2.to_string e));
436 after_telnet_output o sock
437 *)
438
439 type telnet_state =
440 EMPTY
441 | STRING
442 | IAC
443 | WILL
444 | WONT
445 | DO
446 | DONT
447 | NAWS
448 | SB
449
450 type telnet_conn = {
451 telnet_buffer : Buffer.t;
452 mutable telnet_iac : bool;
453 mutable telnet_wait : int;
454 telnet_auth : bool ref;
455 }
456
457 let iac_will_8bit = "\255\253\000"
458 let iac_will_naws = "\255\253\031"
459
460 let user_reader o telnet sock nread =
461 let b = TcpBufferedSocket.buf sock in
462 let rec iter () =
463 if b.len > 0 then
464 let c = b.buf.[b.pos] in
465 buf_used b 1;
466 (* lprintf "char %d\n" (int_of_char c); *)
467 if c = '\255' && not telnet.telnet_iac then begin
468 telnet.telnet_iac <- true;
469 iter ()
470 end else
471 if c <> '\255' && telnet.telnet_iac then begin
472 telnet.telnet_iac <- false;
473 (match c with
474 '\250' | '\251' ->
475 Buffer.add_char telnet.telnet_buffer c;
476 telnet.telnet_wait <- 1
477 | _ ->
478 Buffer.reset telnet.telnet_buffer
479 );
480 iter ()
481 end else
482
483 let i = int_of_char c in
484 telnet.telnet_iac <- false;
485 let is_normal_char = i > 31 in
486
487 if telnet.telnet_wait = 1 then begin
488 Buffer.add_char telnet.telnet_buffer c;
489 let cmd = Buffer.contents telnet.telnet_buffer in
490 telnet.telnet_wait <- 0;
491 let len = String.length cmd in
492 if len = 2 then
493 match cmd with
494 "\251\031" ->
495 Buffer.reset telnet.telnet_buffer
496 | "\250\031" ->
497 telnet.telnet_wait <- 4
498 | _ ->
499 (*
500 lprintf "telnet server: Unknown control sequence %s\n"
501 (String.escaped cmd); *)
502 Buffer.reset telnet.telnet_buffer
503 else
504 let s = String.sub cmd 0 2 in
505 Buffer.reset telnet.telnet_buffer;
506 match s with
507 | "\250\031" ->
508 let dx = BigEndian.get_int16 cmd 2 in
509 let dy = BigEndian.get_int16 cmd 4 in
510 o.conn_width <- dx;
511 o.conn_height <- dy;
512 (* lprintf "SIZE RECEIVED %d x %d\n" dx dy; *)
513 | _ ->
514 (*
515 lprintf "telnet server: Unknown control sequence %s\n"
516 (String.escaped cmd); *)
517 ()
518 end else
519 if telnet.telnet_wait > 1 then begin
520 Buffer.add_char telnet.telnet_buffer c;
521 telnet.telnet_wait <- telnet.telnet_wait - 1;
522 end else
523 if is_normal_char then
524 Buffer.add_char telnet.telnet_buffer c
525 else begin
526 (* evaluate the command *)
527 let cmd = Buffer.contents telnet.telnet_buffer in
528 Buffer.reset telnet.telnet_buffer;
529 if cmd <> "" then begin
530 before_telnet_output o sock;
531 let buf = o.conn_buf in
532 Buffer.reset buf;
533 if o.conn_output = ANSI then Printf.bprintf buf "> $c%s$n\n" cmd;
534 eval telnet.telnet_auth cmd o;
535 Buffer.add_char buf '\n';
536 if o.conn_output = ANSI then Buffer.add_string buf "$n";
537 TcpBufferedSocket.write_string sock
538 (dollar_escape o false (Buffer.contents buf));
539 after_telnet_output o sock;
540 end;
541 if i = 255 then telnet.telnet_wait <- 2;
542 end;
543 iter ()
544 in
545 try
546 iter ()
547 with
548 | CommonTypes.CommandCloseSocket ->
549 (try
550 shutdown sock Closed_by_user;
551 with _ -> ());
552 | e ->
553 before_telnet_output o sock;
554 TcpBufferedSocket.write_string sock
555 (Printf.sprintf "exception [%s]\n" (Printexc2.to_string e));
556 after_telnet_output o sock
557
558
559 let user_closed sock msg =
560 user_socks := List2.removeq sock !user_socks;
561 ()
562
563 let telnet_handler t event =
564 match event with
565 TcpServerSocket.CONNECTION (s, Unix.ADDR_INET (from_ip, from_port)) ->
566 let from_ip = Ip.of_inet_addr from_ip in
567 if not !verbose_no_login then lprintf_nl "Telnet connection from %s" (Ip.to_string from_ip);
568 let token = create_token unlimited_connection_manager in
569 let sock = TcpBufferedSocket.create_simple token
570 "telnet connection"
571 s in
572 let telnet = {
573 telnet_auth = ref (has_empty_password (admin_user ()));
574 telnet_iac = false;
575 telnet_wait = 0;
576 telnet_buffer = Buffer.create 100;
577 } in
578 let o = {
579 conn_buf = Buffer.create 1000;
580 conn_output = (if !!term_ansi then ANSI else TEXT);
581 conn_sortvd = NotSorted;
582 conn_filter = (fun _ -> ());
583 conn_user = find_ui_user CommonUserDb.admin_user_name;
584 conn_width = 80;
585 conn_height = 0;
586 conn_info = Some (TELNET, (from_ip, from_port));
587 } in
588 (match Ip_set.match_ip !allowed_ips_set from_ip with
589 | true ->
590 TcpBufferedSocket.prevent_close sock;
591 TcpBufferedSocket.set_max_output_buffer sock !!interface_buffer;
592 TcpBufferedSocket.set_reader sock (user_reader o telnet);
593 TcpBufferedSocket.set_closer sock user_closed;
594 user_socks := sock :: !user_socks;
595
596 TcpBufferedSocket.write_string sock iac_will_8bit;
597 TcpBufferedSocket.write_string sock iac_will_naws;
598
599 before_telnet_output o sock;
600 TcpBufferedSocket.write_string sock
601 (Printf.sprintf "Welcome to MLDonkey %s\n" Autoconf.current_version);
602
603 TcpBufferedSocket.write_string sock (dollar_escape o false
604 "$cWelcome on mldonkey command-line$n\n\nUse $r?$n for help\n\n");
605
606 after_telnet_output o sock
607
608 | false ->
609 before_telnet_output o sock;
610 let reject_message =
611 Printf.sprintf "Telnet connection from %s rejected (see allowed_ips setting)\n"
612 (Ip.to_string from_ip)
613 in
614 TcpBufferedSocket.write_string sock (dollar_escape o false reject_message);
615 shutdown sock Closed_connect_failed;
616 if not !verbose_no_login then lprintf_n "%s" reject_message;
617 Unix.close s)
618
619 | _ -> ()
620
621 (*************************************************************
622
623 The HTTP Server
624
625 **************************************************************)
626
627 open Http_server
628
629 let buf = Buffer.create 1000
630
631 type http_file =
632 BIN
633 | HTM
634 | MLHTM
635 | TXT
636 | UNK
637
638 type file_ext =
639 BINARY
640 | CSS
641 | HTMLS
642 | ICON
643 | JPEG
644 | JAVASCRIPT
645 | MPEG
646 | AVI
647 | WMV
648 | ASF
649 | MOV
650 | OGM
651 | RM
652 | MKV
653 | PNG
654 | GIF
655 | MP3
656 | WMA
657 | OGG
658 | TEXTS
659 | UNKN
660 | WML
661
662 let http_file_type = ref UNK
663
664 let extension_to_file_ext extension =
665 match extension with
666 | "bin" -> BINARY
667 | "css" -> CSS
668 | "htm"
669 | "html" -> HTMLS
670 | "ico" -> ICON
671 | "jpe"
672 | "jpeg"
673 | "jpg" -> JPEG
674 | "js" -> JAVASCRIPT
675 | "vob"
676 | "mpe"
677 | "mpeg"
678 | "mpg" -> MPEG
679 | "avi" -> AVI
680 | "wmv" -> WMV
681 | "asf" -> ASF
682 | "mov"
683 | "movie"
684 | "qt" -> MOV
685 | "ogm" -> OGM
686 | "ra"
687 | "ram"
688 | "rm"
689 | "rmvb"
690 | "rv9"
691 | "rt" -> RM
692 | "mkv" -> MKV
693 | "png" -> PNG
694 | "gif" -> GIF
695 | "mp3" -> MP3
696 | "wma" -> WMA
697 | "ogg" -> OGG
698 | "txt" -> TEXTS
699 | "wml" -> WML
700 | _ -> UNKN
701
702 let ext_to_file_type ext =
703 match ext with
704 UNKN -> UNK
705 | BINARY -> BIN
706 | CSS -> TXT
707 | HTMLS -> HTM
708 | ICON -> BIN
709 | JAVASCRIPT -> TXT
710 | JPEG -> BIN
711 | MPEG -> BIN
712 | AVI -> BIN
713 | WMV -> BIN
714 | ASF -> BIN
715 | MOV -> BIN
716 | OGM -> BIN
717 | RM -> BIN
718 | MKV -> BIN
719 | PNG -> BIN
720 | GIF -> BIN
721 | MP3 -> BIN
722 | WMA -> BIN
723 | OGG -> BIN
724 | TEXTS -> TXT
725 | WML -> TXT
726
727 let ext_to_mime_type ext =
728 match ext with
729 UNKN -> ""
730 | BINARY -> "application/octet-stream"
731 | CSS -> "text/css"
732 | HTMLS -> "text/html"
733 | ICON -> "image/x-icon"
734 | JAVASCRIPT -> "text/javascript"
735 | JPEG -> "image/jpg"
736 | MPEG -> "video/mpeg"
737 | AVI -> "video/x-msvideo"
738 | WMV -> "video/x-ms-wmv"
739 | ASF -> "video/x-ms-asf"
740 | MOV -> "video/quicktime"
741 | OGM -> "application/ogg" (* is that correct ? *)
742 | RM -> "audio/x-pn-realaudio"
743 | MKV -> "video/x-matroska" (* is that correct ? *)
744 | PNG -> "image/png"
745 | GIF -> "image/gif"
746 | MP3 -> "audio/mpeg"
747 | WMA -> "audio/x-ms-wma"
748 | OGG -> "application/ogg" (* is that correct ? *)
749 | TEXTS -> "text/plain"
750 | WML -> "text/vnd.wap.wml"
751
752 let default_charset = "charset=UTF-8"
753
754 let get_theme_page page =
755 let theme = Filename.concat html_themes_dir !!html_mods_theme in
756 let fname = Filename.concat theme page in fname
757
758 let theme_page_exists page =
759 Sys.file_exists (get_theme_page page)
760
761 (* if files are small really_input should be okay *)
762 let read_theme_page page =
763 let theme_page = get_theme_page page in
764 Unix2.tryopen_read theme_page (fun file ->
765 let size = (Unix.stat theme_page).Unix.st_size in
766 let s = String.make size ' ' in
767 really_input file s 0 size;
768 s)
769
770 let http_add_gen_header r =
771 add_reply_header r "Server" ("MLdonkey/"^Autoconf.current_version);
772 add_reply_header r "Connection" "close"
773
774 let add_gzip_headers r =
775 if !!html_use_gzip then begin
776 add_reply_header r "Content-Encoding" "gzip";
777 add_reply_header r "Vary" "Accept-Encoding";
778 end
779
780 let http_add_html_header r =
781 let ext = extension_to_file_ext "html" in
782 http_file_type := ext_to_file_type ext;
783 http_add_gen_header r;
784 add_reply_header r "Pragma" "no-cache";
785 add_reply_header r "Content-Type" ((ext_to_mime_type ext) ^ ";" ^ default_charset);
786 add_gzip_headers r
787
788 let http_add_text_header r ext =
789 http_file_type := ext_to_file_type ext;
790 http_add_gen_header r;
791 add_reply_header r "Content-Type" ((ext_to_mime_type ext) ^ ";" ^ default_charset);
792 add_gzip_headers r
793
794 let http_add_bin_info_header r clen =
795 add_reply_header r "Accept-Ranges" "bytes";
796 add_reply_header r "Content-Length" (Printf.sprintf "%d" clen)
797 (* FIXME Content-Length is duplicated *)
798
799 let http_add_bin_header r ext clen =
800 http_file_type := ext_to_file_type ext;
801 http_add_gen_header r;
802 add_reply_header r "Content-Type" (ext_to_mime_type ext);
803 http_add_bin_info_header r clen
804
805 let http_add_bin_stream_header r ext =
806 http_file_type := BIN;
807 http_add_gen_header r;
808 let mime_type = ext_to_mime_type ext in
809 let mime_type = if mime_type <> "" then mime_type
810 else "application/binary" in
811 add_reply_header r "Content-Type" mime_type;
812 add_reply_header r "Accept-Ranges" "bytes"
813
814 let http_send_bin r buf filename =
815 let file_to_send =
816 if theme_page_exists filename then
817 File.to_string (get_theme_page filename)
818 else
819 try
820 File.to_string filename
821 with _ -> raise Not_found
822 in
823 let ext = extension_to_file_ext (Filename2.last_extension2 filename) in
824 http_add_bin_header r ext (String.length file_to_send);
825 add_reply_header r "Cache-Control" "no-cache";
826 add_reply_header r "Pragma" "no-cache";
827 Buffer.add_string buf file_to_send
828
829 let http_send_bin_pictures r buf filename =
830 let file_to_send =
831 try
832 Hashtbl.find CommonPictures.files filename
833 with Not_found ->
834 try
835 if String.sub filename 0 4 = "flag" then
836 Hashtbl.find CommonPictures.files "flag_--.png"
837 else
838 raise Not_found
839 with _ -> raise Not_found
840 in
841 let ext = extension_to_file_ext (Filename2.last_extension2 filename) in
842 http_add_bin_header r ext (String.length file_to_send);
843 Buffer.add_string buf file_to_send
844
845 let http_error_no_gd img_type =
846 match img_type with
847 "jpg" ->
848 (match Autoconf.has_gd_jpg with
849 true -> false
850 | false -> lprintf_nl "Warning: GD jpg support disabled"; true)
851 | "png" ->
852 (match Autoconf.has_gd_png with
853 true -> false
854 | false -> lprintf_nl "Warning: GD png support disabled"; true)
855 | _ ->
856 (match Autoconf.has_gd with
857 true -> false
858 | false -> lprintf_nl "Warning: GD support disabled"; true)
859 let any_ip = Ip.of_inet_addr Unix.inet_addr_any
860
861 let html_open_page buf t r open_body =
862 Buffer.reset buf;
863 http_add_html_header r;
864
865 if not !!html_mods then
866 (Buffer.add_string buf
867 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\"
868 \"http://www.w3.org/TR/html4/frameset.dtd\">\n<HTML>\n<HEAD>\n";)
869 else Buffer.add_string buf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n<html>\n<head>\n";
870 if !CommonInteractive.display_vd then begin
871 let this_page = "dheader.html" in
872 Buffer.add_string buf
873 (
874 if !!html_mods_theme <> "" && theme_page_exists this_page then
875 read_theme_page this_page else
876 if !!html_mods then !!CommonMessages.download_html_header_mods0
877 else !!CommonMessages.download_html_header_old);
878 Printf.bprintf buf "<meta http-equiv=\"refresh\" content=\"%d\">" !!vd_reload_delay;
879 end else
880 if !CommonInteractive.display_bw_stats then
881 Printf.bprintf buf "<meta http-equiv=\"refresh\" content=\"%d\">" !!html_mods_bw_refresh_delay;
882
883 let this_page = "header.html" in
884 Buffer.add_string buf (
885 if !!html_mods_theme <> "" && theme_page_exists this_page then
886 read_theme_page this_page else
887 if !!html_mods then !!CommonMessages.html_header_mods0
888 else !!CommonMessages.html_header_old);
889
890 Buffer.add_string buf "</head>\n";
891 if open_body then Buffer.add_string buf "<body>\n"
892
893 let html_close_page buf close_body =
894 if close_body then Buffer.add_string buf "</body>\n";
895 Buffer.add_string buf "</html>\n"
896
897 let clear_page buf =
898 Buffer.reset buf;
899 http_file_type := UNK
900
901 let send_preview r file fd size filename exten =
902 let (begin_pos, end_pos) =
903 try
904 let (begin_pos, end_pos) = request_range r in
905 let end_pos = match end_pos with
906 None -> size
907 | Some end_pos -> end_pos in
908 let range_size = end_pos -- begin_pos in
909 add_reply_header r "Content-Length"
910 (Int64.to_string range_size);
911 add_reply_header r "Content-Range"
912 (Printf.sprintf "bytes %Ld-%Ld/%Ld"
913 begin_pos (end_pos -- one)
914 size);
915 r.reply_head <- "206 Partial Content";
916 begin_pos, end_pos
917 with _ ->
918 add_reply_header r "Content-Length"
919 (Int64.to_string size);
920 zero, size
921 in
922 let len = String.length exten in
923 let exten = if len = 0 then exten
924 else String.lowercase (String.sub exten 1 (len - 1)) in
925 http_add_bin_stream_header r (extension_to_file_ext exten);
926
927 add_reply_header r "Content-Disposition"
928 (Printf.sprintf "inline;filename=\"%s\"" (Filename.basename filename));
929 let s = String.create 200000 in
930 set_max_output_buffer r.sock (String.length s);
931 set_rtimeout r.sock 10000.;
932 let rec stream_file file pos sock =
933 let max = (max_refill sock) - 1 in
934 if max > 0 && !pos < end_pos then
935 let max64 = min (end_pos -- !pos) (Int64.of_int max) in
936 let max = Int64.to_int max64 in
937 Unix32.read fd !pos s 0 max;
938 pos := !pos ++ max64;
939 set_lifetime sock 60.;
940 (* lprintf "HTTPSEND: refill %d %Ld\n" max !pos;*)
941 (* lprintf "HTTPSEND: [%s]\n" (String.escaped
942 (String.sub s 0 max)); *)
943 write sock s 0 max;
944 if output_buffered sock = 0 then begin
945 (* lprintf "Recursing STREAM\n"; *)
946 stream_file file pos sock
947 end
948 in
949 r.reply_stream <- Some (stream_file file (ref begin_pos))
950
951
952 let http_handler o t r =
953 CommonInteractive.display_vd := false;
954 CommonInteractive.display_bw_stats := false;
955 clear_page buf;
956 if !Http_server.verbose && r.get_url.Url.short_file <> "" then
957 lprintf_nl "received URL %s %s"
958 r.get_url.Url.short_file
959 (let b = Buffer.create 100 in
960 List.iter (fun (arg, value) -> Printf.bprintf b " %s %s" arg value) r.get_url.Url.args;
961 if Buffer.contents b <> "" then Printf.sprintf "(%s)" (Buffer.contents b) else "");
962
963 let user = if r.options.login = "" then (admin_user ()).CommonTypes.user_name else r.options.login in
964 if not (valid_password user r.options.passwd) || (r.get_url.Url.short_file = "logout") then begin
965 clear_page buf;
966 http_file_type := TXT;
967 let _, error_text_long, header = Http_server.error_page "401" "" ""
968 (Ip.to_string (TcpBufferedSocket.my_ip r.sock))
969 (string_of_int !!http_port) None in
970 Buffer.add_string buf error_text_long;
971 r.reply_head <- header;
972 r.reply_headers <- [
973 "Connection", "close";
974 "WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" !!http_realm]
975 end
976 else
977 begin
978 let user = find_ui_user user in
979 let o = match user.ui_http_conn with
980 Some oo -> oo.conn_buf <- o.conn_buf;
981 oo.conn_info <- Some (WEB, peer_addr t); oo
982 | None -> let oo = { o with conn_user = user;
983 conn_info = Some (WEB, peer_addr t)} in
984 user.ui_http_conn <- Some oo; oo
985 in
986 try
987 match r.get_url.Url.short_file with
988 | "wap.wml" ->
989 begin
990 clear_page buf;
991 http_add_text_header r WML;
992 let dlkbs =
993 (( (float_of_int !udp_download_rate) +. (float_of_int !control_download_rate)) /. 1024.0) in
994 let ulkbs =
995 (( (float_of_int !udp_upload_rate) +. (float_of_int !control_upload_rate)) /. 1024.0) in
996 Printf.bprintf buf "
997 <?xml version=\"1.0\"?>
998 <!DOCTYPE wml PUBLIC \"-//WAPFORUM//DTD WML 1.1//EN\" \"http://www.wapforum.org/DTD/wml_1.1.xml\">
999
1000 <wml>
1001 <card id=\"main\" title=\"MLDonkey Index Page\"> ";
1002 (* speed *)
1003 Printf.bprintf buf "<p align=\"left\">
1004 <small>
1005 DL %.1f KB/s (%d|%d) UL: %.1f KB/s (%d|%d)
1006 </small>
1007 </p>" dlkbs !udp_download_rate !control_download_rate ulkbs !udp_upload_rate !control_upload_rate;
1008
1009
1010 (* functions *)
1011 List.iter (fun (arg, value) ->
1012 match arg with
1013 "VDC" ->
1014 let num = int_of_string value in
1015 let file = file_find num in
1016 file_cancel file o.conn_user.ui_user
1017 | "VDP" ->
1018 let num = int_of_string value in
1019 let file = file_find num in
1020 file_pause file o.conn_user.ui_user
1021 | "VDR" ->
1022 let num = int_of_string value in
1023 let file = file_find num in
1024 file_resume file o.conn_user.ui_user
1025 | _ -> ()
1026 ) r.get_url.Url.args;
1027
1028 (* downloads *)
1029 Printf.bprintf buf "<p align=\"left\"><small>";
1030 let mfiles = List2.tail_map file_info !!files in
1031 List.iter (fun file ->
1032 Printf.bprintf buf "<a href=\"wap.wml?%s=%d\">%s</a> <a href=\"wap.wml?VDC=%d\">C</a> [%-5d] %5.1f %s %s/%s <br />"
1033 (if downloading file then "VDP" else "VDR" )
1034 (file.file_num)
1035 (if downloading file then "P" else "R" )
1036 (file.file_num)
1037 (file.file_num)
1038 (file.file_download_rate /. 1024.)
1039 (short_name file)
1040 (print_human_readable file (file.file_size -- file.file_downloaded))
1041 (print_human_readable file file.file_size);
1042 ) mfiles;
1043 Printf.bprintf buf "<br />Downloaded %d/%d files " (List.length !!done_files) (List.length !!files);
1044 Printf.bprintf buf "</small></p>";
1045 Printf.bprintf buf "</card></wml>";
1046 end
1047 | "commands.html" ->
1048 html_open_page buf t r true;
1049 let this_page = "commands.html" in
1050 Buffer.add_string buf (
1051 if !!html_mods_theme <> "" && theme_page_exists this_page then
1052 read_theme_page this_page else
1053 if !!html_mods then !!CommonMessages.web_common_header_mods0
1054 else !!CommonMessages.web_common_header_old)
1055 | "multidllink.html" ->
1056 html_open_page buf t r true;
1057 let this_page = "multidllink.html" in
1058 Buffer.add_string buf (
1059 if !!html_mods_theme <> "" && theme_page_exists this_page then
1060 read_theme_page this_page else
1061 if !!html_mods then !!CommonMessages.multidllink_mods0
1062 else !!CommonMessages.multidllink_old)
1063 | "" | "index.html" ->
1064 html_open_page buf t r false;
1065 let this_page = "frames.html" in
1066 if !!html_mods_theme <> "" && theme_page_exists this_page then
1067 Buffer.add_string buf (read_theme_page this_page) else
1068 if !!html_mods then
1069 (if !!html_frame_border then
1070 Printf.bprintf buf
1071 "<frameset src=\"index\" rows=\"%d,25,*\">
1072 <frame name=\"commands\" noresize scrolling=\"no\" noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"commands.html\">
1073 <frame name=\"fstatus\" noresize scrolling=\"no\" noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"noframe.html\">
1074 <frame name=\"output\" noresize noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"oneframe.html\">
1075 </frameset>
1076 " !!commands_frame_height
1077 else
1078 Printf.bprintf buf
1079 "<frameset src=\"index\" rows=\"%d,25,*\" frameborder=\"no\">
1080 <frame name=\"commands\" noresize scrolling=\"no\" noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"commands.html\">
1081 <frame name=\"fstatus\" noresize scrolling=\"no\" noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"noframe.html\">
1082 <frame name=\"output\" noresize noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"oneframe.html\">
1083 </frameset>
1084 " !!commands_frame_height)
1085 else
1086 Printf.bprintf buf
1087 "<frameset src=\"index\" rows=\"%d,2*\">
1088 <frameset src=\"index\" cols=\"5*,1*\">
1089 <frame name=\"commands\" src=\"commands.html\">
1090 <frame name=\"fstatus\" src=\"noframe.html\">
1091 </frameset>
1092 <frame name=\"output\" src=\"oneframe.html\">
1093 </frameset>
1094 " !!commands_frame_height
1095 | "complex_search.html" ->
1096 html_open_page buf t r true;
1097 CommonSearch.complex_search buf
1098 | "noframe.html" ->
1099 html_open_page buf t r true
1100
1101 | "oneframe.html" ->
1102 html_open_page buf t r true;
1103 Buffer.add_string buf (Printf.sprintf "<br><div align=\"center\"><h3>%s %s</h3></div>"
1104 (Printf.sprintf (_b "Welcome to MLDonkey")) Autoconf.current_version);
1105 if !!motd_html <> "" then Buffer.add_string buf !!motd_html;
1106 if user2_is_admin o.conn_user.ui_user then
1107 (match DriverInteractive.real_startup_message () with
1108 Some s -> Buffer.add_string buf (Printf.sprintf "<p><pre><b><h3>%s</b></h3></pre>" s);
1109 | None -> ())
1110
1111 | "bw_updown.png" ->
1112 (match http_error_no_gd "png" with
1113 false ->
1114 G.do_draw_pic "Traffic" "s(kb)" "t(h:m:s)" download_history upload_history;
1115 http_send_bin r buf "bw_updown.png"
1116 | true -> raise Not_found)
1117
1118 | "bw_updown.jpg" ->
1119 (match http_error_no_gd "jpg" with
1120 false ->
1121 G.do_draw_pic "Traffic" "s(kb)" "t(h:m:s)" download_history upload_history;
1122 http_send_bin r buf "bw_updown.jpg"
1123 | true -> raise Not_found)
1124
1125 | "bw_download.png" ->
1126 (match http_error_no_gd "png" with
1127 false ->
1128 G.do_draw_down_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_history;
1129 http_send_bin r buf "bw_download.png"
1130 | true -> raise Not_found)
1131
1132 | "bw_download.jpg" ->
1133 (match http_error_no_gd "jpg" with
1134 false ->
1135 G.do_draw_down_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_history;
1136 http_send_bin r buf "bw_download.jpg"
1137 | true -> raise Not_found)
1138
1139 | "bw_upload.png" ->
1140 (match http_error_no_gd "png" with
1141 false ->
1142 G.do_draw_up_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_history;
1143 http_send_bin r buf "bw_upload.png"
1144 | true -> raise Not_found)
1145
1146 | "bw_upload.jpg" ->
1147 (match http_error_no_gd "jpg" with
1148 | false ->
1149 G.do_draw_up_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_history;
1150 http_send_bin r buf "bw_upload.jpg"
1151 | true -> raise Not_found)
1152
1153 | "bw_h_updown.png" ->
1154 (match http_error_no_gd "png" with
1155 | false ->
1156 G.do_draw_h_pic "Traffic" "s(kb)" "t(h:m:s)" download_h_history upload_h_history;
1157 http_send_bin r buf "bw_h_updown.png"
1158 | true -> raise Not_found)
1159
1160 | "bw_h_updown.jpg" ->
1161 (match http_error_no_gd "jpg" with
1162 | false ->
1163 G.do_draw_h_pic "Traffic" "s(kb)" "t(h:m:s)" download_h_history upload_h_history;
1164 http_send_bin r buf "bw_h_updown.jpg"
1165 | true -> raise Not_found)
1166
1167 | "bw_h_download.png" ->
1168 (match http_error_no_gd "png" with
1169 | false ->
1170 G.do_draw_down_h_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_h_history;
1171 http_send_bin r buf "bw_h_download.png"
1172 | true -> raise Not_found)
1173
1174 | "bw_h_download.jpg" ->
1175 (match http_error_no_gd "jpg" with
1176 | false ->
1177 G.do_draw_down_h_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_h_history;
1178 http_send_bin r buf "bw_h_download.jpg"
1179 | true -> raise Not_found)
1180
1181 | "bw_h_upload.png" ->
1182 (match http_error_no_gd "png" with
1183 | false ->
1184 G.do_draw_up_h_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_h_history;
1185 http_send_bin r buf "bw_h_upload.png"
1186 | true -> raise Not_found)
1187
1188 | "bw_h_upload.jpg" ->
1189 (match http_error_no_gd "jpg" with
1190 | false ->
1191 G.do_draw_up_h_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_h_history;
1192 http_send_bin r buf "bw_h_upload.jpg"
1193 | true -> raise Not_found)
1194
1195 | "tag.png" ->
1196 (match http_error_no_gd "png" with
1197 | false ->
1198 G.do_draw_tag !!html_mods_vd_gfx_tag_title download_history upload_history;
1199 http_send_bin r buf "tag.png"
1200 | true -> raise Not_found)
1201
1202 | "tag.jpg" ->
1203 (match http_error_no_gd "jpg" with
1204 | false ->
1205 G.do_draw_tag !!html_mods_vd_gfx_tag_title download_history upload_history;
1206 http_send_bin r buf "tag.jpg"
1207 | true -> raise Not_found)
1208
1209 | "filter" ->
1210 html_open_page buf t r true;
1211 let b = Buffer.create 10000 in
1212 let filter = ref (fun _ -> ()) in
1213 begin
1214 match r.get_url.Url.args with
1215 ("num", num) :: args ->
1216 List.iter (fun (arg, value) ->
1217 match arg with
1218 | "media" ->
1219 let old_filter = !filter in
1220 filter := (fun r ->
1221 if r.result_type = value then raise Not_found;
1222 old_filter r
1223 )
1224 | "format" ->
1225 let old_filter = !filter in
1226 filter := (fun r ->
1227 if r.result_format = value then raise Not_found;
1228 old_filter r
1229 )
1230 | "size" ->
1231 let old_filter = !filter in
1232 let mega5 = Int64.of_int (5 * 1024 * 1024) in
1233 let mega20 = Int64.of_int (20 * 1024 * 1024) in
1234 let mega400 = Int64.of_int (400 * 1024 * 1024) in
1235 let min, max = match value with
1236 "0to5" -> Int64.zero, mega5
1237 | "5to20" -> mega5, mega20
1238 | "20to400" -> mega20, mega400
1239 | "400+" -> mega400, Int64.max_int
1240 | _ -> Int64.zero, Int64.max_int
1241 in
1242 filter := (fun r ->
1243 if r.result_size >= min &&
1244 r.result_size <= max then
1245 raise Not_found;
1246 old_filter r
1247 )
1248 | _ -> ()
1249 ) args;
1250
1251 let num = int_of_string num in
1252 let s = search_find num in
1253
1254 DriverInteractive.print_search b s
1255 { o with conn_filter = !filter };
1256
1257 Buffer.add_string buf (html_escaped
1258 (Buffer.contents b))
1259
1260 | _ ->
1261 Buffer.add_string buf "Bad filter"
1262 end
1263
1264 | "results" ->
1265 html_open_page buf t r true;
1266 let b = Buffer.create 10000 in
1267 List.iter (fun (arg, value) ->
1268 match arg with
1269 "d" -> begin
1270 try
1271 let num = int_of_string value in
1272 let r = find_result num in
1273 let files = result_download r [] false o.conn_user.ui_user in
1274 List.iter CommonInteractive.start_download files;
1275
1276 let module M = CommonMessages in
1277 Gettext.buftext buf M.download_started num
1278 with e ->
1279 Printf.bprintf buf "Error %s with %s<br>"
1280 (Printexc2.to_string e) value;
1281 end
1282 | _ -> ()
1283 ) r.get_url.Url.args;
1284 Buffer.add_string buf (html_escaped (Buffer.contents b))
1285
1286 | "files" ->
1287
1288 List.iter (fun (arg, value) ->
1289 match arg with
1290 "cancel" ->
1291 let num = int_of_string value in
1292 let file = file_find num in
1293 file_cancel file o.conn_user.ui_user
1294 | "pause" ->
1295 let num = int_of_string value in
1296 let file = file_find num in
1297 file_pause file o.conn_user.ui_user
1298 | "resume" ->
1299 let num = int_of_string value in
1300 let file = file_find num in
1301 file_resume file o.conn_user.ui_user
1302 | "release" ->
1303 let num = int_of_string value in
1304 let file = file_find num in
1305 set_file_release file true o.conn_user.ui_user
1306 | "norelease" ->
1307 let num = int_of_string value in
1308 let file = file_find num in
1309 set_file_release file false o.conn_user.ui_user
1310 | "sortby" ->
1311 begin
1312 match value with
1313 | "Percent" -> o.conn_sortvd <- ByPercent
1314 | "%" -> o.conn_sortvd <- ByPercent
1315 | "File" -> o.conn_sortvd <- ByName
1316 | "Downloaded" -> o.conn_sortvd <- ByDone
1317 | "DLed" -> o.conn_sortvd <- ByDone
1318 | "Size" -> o.conn_sortvd <- BySize
1319 | "Rate" -> o.conn_sortvd <- ByRate
1320 | "ETA" -> o.conn_sortvd <- ByETA
1321 | "Priority" -> o.conn_sortvd <- ByPriority
1322 | "Age" -> o.conn_sortvd <- ByAge
1323 | "Last" -> o.conn_sortvd <- ByLast
1324 | "Srcs" -> o.conn_sortvd <- BySources
1325 | "A" -> o.conn_sortvd <- ByASources
1326 | "N" -> o.conn_sortvd <- ByNet
1327 | "Avail" -> o.conn_sortvd <- ByAvail
1328 | "Cm" -> o.conn_sortvd <- ByComments
1329 | "User" -> o.conn_sortvd <- ByUser
1330 | "Group" -> o.conn_sortvd <- ByGroup
1331 | _ -> ()
1332 end
1333 | _ -> ()
1334 ) r.get_url.Url.args;
1335 let b = Buffer.create 10000 in
1336
1337 let list = List2.tail_map file_info (user2_filter_files !!files o.conn_user.ui_user) in
1338 DriverInteractive.display_file_list b o list;
1339 html_open_page buf t r true;
1340 Buffer.add_string buf (html_escaped (Buffer.contents b))
1341
1342 | "submit" ->
1343 begin
1344
1345 match r.get_url.Url.args with
1346 | [ "jvcmd", "multidllink" ; "links", links] ->
1347 html_open_page buf t r true;
1348 List.iter (fun url ->
1349 let url = fst (String2.cut_at url '\013') in
1350 if url <> "" then
1351 begin
1352 Buffer.add_string buf (html_escaped (dllink_parse (o.conn_output = HTML) url o.conn_user.ui_user));
1353 Buffer.add_string buf (html_escaped "\\<P\\>")
1354 end
1355 ) (String2.split links '\n')
1356
1357 | ("q", cmd) :: other_args ->
1358 List.iter (fun arg ->
1359 match arg with
1360 | "sortby", "size" -> o.conn_sortvd <- BySize
1361 | "sortby", "name" -> o.conn_sortvd <- ByName
1362 | "sortby", "rate" -> o.conn_sortvd <- ByRate
1363 | "sortby", "done" -> o.conn_sortvd <- ByDone
1364 | "sortby", "percent" -> o.conn_sortvd <- ByPercent
1365 | "sortby", "priority" -> o.conn_sortvd <- ByPriority
1366 | _ -> ()
1367 ) other_args;
1368 let s =
1369 let b = o.conn_buf in
1370 clear_page b;
1371 eval (ref true) cmd o;
1372 html_escaped (Buffer.contents b)
1373 in
1374 html_open_page buf t r true;
1375
1376 (* Konqueror doesn't like html within <pre> *)
1377 let drop_pre = ref false in
1378 let rawcmd = ref cmd in
1379
1380 if String.contains cmd ' ' then
1381 rawcmd := String.sub cmd 0 (String.index cmd ' ');
1382
1383 (match !rawcmd with
1384 | "vm" | "vma" | "view_custom_queries" | "xs" | "vr"
1385 | "afr" | "friend_remove" | "reshare" | "recover_temp"
1386 | "c" | "commit" | "bw_stats" | "ovweb" | "friends"
1387 | "message_log" | "friend_add" | "remove_old_servers"
1388 | "downloaders" | "uploaders" | "scan_temp" | "cs"
1389 | "version" | "rename" | "force_download" | "close_fds"
1390 | "vd" | "vo" | "voo" | "upstats" | "shares" | "share"
1391 | "unshare" | "stats" | "users" | "block_list" ->
1392 drop_pre := true;
1393 | _ -> ());
1394 Printf.bprintf buf "%s\n"
1395 (if use_html_mods o && !drop_pre then s else "\n<pre>\n" ^ s ^ "</pre>");
1396
1397 | [ ("custom", query) ] ->
1398 html_open_page buf t r true;
1399 CommonSearch.custom_query buf query
1400
1401 | ("custom", query) :: args ->
1402 html_open_page buf t r true;
1403 send_custom_query o.conn_user buf query args
1404
1405 | [ "setoption", _ ; "option", name; "value", value ] ->
1406 html_open_page buf t r true;
1407 let gui_type, ip, port =
1408 match o.conn_info with
1409 | None -> None, None, None
1410 | Some (gui_type, (ip, port)) -> Some gui_type, Some ip, Some port
1411 in
1412 if user2_is_admin o.conn_user.ui_user then
1413 begin
1414 CommonInteractive.set_fully_qualified_options name value
1415 ~user:(Some o.conn_user.ui_user.CommonTypes.user_name)
1416 ~ip:ip ~port:port ~gui_type:gui_type ();
1417 Buffer.add_string buf "Option value changed"
1418 end
1419 else
1420 Buffer.add_string buf "You are not allowed to change options"
1421
1422 | args ->
1423 List.iter (fun (s,v) ->
1424 lprintf_nl "[%s]=[%s]" (String.escaped s) (String.escaped v))
1425 args;
1426 raise Not_found
1427 end
1428
1429 | "preview_download" ->
1430 begin
1431 clear_page buf;
1432 match r.get_url.Url.args with
1433 ["q", file_num] ->
1434 let file_num = int_of_string file_num in
1435 let file = file_find file_num in
1436 let fd = file_fd file in
1437 let size = file_size file in
1438 let filename = file_best_name file in
1439 let exten = Filename2.last_extension filename in
1440 send_preview r file fd size filename exten
1441
1442 | args ->
1443 List.iter (fun (s,v) ->
1444 lprintf_nl "[%s]=[%s]" (String.escaped s) (String.escaped v))
1445 args;
1446 raise Not_found
1447 end
1448
1449 | "preview_upload" ->
1450 begin
1451 clear_page buf;
1452 match r.get_url.Url.args with
1453 ["q", file_num] ->
1454 let file_num = int_of_string file_num in
1455 let file = shared_find file_num in
1456 let impl = as_shared_impl file in
1457 let info = shared_info file in
1458 let filename = impl.impl_shared_fullname in
1459 let exten = Filename2.last_extension impl.impl_shared_codedname in
1460 if not (Sys.file_exists filename) then
1461 begin
1462 lprintf_nl "file %s not found" filename;
1463 raise Not_found
1464 end;
1465 let fd = Unix32.create_ro filename in
1466 let size = info.shared_size in
1467 send_preview r file fd size filename exten
1468
1469 | args ->
1470 List.iter (fun (s,v) ->
1471 lprintf_nl "[%s]=[%s]" (String.escaped s) (String.escaped v))
1472 args;
1473 raise Not_found
1474 end
1475
1476 | "h.css" ->
1477 clear_page buf;
1478 http_add_text_header r CSS;
1479 let this_page = "h.css" in
1480 Buffer.add_string buf (
1481 if !!html_mods_theme <> "" && theme_page_exists this_page then
1482 read_theme_page this_page else
1483 if !!html_mods then !CommonMessages.html_css_mods
1484 else !!CommonMessages.html_css_old)
1485
1486 | "dh.css" ->
1487 clear_page buf;
1488 http_add_text_header r CSS;
1489 let this_page = "dh.css" in
1490 Buffer.add_string buf (
1491 if !!html_mods_theme <> "" && theme_page_exists this_page then
1492 read_theme_page this_page else
1493 if !!html_mods then !CommonMessages.download_html_css_mods
1494 else !!CommonMessages.download_html_css_old)
1495
1496 | "i.js" ->
1497 clear_page buf;
1498 http_add_text_header r JAVASCRIPT;
1499 let this_page = "i.js" in
1500 Buffer.add_string buf (
1501 if !!html_mods_theme <> "" && theme_page_exists this_page then
1502 read_theme_page this_page else
1503 if !!html_mods then !!CommonMessages.html_js_mods0
1504 else !!CommonMessages.html_js_old)
1505
1506 | "di.js" ->
1507 clear_page buf;
1508 http_add_text_header r JAVASCRIPT;
1509 let this_page = "di.js" in
1510 Buffer.add_string buf (
1511 if !!html_mods_theme <> "" && theme_page_exists this_page then
1512 read_theme_page this_page else
1513 if !!html_mods then !!CommonMessages.download_html_js_mods0
1514 else !!CommonMessages.download_html_js_old)
1515 | s -> http_send_bin_pictures r buf (String.lowercase s)
1516 with
1517 | Not_found ->
1518 let _, error_text_long, header = Http_server.error_page "404" "" ""
1519 (Ip.to_string (TcpBufferedSocket.my_ip r.sock))
1520 (string_of_int !!http_port)
1521 (Some (Url_not_found r.get_url.Url.full_file)) in
1522 r.reply_head <- header;
1523 Buffer.add_string buf error_text_long
1524 | e ->
1525 Printf.bprintf buf "\nException %s\n" (Printexc2.to_string e);
1526 r.reply_stream <- None
1527 end;
1528
1529 let s =
1530 match !http_file_type with
1531 HTM -> html_close_page buf false; dollar_escape o true (Buffer.contents buf)
1532 | MLHTM -> html_close_page buf true; dollar_escape o true (Buffer.contents buf)
1533 | TXT
1534 | UNK
1535 | BIN -> Buffer.contents buf
1536 in
1537 r.reply_content <-
1538 if !http_file_type <> BIN && !!html_use_gzip then
1539 Zlib.gzip_string s
1540 else s
1541
1542 let http_options = {
1543 conn_buf = Buffer.create 10000;
1544 conn_output = HTML;
1545 conn_sortvd = NotSorted;
1546 conn_filter = (fun _ -> ());
1547 conn_user = find_ui_user CommonUserDb.admin_user_name;
1548 conn_width = 80; conn_height = 0;
1549 conn_info = Some (WEB, (Ip.null, 0));
1550 }
1551
1552 let create_http_handler () =
1553 let config = {
1554 bind_addr = Ip.to_inet_addr !!http_bind_addr ;
1555 port = !!http_port;
1556 requests = [];
1557 addrs = Ip_set.of_list !!allowed_ips;
1558 (* do not limit access to MLDonkey web interface by IP blocklist *)
1559 use_ip_block_list = false;
1560 base_ref = "";
1561 default = http_handler http_options;
1562 } in
1563 option_hook allowed_ips (fun _ ->
1564 config.addrs <- Ip_set.of_list !!allowed_ips);
1565 ignore(find_port "http server" !!http_bind_addr http_port
1566 (Http_server.handler config));
1567 config.port <- !!http_port
mldonkey - cross-platform multi-network p2p daemon