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