?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
gettext: reduce complexity, drop unused code
[mldonkey.git] / src / daemon / driver / driverControlers.ml
blobd502a8d28ef29b71c3b2f0682f21ef1c411d3637
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 let short_file =
957 let file = r.get_url.Url.short_file in
958 match !!http_root_url with
959 | "" | "/" -> `File file
960 | root ->
961 let root = if not (String2.starts_with root "/") then "/" ^ root else root in
962 (* we want to treat "/root" requests as invalid and redirect them to "/root/" *)
963 let root_dir = if root <> "" && root.[String.length root - 1] = '/' then root else root ^ "/" in
964 if String2.starts_with ("/"^file) root_dir then
965 `File (String2.after file (String.length root_dir - 1))
966 else
967 `Redirect root_dir
968 in
969 if !Http_server.verbose && short_file <> `File "" then
970 lprintf_nl "received URL %s %s"
971 r.get_url.Url.short_file
972 (let b = Buffer.create 100 in
973 List.iter (fun (arg, value) -> Printf.bprintf b " %s %s" arg value) r.get_url.Url.args;
974 if Buffer.contents b <> "" then Printf.sprintf "(%s)" (Buffer.contents b) else "");
975
976 let user = if r.options.login = "" then (admin_user ()).CommonTypes.user_name else r.options.login in
977 if not (valid_password user r.options.passwd) || (short_file = `File "logout") then begin
978 clear_page buf;
979 http_file_type := HTM;
980 let _, error_text_long, head = Http_server.error_page Unauthorized (TcpBufferedSocket.my_ip r.sock) !!http_port in
981 Buffer.add_string buf error_text_long;
982 r.reply_head <- head;
983 http_add_html_header r;
984 add_reply_header r "WWW-Authenticate" (Printf.sprintf "Basic realm=\"%s\"" !!http_realm);
985 end
986 else
987 begin
988 let user = find_ui_user user in
989 let o = match user.ui_http_conn with
990 Some oo -> oo.conn_buf <- o.conn_buf;
991 oo.conn_info <- Some (WEB, peer_addr t); oo
992 | None -> let oo = { o with conn_user = user;
993 conn_info = Some (WEB, peer_addr t)} in
994 user.ui_http_conn <- Some oo; oo
995 in
996 try
997 match short_file with
998 | `Redirect url ->
999 let _, error_text_long, head = Http_server.error_page (Moved url)
1000 (TcpBufferedSocket.my_ip r.sock)
1001 !!http_port
1002 in
1003 r.reply_head <- head;
1004 add_reply_header r "Location" url;
1005 http_add_html_header r;
1006 Buffer.add_string buf error_text_long
1007 | `File short_file ->
1008 match short_file with
1009 | "wap.wml" ->
1010 begin
1011 clear_page buf;
1012 http_add_text_header r WML;
1013 let dlkbs =
1014 (( (float_of_int !udp_download_rate) +. (float_of_int !control_download_rate)) /. 1024.0) in
1015 let ulkbs =
1016 (( (float_of_int !udp_upload_rate) +. (float_of_int !control_upload_rate)) /. 1024.0) in
1017 Printf.bprintf buf "
1018 <?xml version=\"1.0\"?>
1019 <!DOCTYPE wml PUBLIC \"-//WAPFORUM//DTD WML 1.1//EN\" \"http://www.wapforum.org/DTD/wml_1.1.xml\">
1020
1021 <wml>
1022 <card id=\"main\" title=\"MLDonkey Index Page\"> ";
1023 (* speed *)
1024 Printf.bprintf buf "<p align=\"left\">
1025 <small>
1026 DL %.1f KB/s (%d|%d) UL: %.1f KB/s (%d|%d)
1027 </small>
1028 </p>" dlkbs !udp_download_rate !control_download_rate ulkbs !udp_upload_rate !control_upload_rate;
1029
1030
1031 (* functions *)
1032 List.iter (fun (arg, value) ->
1033 match arg with
1034 "VDC" ->
1035 let num = int_of_string value in
1036 let file = file_find num in
1037 file_cancel file o.conn_user.ui_user
1038 | "VDP" ->
1039 let num = int_of_string value in
1040 let file = file_find num in
1041 file_pause file o.conn_user.ui_user
1042 | "VDR" ->
1043 let num = int_of_string value in
1044 let file = file_find num in
1045 file_resume file o.conn_user.ui_user
1046 | _ -> ()
1047 ) r.get_url.Url.args;
1048
1049 (* downloads *)
1050 Printf.bprintf buf "<p align=\"left\"><small>";
1051 let mfiles = List2.tail_map file_info !!files in
1052 List.iter (fun file ->
1053 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 />"
1054 (if downloading file then "VDP" else "VDR" )
1055 (file.file_num)
1056 (if downloading file then "P" else "R" )
1057 (file.file_num)
1058 (file.file_num)
1059 (file.file_download_rate /. 1024.)
1060 (short_name file)
1061 (print_human_readable file (file.file_size -- file.file_downloaded))
1062 (print_human_readable file file.file_size);
1063 ) mfiles;
1064 Printf.bprintf buf "<br />Downloaded %d/%d files " (List.length !!done_files) (List.length !!files);
1065 Printf.bprintf buf "</small></p>";
1066 Printf.bprintf buf "</card></wml>";
1067 end
1068 | "commands.html" ->
1069 html_open_page buf t r true;
1070 let this_page = "commands.html" in
1071 Buffer.add_string buf (
1072 if !!html_mods_theme <> "" && theme_page_exists this_page then
1073 read_theme_page this_page else
1074 if !!html_mods then !!CommonMessages.web_common_header_mods0
1075 else !!CommonMessages.web_common_header_old)
1076 | "multidllink.html" ->
1077 html_open_page buf t r true;
1078 let this_page = "multidllink.html" in
1079 Buffer.add_string buf (
1080 if !!html_mods_theme <> "" && theme_page_exists this_page then
1081 read_theme_page this_page else
1082 if !!html_mods then !!CommonMessages.multidllink_mods0
1083 else !!CommonMessages.multidllink_old)
1084 | "" | "index.html" ->
1085 html_open_page buf t r false;
1086 let this_page = "frames.html" in
1087 if !!html_mods_theme <> "" && theme_page_exists this_page then
1088 Buffer.add_string buf (read_theme_page this_page) else
1089 if !!html_mods then
1090 (if !!html_frame_border then
1091 Printf.bprintf buf
1092 "<frameset src=\"index\" rows=\"%d,25,*\">
1093 <frame name=\"commands\" noresize scrolling=\"no\" noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"commands.html\">
1094 <frame name=\"fstatus\" noresize scrolling=\"no\" noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"noframe.html\">
1095 <frame name=\"output\" noresize noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"oneframe.html\">
1096 </frameset>
1097 " !!commands_frame_height
1098 else
1099 Printf.bprintf buf
1100 "<frameset src=\"index\" rows=\"%d,25,*\" frameborder=\"no\">
1101 <frame name=\"commands\" noresize scrolling=\"no\" noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"commands.html\">
1102 <frame name=\"fstatus\" noresize scrolling=\"no\" noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"noframe.html\">
1103 <frame name=\"output\" noresize noshade marginwidth=0 marginheight=0 border=0 framespacing=0 src=\"oneframe.html\">
1104 </frameset>
1105 " !!commands_frame_height)
1106 else
1107 Printf.bprintf buf
1108 "<frameset src=\"index\" rows=\"%d,2*\">
1109 <frameset src=\"index\" cols=\"5*,1*\">
1110 <frame name=\"commands\" src=\"commands.html\">
1111 <frame name=\"fstatus\" src=\"noframe.html\">
1112 </frameset>
1113 <frame name=\"output\" src=\"oneframe.html\">
1114 </frameset>
1115 " !!commands_frame_height
1116 | "complex_search.html" ->
1117 html_open_page buf t r true;
1118 CommonSearch.complex_search buf
1119 | "noframe.html" ->
1120 html_open_page buf t r true
1121
1122 | "oneframe.html" ->
1123 html_open_page buf t r true;
1124 Buffer.add_string buf (Printf.sprintf "<br><div align=\"center\"><h3>%s %s</h3></div>"
1125 (Printf.sprintf (_b "Welcome to MLDonkey")) Autoconf.current_version);
1126 if !!motd_html <> "" then Buffer.add_string buf !!motd_html;
1127 if user2_is_admin o.conn_user.ui_user then
1128 (match DriverInteractive.real_startup_message () with
1129 Some s -> Buffer.add_string buf (Printf.sprintf "<p><pre><b><h3>%s</b></h3></pre>" s);
1130 | None -> ())
1131
1132 | "bw_updown.png" ->
1133 (match http_error_no_gd "png" with
1134 false ->
1135 G.do_draw_pic "Traffic" "s(kb)" "t(h:m:s)" download_history upload_history;
1136 http_send_bin r buf "bw_updown.png"
1137 | true -> raise Not_found)
1138
1139 | "bw_updown.jpg" ->
1140 (match http_error_no_gd "jpg" with
1141 false ->
1142 G.do_draw_pic "Traffic" "s(kb)" "t(h:m:s)" download_history upload_history;
1143 http_send_bin r buf "bw_updown.jpg"
1144 | true -> raise Not_found)
1145
1146 | "bw_download.png" ->
1147 (match http_error_no_gd "png" with
1148 false ->
1149 G.do_draw_down_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_history;
1150 http_send_bin r buf "bw_download.png"
1151 | true -> raise Not_found)
1152
1153 | "bw_download.jpg" ->
1154 (match http_error_no_gd "jpg" with
1155 false ->
1156 G.do_draw_down_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_history;
1157 http_send_bin r buf "bw_download.jpg"
1158 | true -> raise Not_found)
1159
1160 | "bw_upload.png" ->
1161 (match http_error_no_gd "png" with
1162 false ->
1163 G.do_draw_up_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_history;
1164 http_send_bin r buf "bw_upload.png"
1165 | true -> raise Not_found)
1166
1167 | "bw_upload.jpg" ->
1168 (match http_error_no_gd "jpg" with
1169 | false ->
1170 G.do_draw_up_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_history;
1171 http_send_bin r buf "bw_upload.jpg"
1172 | true -> raise Not_found)
1173
1174 | "bw_h_updown.png" ->
1175 (match http_error_no_gd "png" with
1176 | false ->
1177 G.do_draw_h_pic "Traffic" "s(kb)" "t(h:m:s)" download_h_history upload_h_history;
1178 http_send_bin r buf "bw_h_updown.png"
1179 | true -> raise Not_found)
1180
1181 | "bw_h_updown.jpg" ->
1182 (match http_error_no_gd "jpg" with
1183 | false ->
1184 G.do_draw_h_pic "Traffic" "s(kb)" "t(h:m:s)" download_h_history upload_h_history;
1185 http_send_bin r buf "bw_h_updown.jpg"
1186 | true -> raise Not_found)
1187
1188 | "bw_h_download.png" ->
1189 (match http_error_no_gd "png" with
1190 | false ->
1191 G.do_draw_down_h_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_h_history;
1192 http_send_bin r buf "bw_h_download.png"
1193 | true -> raise Not_found)
1194
1195 | "bw_h_download.jpg" ->
1196 (match http_error_no_gd "jpg" with
1197 | false ->
1198 G.do_draw_down_h_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_h_history;
1199 http_send_bin r buf "bw_h_download.jpg"
1200 | true -> raise Not_found)
1201
1202 | "bw_h_upload.png" ->
1203 (match http_error_no_gd "png" with
1204 | false ->
1205 G.do_draw_up_h_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_h_history;
1206 http_send_bin r buf "bw_h_upload.png"
1207 | true -> raise Not_found)
1208
1209 | "bw_h_upload.jpg" ->
1210 (match http_error_no_gd "jpg" with
1211 | false ->
1212 G.do_draw_up_h_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_h_history;
1213 http_send_bin r buf "bw_h_upload.jpg"
1214 | true -> raise Not_found)
1215
1216 | "tag.png" ->
1217 (match http_error_no_gd "png" with
1218 | false ->
1219 G.do_draw_tag !!html_mods_vd_gfx_tag_title download_history upload_history;
1220 http_send_bin r buf "tag.png"
1221 | true -> raise Not_found)
1222
1223 | "tag.jpg" ->
1224 (match http_error_no_gd "jpg" with
1225 | false ->
1226 G.do_draw_tag !!html_mods_vd_gfx_tag_title download_history upload_history;
1227 http_send_bin r buf "tag.jpg"
1228 | true -> raise Not_found)
1229
1230 | "filter" ->
1231 html_open_page buf t r true;
1232 let b = Buffer.create 10000 in
1233 let filter = ref (fun _ -> ()) in
1234 begin
1235 match r.get_url.Url.args with
1236 ("num", num) :: args ->
1237 List.iter (fun (arg, value) ->
1238 match arg with
1239 | "media" ->
1240 let old_filter = !filter in
1241 filter := (fun r ->
1242 if r.result_type = value then raise Not_found;
1243 old_filter r
1244 )
1245 | "format" ->
1246 let old_filter = !filter in
1247 filter := (fun r ->
1248 if r.result_format = value then raise Not_found;
1249 old_filter r
1250 )
1251 | "size" ->
1252 let old_filter = !filter in
1253 let mega5 = Int64.of_int (5 * 1024 * 1024) in
1254 let mega20 = Int64.of_int (20 * 1024 * 1024) in
1255 let mega400 = Int64.of_int (400 * 1024 * 1024) in
1256 let min, max = match value with
1257 "0to5" -> Int64.zero, mega5
1258 | "5to20" -> mega5, mega20
1259 | "20to400" -> mega20, mega400
1260 | "400+" -> mega400, Int64.max_int
1261 | _ -> Int64.zero, Int64.max_int
1262 in
1263 filter := (fun r ->
1264 if r.result_size >= min &&
1265 r.result_size <= max then
1266 raise Not_found;
1267 old_filter r
1268 )
1269 | _ -> ()
1270 ) args;
1271
1272 let num = int_of_string num in
1273 let s = search_find num in
1274
1275 DriverInteractive.print_search b s
1276 { o with conn_filter = !filter };
1277
1278 Buffer.add_string buf (html_escaped
1279 (Buffer.contents b))
1280
1281 | _ ->
1282 Buffer.add_string buf "Bad filter"
1283 end
1284
1285 | "results" ->
1286 html_open_page buf t r true;
1287 let b = Buffer.create 10000 in
1288 List.iter (fun (arg, value) ->
1289 match arg with
1290 "d" -> begin
1291 try
1292 let num = int_of_string value in
1293 let r = find_result num in
1294 let files = result_download r [] false o.conn_user.ui_user in
1295 List.iter CommonInteractive.start_download files;
1296
1297 let module M = CommonMessages in
1298 Buffer.add_string buf (M.download_started num)
1299 with e ->
1300 Printf.bprintf buf "Error %s with %s<br>"
1301 (Printexc2.to_string e) value;
1302 end
1303 | _ -> ()
1304 ) r.get_url.Url.args;
1305 Buffer.add_string buf (html_escaped (Buffer.contents b))
1306
1307 | "files" ->
1308
1309 List.iter (fun (arg, value) ->
1310 match arg with
1311 "cancel" ->
1312 let num = int_of_string value in
1313 let file = file_find num in
1314 file_cancel file o.conn_user.ui_user
1315 | "pause" ->
1316 let num = int_of_string value in
1317 let file = file_find num in
1318 file_pause file o.conn_user.ui_user
1319 | "resume" ->
1320 let num = int_of_string value in
1321 let file = file_find num in
1322 file_resume file o.conn_user.ui_user
1323 | "release" ->
1324 let num = int_of_string value in
1325 let file = file_find num in
1326 set_file_release file true o.conn_user.ui_user
1327 | "norelease" ->
1328 let num = int_of_string value in
1329 let file = file_find num in
1330 set_file_release file false o.conn_user.ui_user
1331 | "sortby" ->
1332 begin
1333 match value with
1334 | "Percent" -> o.conn_sortvd <- ByPercent
1335 | "%" -> o.conn_sortvd <- ByPercent
1336 | "File" -> o.conn_sortvd <- ByName
1337 | "Downloaded" -> o.conn_sortvd <- ByDone
1338 | "DLed" -> o.conn_sortvd <- ByDone
1339 | "Size" -> o.conn_sortvd <- BySize
1340 | "Rate" -> o.conn_sortvd <- ByRate
1341 | "ETA" -> o.conn_sortvd <- ByETA
1342 | "Priority" -> o.conn_sortvd <- ByPriority
1343 | "Age" -> o.conn_sortvd <- ByAge
1344 | "Last" -> o.conn_sortvd <- ByLast
1345 | "Srcs" -> o.conn_sortvd <- BySources
1346 | "A" -> o.conn_sortvd <- ByASources
1347 | "N" -> o.conn_sortvd <- ByNet
1348 | "Avail" -> o.conn_sortvd <- ByAvail
1349 | "Cm" -> o.conn_sortvd <- ByComments
1350 | "User" -> o.conn_sortvd <- ByUser
1351 | "Group" -> o.conn_sortvd <- ByGroup
1352 | _ -> ()
1353 end
1354 | _ -> ()
1355 ) r.get_url.Url.args;
1356 let b = Buffer.create 10000 in
1357
1358 let list = List2.tail_map file_info (user2_filter_files !!files o.conn_user.ui_user) in
1359 DriverInteractive.display_file_list b o list;
1360 html_open_page buf t r true;
1361 Buffer.add_string buf (html_escaped (Buffer.contents b))
1362
1363 | "submit" ->
1364 begin
1365
1366 match r.get_url.Url.args with
1367 | [ "jvcmd", "multidllink" ; "links", links] ->
1368 html_open_page buf t r true;
1369 List.iter (fun url ->
1370 let url = fst (String2.cut_at url '\013') in
1371 if url <> "" then
1372 begin
1373 Buffer.add_string buf (html_escaped (dllink_parse (o.conn_output = HTML) url o.conn_user.ui_user));
1374 Buffer.add_string buf (html_escaped "\\<P\\>")
1375 end
1376 ) (String2.split links '\n')
1377
1378 | ("q", cmd) :: other_args ->
1379 List.iter (fun arg ->
1380 match arg with
1381 | "sortby", "size" -> o.conn_sortvd <- BySize
1382 | "sortby", "name" -> o.conn_sortvd <- ByName
1383 | "sortby", "rate" -> o.conn_sortvd <- ByRate
1384 | "sortby", "done" -> o.conn_sortvd <- ByDone
1385 | "sortby", "percent" -> o.conn_sortvd <- ByPercent
1386 | "sortby", "priority" -> o.conn_sortvd <- ByPriority
1387 | _ -> ()
1388 ) other_args;
1389 let s =
1390 let b = o.conn_buf in
1391 clear_page b;
1392 eval (ref true) cmd o;
1393 html_escaped (Buffer.contents b)
1394 in
1395 html_open_page buf t r true;
1396
1397 (* Konqueror doesn't like html within <pre> *)
1398 let drop_pre = ref false in
1399 let rawcmd = ref cmd in
1400
1401 if String.contains cmd ' ' then
1402 rawcmd := String.sub cmd 0 (String.index cmd ' ');
1403
1404 (match !rawcmd with
1405 | "vm" | "vma" | "view_custom_queries" | "xs" | "vr"
1406 | "afr" | "friend_remove" | "reshare" | "recover_temp"
1407 | "c" | "commit" | "bw_stats" | "ovweb" | "friends"
1408 | "message_log" | "friend_add" | "remove_old_servers"
1409 | "downloaders" | "uploaders" | "scan_temp" | "cs"
1410 | "version" | "rename" | "force_download" | "close_fds"
1411 | "vd" | "vo" | "voo" | "upstats" | "shares" | "share"
1412 | "unshare" | "stats" | "users" | "block_list" ->
1413 drop_pre := true;
1414 | _ -> ());
1415 Printf.bprintf buf "%s\n"
1416 (if use_html_mods o && !drop_pre then s else "\n<pre>\n" ^ s ^ "</pre>");
1417
1418 | [ ("custom", query) ] ->
1419 html_open_page buf t r true;
1420 CommonSearch.custom_query buf query
1421
1422 | ("custom", query) :: args ->
1423 html_open_page buf t r true;
1424 send_custom_query o.conn_user buf query args
1425
1426 | [ ("api", cmd) ] ->
1427 clear_page o.conn_buf;
1428 eval (ref true) cmd o;
1429 Buffer.add_string buf (Buffer.contents o.conn_buf)
1430
1431 | [ "setoption", _ ; "option", name; "value", value ] ->
1432 html_open_page buf t r true;
1433 let gui_type, ip, port =
1434 match o.conn_info with
1435 | None -> None, None, None
1436 | Some (gui_type, (ip, port)) -> Some gui_type, Some ip, Some port
1437 in
1438 if user2_is_admin o.conn_user.ui_user then
1439 begin
1440 CommonInteractive.set_fully_qualified_options name value
1441 ~user:(Some o.conn_user.ui_user.CommonTypes.user_name)
1442 ~ip:ip ~port:port ~gui_type:gui_type ();
1443 Buffer.add_string buf "Option value changed"
1444 end
1445 else
1446 Buffer.add_string buf "You are not allowed to change options"
1447
1448 | args ->
1449 List.iter (fun (s,v) ->
1450 lprintf_nl "[%s]=[%s]" (String.escaped s) (String.escaped v))
1451 args;
1452 raise Not_found
1453 end
1454
1455 | "preview_download" ->
1456 begin
1457 clear_page buf;
1458 match r.get_url.Url.args with
1459 ["q", file_num] ->
1460 let file_num = int_of_string file_num in
1461 let file = file_find file_num in
1462 let fd = file_fd file in
1463 let size = file_size file in
1464 let filename = file_best_name file in
1465 let exten = Filename2.last_extension filename in
1466 send_preview r file fd size filename exten
1467
1468 | args ->
1469 List.iter (fun (s,v) ->
1470 lprintf_nl "[%s]=[%s]" (String.escaped s) (String.escaped v))
1471 args;
1472 raise Not_found
1473 end
1474
1475 | "preview_upload" ->
1476 begin
1477 clear_page buf;
1478 match r.get_url.Url.args with
1479 ["q", file_num] ->
1480 let file_num = int_of_string file_num in
1481 let file = shared_find file_num in
1482 let impl = as_shared_impl file in
1483 let info = shared_info file in
1484 let filename = impl.impl_shared_fullname in
1485 let exten = Filename2.last_extension impl.impl_shared_codedname in
1486 if not (Sys.file_exists filename) then
1487 begin
1488 lprintf_nl "file %s not found" filename;
1489 raise Not_found
1490 end;
1491 let fd = Unix32.create_ro filename in
1492 let size = info.shared_size in
1493 send_preview r file fd size filename exten
1494
1495 | args ->
1496 List.iter (fun (s,v) ->
1497 lprintf_nl "[%s]=[%s]" (String.escaped s) (String.escaped v))
1498 args;
1499 raise Not_found
1500 end
1501
1502 | "h.css" ->
1503 clear_page buf;
1504 http_add_text_header r CSS;
1505 let this_page = "h.css" in
1506 Buffer.add_string buf (
1507 if !!html_mods_theme <> "" && theme_page_exists this_page then
1508 read_theme_page this_page else
1509 if !!html_mods then !CommonMessages.html_css_mods
1510 else !!CommonMessages.html_css_old)
1511
1512 | "dh.css" ->
1513 clear_page buf;
1514 http_add_text_header r CSS;
1515 let this_page = "dh.css" in
1516 Buffer.add_string buf (
1517 if !!html_mods_theme <> "" && theme_page_exists this_page then
1518 read_theme_page this_page else
1519 if !!html_mods then !CommonMessages.download_html_css_mods
1520 else !!CommonMessages.download_html_css_old)
1521
1522 | "i.js" ->
1523 clear_page buf;
1524 http_add_text_header r JAVASCRIPT;
1525 let this_page = "i.js" in
1526 Buffer.add_string buf (
1527 if !!html_mods_theme <> "" && theme_page_exists this_page then
1528 read_theme_page this_page else
1529 if !!html_mods then !!CommonMessages.html_js_mods0
1530 else !!CommonMessages.html_js_old)
1531
1532 | "di.js" ->
1533 clear_page buf;
1534 http_add_text_header r JAVASCRIPT;
1535 let this_page = "di.js" in
1536 Buffer.add_string buf (
1537 if !!html_mods_theme <> "" && theme_page_exists this_page then
1538 read_theme_page this_page else
1539 if !!html_mods then !!CommonMessages.download_html_js_mods0
1540 else !!CommonMessages.download_html_js_old)
1541 | s -> http_send_bin_pictures r buf (String.lowercase s)
1542 with
1543 | Not_found ->
1544 let _, error_text_long, head = Http_server.error_page (Not_Found r.get_url.Url.full_file)
1545 (TcpBufferedSocket.my_ip r.sock) !!http_port
1546 in
1547 r.reply_head <- head;
1548 http_add_html_header r;
1549 Buffer.add_string buf error_text_long
1550 | e ->
1551 http_add_text_header r TEXTS;
1552 Printf.bprintf buf "%sException %s\n"
1553 (if Buffer.length buf = 0 then "" else "\n") (Printexc2.to_string e);
1554 r.reply_stream <- None
1555 end;
1556
1557 let s =
1558 match !http_file_type with
1559 HTM -> html_close_page buf false; dollar_escape o true (Buffer.contents buf)
1560 | MLHTM -> html_close_page buf true; dollar_escape o true (Buffer.contents buf)
1561 | TXT
1562 | UNK
1563 | BIN -> Buffer.contents buf
1564 in
1565 r.reply_content <-
1566 if !http_file_type <> BIN && !!html_use_gzip then
1567 Zlib.gzip_string s
1568 else s
1569
1570 let http_options = {
1571 conn_buf = Buffer.create 10000;
1572 conn_output = HTML;
1573 conn_sortvd = NotSorted;
1574 conn_filter = (fun _ -> ());
1575 conn_user = find_ui_user CommonUserDb.admin_user_name;
1576 conn_width = 80; conn_height = 0;
1577 conn_info = Some (WEB, (Ip.null, 0));
1578 }
1579
1580 let create_http_handler () =
1581 let config = {
1582 bind_addr = Ip.to_inet_addr !!http_bind_addr ;
1583 port = !!http_port;
1584 requests = [];
1585 addrs = Ip_set.of_list !!allowed_ips;
1586 (* do not limit access to MLDonkey web interface by IP blocklist *)
1587 use_ip_block_list = false;
1588 base_ref = "";
1589 default = http_handler http_options;
1590 } in
1591 option_hook allowed_ips (fun _ ->
1592 config.addrs <- Ip_set.of_list !!allowed_ips);
1593 ignore(find_port "http server" !!http_bind_addr http_port
1594 (Http_server.handler config));
1595 config.port <- !!http_port
mldonkey - cross-platform multi-network p2p daemon