/[mldonkey]/mldonkey/src/daemon/driver/driverControlers.ml
ViewVC logotype

Diff of /mldonkey/src/daemon/driver/driverControlers.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.32 by spiralvoice, Tue Jun 28 22:42:01 2005 UTC revision 1.33 by spiralvoice, Sun Jul 10 23:19:16 2005 UTC
# Line 35  open TcpBufferedSocket Line 35  open TcpBufferedSocket
35  open DriverInteractive  open DriverInteractive
36  open CommonOptions  open CommonOptions
37    
38      
39  let rec dollar_escape o with_frames s =  let rec dollar_escape o with_frames s =
40    String2.convert false (fun b escaped c ->    String2.convert false (fun b escaped c ->
41        if escaped then        if escaped then
42          match c with          match c with
43          | 'O' -> if with_frames then          | 'O' -> if with_frames then
44                if !!html_mods then Buffer.add_string b "output"                if !!html_mods then Buffer.add_string b "output"
45                else Buffer.add_string b " target=\"output\"";                else Buffer.add_string b " target=\"output\"";
46                false                false
47          | 'S' -> if with_frames then          | 'S' -> if with_frames then
48                if !!html_mods then Buffer.add_string b "fstatus"                if !!html_mods then Buffer.add_string b "fstatus"
# Line 50  let rec dollar_escape o with_frames s = Line 50  let rec dollar_escape o with_frames s =
50                false                false
51          | 'P' -> if with_frames then          | 'P' -> if with_frames then
52                if !!html_mods then Buffer.add_string b "_parent"                if !!html_mods then Buffer.add_string b "_parent"
53                else Buffer.add_string b " target=\"_parent\"";                else Buffer.add_string b " target=\"_parent\"";
54                false                false
55          | 'G' -> false          | 'G' -> false
56                
57          | 'r' ->          | 'r' ->
58              if o.conn_output = ANSI then              if o.conn_output = ANSI then
59                Buffer.add_string b Terminal.ANSI.ansi_RED;                Buffer.add_string b Terminal.ANSI.ansi_RED;
60              false              false
61                
62          | 'b' ->          | 'b' ->
63              if o.conn_output = ANSI then              if o.conn_output = ANSI then
64                Buffer.add_string b Terminal.ANSI.ansi_BLUE;                Buffer.add_string b Terminal.ANSI.ansi_BLUE;
65              false              false
66                
67          | 'g' ->          | 'g' ->
68              if o.conn_output = ANSI then              if o.conn_output = ANSI then
69                Buffer.add_string b Terminal.ANSI.ansi_GREEN;                Buffer.add_string b Terminal.ANSI.ansi_GREEN;
70              false              false
71                
72          | 'n' ->          | 'n' ->
73              if o.conn_output = ANSI then              if o.conn_output = ANSI then
74                Buffer.add_string b Terminal.ANSI.ansi_NORMAL;                Buffer.add_string b Terminal.ANSI.ansi_NORMAL;
75              false              false
76                
77          | _ ->          | _ ->
78  (*  (*
79              try              try
80                Buffer.add_string b (dollar_escape with_frames                Buffer.add_string b (dollar_escape with_frames
81                    (CommonNetwork.escape_char c));                    (CommonNetwork.escape_char c));
82                false                false
83                
84              with _ -> *)              with _ -> *)
85                  Buffer.add_char b '$'; Buffer.add_char b c; false                  Buffer.add_char b '$'; Buffer.add_char b c; false
86        else        else
# Line 112  let eval auth cmd o = Line 112  let eval auth cmd o =
112                let ncmd = ref cmd in                let ncmd = ref cmd in
113                let nhelp = ref help in                let nhelp = ref help in
114                Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());                Printf.bprintf buf "\\<tr class=\\\"dl-%d\\\"\\>" (html_mods_cntr ());
115                html_mods_td buf [                html_mods_td buf [
116                  ("", "sr", "\\<a href=\\\"submit?q=" ^ !ncmd ^                  ("", "sr", "\\<a href=\\\"submit?q=" ^ !ncmd ^
117                    "\\\"\\>" ^ !ncmd ^ "\\</a\\>");                    "\\\"\\>" ^ !ncmd ^ "\\</a\\>");
118                  ("", "srw", Str.global_replace (Str.regexp "\n") "\\<br\\>" !nhelp);                  ("", "srw", Str.global_replace (Str.regexp "\n") "\\<br\\>" !nhelp);
119                  ("", "sr", "\\<a href=\\\"http://mldonkey.berlios.de/modules.php?name=Wiki&pagename=" ^ !ncmd ^                  ("", "sr", "\\<a href=\\\"http://mldonkey.berlios.de/modules.php?name=Wiki&pagename=" ^ !ncmd ^
120                    "\\\"\\>wiki\\</a\\>"); ];                    "\\\"\\>wiki\\</a\\>"); ];
121                Printf.bprintf buf "\\</tr\\>\n";                Printf.bprintf buf "\\</tr\\>\n";
122            )            )
123            (List.sort (fun (c1,_, _,_) (c2,_, _,_) -> compare c1 c2)            (List.sort (fun (c1,_, _,_) (c2,_, _,_) -> compare c1 c2)
124              !CommonNetwork.network_commands);              !CommonNetwork.network_commands);
125            Printf.bprintf buf "\\</table\\>\\</div\\>";            Printf.bprintf buf "\\</table\\>\\</div\\>";
# Line 130  let eval auth cmd o = Line 130  let eval auth cmd o =
130              ("", "sr", "[< >] : optionnal parameter");              ("", "sr", "[< >] : optionnal parameter");
131              ("", "sr", "< 1 | 2 > : alternative parameter"); ];              ("", "sr", "< 1 | 2 > : alternative parameter"); ];
132            Printf.bprintf buf "\\</table\\>\\</div\\>\\</div\\>"            Printf.bprintf buf "\\</table\\>\\</div\\>\\</div\\>"
133          end else                  end else
134          begin          begin
135            Buffer.add_string  buf M.available_commands_are;            Buffer.add_string  buf M.available_commands_are;
136            let list = Hashtbl2.to_list2 commands_by_kind in            let list = Hashtbl2.to_list2 commands_by_kind in
# Line 142  let eval auth cmd o = Line 142  let eval auth cmd o =
142                    Printf.bprintf buf "$r%s$n %s\n" cmd help;                    Printf.bprintf buf "$r%s$n %s\n" cmd help;
143                ) list                ) list
144            ) list;            ) list;
145          end          end
146            
147      | ["help"] | ["?"] ->      | ["help"] | ["?"] ->
148            let module M = CommonMessages in            let module M = CommonMessages in
149             if o.conn_output = HTML then             if o.conn_output = HTML then
# Line 271  Use '$rhelp command$n' or '$r? command$n Line 271  Use '$rhelp command$n' or '$r? command$n
271      | "?" :: args | "help" :: args ->      | "?" :: args | "help" :: args ->
272            List.iter (fun arg ->            List.iter (fun arg ->
273                List.iter (fun (cmd, _, _, help) ->                List.iter (fun (cmd, _, _, help) ->
274                    if cmd = arg then                        if cmd = arg then
275                      Printf.bprintf  buf "%s %s\n" cmd help)                      Printf.bprintf  buf "%s %s\n" cmd help)
276                !CommonNetwork.network_commands)                !CommonNetwork.network_commands)
277            args            args
278      | one :: two ->      | one :: two ->
279          let cmd, args =          let cmd, args =
280            (try            (try
281               let command = List.assoc one !!alias_commands in               let command = List.assoc one !!alias_commands in
282               match String2.split command ' ' with               match String2.split command ' ' with
283                   []   -> raise Not_found (* can't happen *)                   []   -> raise Not_found (* can't happen *)
284                 | [a]  -> a, two                 | [a]  -> a, two
285                 | a::b -> a, (b @ two)                 | a::b -> a, (b @ two)
286             with             with
287                 Not_found -> one, two)                 Not_found -> one, two)
288          in          in
289        if cmd = "q" then        if cmd = "q" then
290          raise CommonTypes.CommandCloseSocket          raise CommonTypes.CommandCloseSocket
291        else        else
# Line 301  Use '$rhelp command$n' or '$r? command$n Line 301  Use '$rhelp command$n' or '$r? command$n
301              o.conn_user <- find_ui_user user;              o.conn_user <- find_ui_user user;
302              let module M = CommonMessages in              let module M = CommonMessages in
303              Buffer.add_string buf M.full_access              Buffer.add_string buf M.full_access
304            end else            end else
305          let module M = CommonMessages in          let module M = CommonMessages in
306          Buffer.add_string buf M.bad_login          Buffer.add_string buf M.bad_login
307        else        else
308        if !auth then        if !auth then
309          DriverCommands.execute_command          DriverCommands.execute_command
310            !CommonNetwork.network_commands o cmd args                  !CommonNetwork.network_commands o cmd args
311        else        else
312        let module M = CommonMessages in        let module M = CommonMessages in
313        Buffer.add_string buf M.command_not_authorized        Buffer.add_string buf M.command_not_authorized
314    
315                  
316  (* This function is called every hour to check if we have something to do  (* This function is called every hour to check if we have something to do
317  just now *)  just now *)
318            
319  let calendar_options = {  let calendar_options = {
320      conn_buf = Buffer.create 1000;      conn_buf = Buffer.create 1000;
321      conn_output = TEXT;      conn_output = TEXT;
# Line 324  let calendar_options = { Line 324  let calendar_options = {
324      conn_user = default_user;      conn_user = default_user;
325      conn_width = 80; conn_height = 0;      conn_width = 80; conn_height = 0;
326    }    }
327          
328  let check_calendar () =  let check_calendar () =
329    let time = last_time () in    let time = last_time () in
330    let tm = Unix.localtime (date_of_int time) in    let tm = Unix.localtime (date_of_int time) in
# Line 334  let check_calendar () = Line 334  let check_calendar () =
334            eval (ref true) command calendar_options;            eval (ref true) command calendar_options;
335            lprintf "Calendar execute: %s\n%s\n" command            lprintf "Calendar execute: %s\n%s\n" command
336              (Buffer.contents calendar_options.conn_buf);              (Buffer.contents calendar_options.conn_buf);
337            Buffer.clear calendar_options.conn_buf;                      Buffer.clear calendar_options.conn_buf;
338          end          end
339    ) !!calendar    ) !!calendar
340      
341    
342  (*************************************************************  (*************************************************************
343    
344                    The Telnet Server                    The Telnet Server
     
 **************************************************************)    
345    
346  let before_telnet_output o sock =  **************************************************************)
347    
348    let before_telnet_output o sock =
349    if o.conn_output = ANSI && o.conn_height <> 0 then    if o.conn_output = ANSI && o.conn_height <> 0 then
350      write_string sock (Printf.sprintf      write_string sock (Printf.sprintf
351          "%s%s\n%s%s"          "%s%s\n%s%s"
352          (Terminal.gotoxy 0 (o.conn_height-3))          (Terminal.gotoxy 0 (o.conn_height-3))
353        Terminal.ANSI.ansi_CLREOL        Terminal.ANSI.ansi_CLREOL
354        Terminal.ANSI.ansi_CLREOL        Terminal.ANSI.ansi_CLREOL
355        (Terminal.gotoxy 0 (o.conn_height-3)))        (Terminal.gotoxy 0 (o.conn_height-3)))
356      
357  let after_telnet_output o sock =  let after_telnet_output o sock =
358    if o.conn_output = ANSI && o.conn_height <> 0 then    if o.conn_output = ANSI && o.conn_height <> 0 then
359      write_string sock (Printf.sprintf "\n\n%s"      write_string sock (Printf.sprintf "\n\n%s"
360          (Terminal.gotoxy 0 (o.conn_height - 2)));          (Terminal.gotoxy 0 (o.conn_height - 2)));
# Line 362  let after_telnet_output o sock = Line 362  let after_telnet_output o sock =
362      write_string sock (Printf.sprintf "%sMLdonkey command-line:%s\n> "      write_string sock (Printf.sprintf "%sMLdonkey command-line:%s\n> "
363        Terminal.ANSI.ansi_REVERSE        Terminal.ANSI.ansi_REVERSE
364        Terminal.ANSI.ansi_NORMAL)        Terminal.ANSI.ansi_NORMAL)
365      
366  (*    (*
367  let user_reader o telnet sock nread  =  let user_reader o telnet sock nread  =
368    let b = TcpBufferedSocket.buf sock in    let b = TcpBufferedSocket.buf sock in
369    let end_pos = b.pos + b.len in    let end_pos = b.pos + b.len in
370    let new_pos = end_pos - nread in    let new_pos = end_pos - nread in
# Line 375  let user_reader o telnet sock nread  = Line 375  let user_reader o telnet sock nread  =
375        if c <> 13 && c <> 10 && (c < 32 || c > 127) then        if c <> 13 && c <> 10 && (c < 32 || c > 127) then
376          lprintf "term[%d] = %d\n" i c;          lprintf "term[%d] = %d\n" i c;
377      done;      done;
378        
379      if i < end_pos then      if i < end_pos then
380        let c = b.buf.[i] in        let c = b.buf.[i] in
381        let c = int_of_char c in        let c = int_of_char c in
# Line 391  let user_reader o telnet sock nread  = Line 391  let user_reader o telnet sock nread  =
391              eval telnet.telnet_auth cmd o;              eval telnet.telnet_auth cmd o;
392              Buffer.add_char buf '\n';              Buffer.add_char buf '\n';
393              if o.conn_output = ANSI then Buffer.add_string buf "$n";              if o.conn_output = ANSI then Buffer.add_string buf "$n";
394              TcpBufferedSocket.write_string sock              TcpBufferedSocket.write_string sock
395                (dollar_escape o false (Buffer.contents buf));                (dollar_escape o false (Buffer.contents buf));
396              after_telnet_output o sock;              after_telnet_output o sock;
397            end;            end;
# Line 406  let user_reader o telnet sock nread  = Line 406  let user_reader o telnet sock nread  =
406      (try      (try
407         shutdown sock "user quit";         shutdown sock "user quit";
408       with _ -> ());       with _ -> ());
409    | e ->    | e ->
410        before_telnet_output o sock;        before_telnet_output o sock;
411        TcpBufferedSocket.write_string sock        TcpBufferedSocket.write_string sock
412          (Printf.sprintf "exception [%s]\n" (Printexc2.to_string e));          (Printf.sprintf "exception [%s]\n" (Printexc2.to_string e));
# Line 432  type telnet_conn = { Line 432  type telnet_conn = {
432    }    }
433    
434    
435  let iac_will_naws = "\255\253\031"    let iac_will_naws = "\255\253\031"
436      
437  let user_reader o telnet sock nread  =  let user_reader o telnet sock nread  =
438    let b = TcpBufferedSocket.buf sock in    let b = TcpBufferedSocket.buf sock in
439    let end_pos = b.pos + b.len in    let end_pos = b.pos + b.len in
440    let new_pos = end_pos - nread in    let new_pos = end_pos - nread in
# Line 450  let user_reader o telnet sock nread  = Line 450  let user_reader o telnet sock nread  =
450        if c <> '\255' && telnet.telnet_iac then begin        if c <> '\255' && telnet.telnet_iac then begin
451            telnet.telnet_iac <- false;            telnet.telnet_iac <- false;
452            (match c with            (match c with
453                '\250' | '\251' ->                '\250' | '\251' ->
454                  Buffer.add_char telnet.telnet_buffer c;                                  Buffer.add_char telnet.telnet_buffer c;
455                  telnet.telnet_wait <- 1                  telnet.telnet_wait <- 1
456              | _ ->              | _ ->
457                  Buffer.clear telnet.telnet_buffer                  Buffer.clear telnet.telnet_buffer
458            );            );
459            iter ()            iter ()
460          end else          end else
461          
462        let i = int_of_char c in        let i = int_of_char c in
463        telnet.telnet_iac <- false;        telnet.telnet_iac <- false;
464        let is_normal_char = i > 31 && i < 127 in        let is_normal_char = i > 31 && i < 127 in
465          
466        if telnet.telnet_wait = 1 then begin        if telnet.telnet_wait = 1 then begin
467            Buffer.add_char telnet.telnet_buffer c;            Buffer.add_char telnet.telnet_buffer c;
468            let cmd = Buffer.contents telnet.telnet_buffer in            let cmd = Buffer.contents telnet.telnet_buffer in
# Line 470  let user_reader o telnet sock nread  = Line 470  let user_reader o telnet sock nread  =
470            let len = String.length cmd in            let len = String.length cmd in
471            if len = 2 then            if len = 2 then
472              match cmd with              match cmd with
473                "\251\031" ->                "\251\031" ->
474                  Buffer.clear telnet.telnet_buffer                  Buffer.clear telnet.telnet_buffer
475              | "\250\031" ->              | "\250\031" ->
476                  telnet.telnet_wait <- 4                  telnet.telnet_wait <- 4
477              | _ ->              | _ ->
478                  (*                  (*
479                  lprintf "telnet server: Unknown control sequence %s\n"                  lprintf "telnet server: Unknown control sequence %s\n"
480                    (String.escaped cmd);                *)                    (String.escaped cmd);                *)
# Line 483  let user_reader o telnet sock nread  = Line 483  let user_reader o telnet sock nread  =
483            let s = String.sub cmd 0 2 in            let s = String.sub cmd 0 2 in
484            Buffer.clear telnet.telnet_buffer;            Buffer.clear telnet.telnet_buffer;
485            match s with            match s with
486            | "\250\031" ->            | "\250\031" ->
487                let dx = BigEndian.get_int16 cmd 2 in                let dx = BigEndian.get_int16 cmd 2 in
488                let dy = BigEndian.get_int16 cmd 4 in                let dy = BigEndian.get_int16 cmd 4 in
489                o.conn_width <- dx;                o.conn_width <- dx;
490                o.conn_height <- dy;                o.conn_height <- dy;
491  (*              lprintf "SIZE RECEIVED %d x %d\n" dx dy; *)  (*              lprintf "SIZE RECEIVED %d x %d\n" dx dy; *)
492            | _ ->            | _ ->
493                (*                (*
494                lprintf "telnet server: Unknown control sequence %s\n"                lprintf "telnet server: Unknown control sequence %s\n"
495                (String.escaped cmd); *)                (String.escaped cmd); *)
496                ()                ()
497          end else          end else
498        if telnet.telnet_wait > 1 then begin        if telnet.telnet_wait > 1 then begin
499            Buffer.add_char telnet.telnet_buffer c;            Buffer.add_char telnet.telnet_buffer c;
500            telnet.telnet_wait <- telnet.telnet_wait - 1;            telnet.telnet_wait <- telnet.telnet_wait - 1;
501          end else          end else
502        if is_normal_char then        if is_normal_char then
503          Buffer.add_char telnet.telnet_buffer c          Buffer.add_char telnet.telnet_buffer c
504        else begin        else begin
505  (* evaluate the command *)  (* evaluate the command *)
# Line 513  let user_reader o telnet sock nread  = Line 513  let user_reader o telnet sock nread  =
513                eval telnet.telnet_auth cmd o;                eval telnet.telnet_auth cmd o;
514                Buffer.add_char buf '\n';                Buffer.add_char buf '\n';
515                if o.conn_output = ANSI then Buffer.add_string buf "$n";                if o.conn_output = ANSI then Buffer.add_string buf "$n";
516                TcpBufferedSocket.write_string sock                TcpBufferedSocket.write_string sock
517                  (dollar_escape o false (Buffer.contents buf));                  (dollar_escape o false (Buffer.contents buf));
518                after_telnet_output o sock;                after_telnet_output o sock;
519              end;              end;
# Line 528  let user_reader o telnet sock nread  = Line 528  let user_reader o telnet sock nread  =
528      (try      (try
529         shutdown sock Closed_by_user;         shutdown sock Closed_by_user;
530       with _ -> ());       with _ -> ());
531    | e ->    | e ->
532        before_telnet_output o sock;        before_telnet_output o sock;
533        TcpBufferedSocket.write_string sock        TcpBufferedSocket.write_string sock
534          (Printf.sprintf "exception [%s]\n" (Printexc2.to_string e));          (Printf.sprintf "exception [%s]\n" (Printexc2.to_string e));
535        after_telnet_output o sock        after_telnet_output o sock
536    
537      
538  let user_closed sock  msg =  let user_closed sock  msg =
539    user_socks := List2.removeq sock !user_socks;    user_socks := List2.removeq sock !user_socks;
540    ()    ()
541    
542  (* Here, we clearly need a good html parser to remove tags, and to translate  (* Here, we clearly need a good html parser to remove tags, and to translate
543  special characters. Avoid them in the meantime. *)  special characters. Avoid them in the meantime. *)
544  let text_of_html html =  let text_of_html html =
545    String2.convert false (fun buf state c ->    String2.convert false (fun buf state c ->
546      if state then      if state then
547        c <> '>'        c <> '>'
548      else      else
549        if c = '<' then true else begin        if c = '<' then true else begin
550          Buffer.add_char buf c;          Buffer.add_char buf c;
551          false          false
552        end        end
553  ) html  ) html
554      
555  let telnet_handler t event =  let telnet_handler t event =
556    match event with    match event with
557      TcpServerSocket.CONNECTION (s, Unix.ADDR_INET (from_ip, from_port)) ->      TcpServerSocket.CONNECTION (s, Unix.ADDR_INET (from_ip, from_port)) ->
558        let from_ip = Ip.of_inet_addr from_ip in        let from_ip = Ip.of_inet_addr from_ip in
559        if Ip.matches from_ip !!allowed_ips then        if Ip.matches from_ip !!allowed_ips then
560          let token = create_token unlimited_connection_manager in          let token = create_token unlimited_connection_manager in
561          let sock = TcpBufferedSocket.create_simple token          let sock = TcpBufferedSocket.create_simple token
562            "telnet connection"            "telnet connection"
# Line 573  let telnet_handler t event = Line 573  let telnet_handler t event =
573              conn_sortvd = NotSorted;              conn_sortvd = NotSorted;
574              conn_filter = (fun _ -> ());              conn_filter = (fun _ -> ());
575              conn_user = default_user;              conn_user = default_user;
576              conn_width = 80;              conn_width = 80;
577              conn_height = 0;              conn_height = 0;
578            } in            } in
579          TcpBufferedSocket.prevent_close sock;          TcpBufferedSocket.prevent_close sock;
# Line 589  let telnet_handler t event = Line 589  let telnet_handler t event =
589    
590          TcpBufferedSocket.write_string sock (dollar_escape o false          TcpBufferedSocket.write_string sock (dollar_escape o false
591              "\n$bWelcome on mldonkey command-line$n\n\nUse $r?$n for help\n\n");              "\n$bWelcome on mldonkey command-line$n\n\nUse $r?$n for help\n\n");
592            
593          after_telnet_output o sock          after_telnet_output o sock
594        else        else
595          Unix.close s          Unix.close s
596    
597    | _ -> ()    | _ -> ()
# Line 599  let telnet_handler t event = Line 599  let telnet_handler t event =
599  (*************************************************************  (*************************************************************
600    
601                    The Chat Server                    The Chat Server
     
 **************************************************************)    
602    
603  let chat_handler t event =  **************************************************************)
604    
605    let chat_handler t event =
606    match event with    match event with
607      TcpServerSocket.CONNECTION (s, Unix.ADDR_INET (from_ip, from_port)) ->      TcpServerSocket.CONNECTION (s, Unix.ADDR_INET (from_ip, from_port)) ->
608        (        (
# Line 615  let chat_handler t event = Line 615  let chat_handler t event =
615                conn_user = default_user;                conn_user = default_user;
616                conn_width = 80; conn_height = 0;                conn_width = 80; conn_height = 0;
617              } in              } in
618              
619           let from_ip = Ip.of_inet_addr from_ip in           let from_ip = Ip.of_inet_addr from_ip in
620           if Ip.matches from_ip !!allowed_ips then           if Ip.matches from_ip !!allowed_ips then
621             (             (
622              let chanin = Unix.in_channel_of_descr s in              let chanin = Unix.in_channel_of_descr s in
623              let chanout = Unix.out_channel_of_descr s in              let chanout = Unix.out_channel_of_descr s in
624              let paq = Chat_proto.read_packet_channel chanin in              let paq = Chat_proto.read_packet_channel chanin in
625              let ret =              let ret =
626                match paq with                match paq with
627                  ((v,id,(host,port)),iddest,pro) ->                  ((v,id,(host,port)),iddest,pro) ->
628                    if v <> CommonChat.version then                    if v <> CommonChat.version then
629                      None                      None
630                    else                    else
631                      Some paq                      Some paq
632              in              in
633              close_out chanout;              close_out chanout;
634              (match ret with              (match ret with
635                None -> ()                None -> ()
636              | Some ((v,id,(host,port)),iddest,pro) ->              | Some ((v,id,(host,port)),iddest,pro) ->
637                  match pro with                  match pro with
638                    Chat_proto.Hello ->                    Chat_proto.Hello ->
639                      CommonChat.send_hello_ok ()                      CommonChat.send_hello_ok ()
640                  | Chat_proto.HelloOk -> ()                  | Chat_proto.HelloOk -> ()
641                  | Chat_proto.AddOpen _ -> ()                  | Chat_proto.AddOpen _ -> ()
642                  | Chat_proto.Byebye -> ()                  | Chat_proto.Byebye -> ()
643                  | Chat_proto.RoomMessage _ ->                  | Chat_proto.RoomMessage _ ->
644                      (* A VOIR *)                      (* A VOIR *)
645                      ()                      ()
646                  | Chat_proto.Message s ->                  | Chat_proto.Message s ->
647                      if iddest = !!CommonOptions.chat_console_id then                      if iddest = !!CommonOptions.chat_console_id then
648                     (* we must eval the string as a command *)                     (* we must eval the string as a command *)
649                        (                        (
650                              let buf = o.conn_buf in                              let buf = o.conn_buf in
651                              Buffer.clear buf;                              Buffer.clear buf;
652                         let auth = ref true in                         let auth = ref true in
653                         eval auth s o;                         eval auth s o;
654                         CommonChat.send_text !!CommonOptions.chat_console_id None                         CommonChat.send_text !!CommonOptions.chat_console_id None
655                           (dollar_escape o false (Buffer.contents buf));                           (dollar_escape o false (Buffer.contents buf));
656                         Buffer.reset buf                         Buffer.reset buf
657                        )                        )
658                      else                      else
659                     (* we must forward the message *)                     (* we must forward the message *)
660                        (networks_iter (fun r ->                        (networks_iter (fun r ->
661                          network_private_message r iddest s)                          network_private_message r iddest s)
662                        )                        )
663              )              )
664             )             )
665           else           else
666             Unix.close s             Unix.close s
667       with       with
668         Failure mess ->         Failure mess ->
669           lprintf "%s\n" mess;           lprintf "%s\n" mess;
670           Unix.close s           Unix.close s
671      )      )
672    | _ ->    | _ ->
673        ()        ()
# Line 675  let chat_handler t event = Line 675  let chat_handler t event =
675  (*************************************************************  (*************************************************************
676    
677                    The HTTP Server                    The HTTP Server
678      
679  **************************************************************)    **************************************************************)
680    
681  let buf = Buffer.create 1000  let buf = Buffer.create 1000
682          
683  let html_page = ref true    let html_page = ref true
684    
685  open Http_server  open Http_server
686    
687  let get_theme_page page =  let get_theme_page page =
688          let theme = Filename.concat html_themes_dir !!html_mods_theme in          let theme = Filename.concat html_themes_dir !!html_mods_theme in
689          let fname = Filename.concat theme page in fname          let fname = Filename.concat theme page in fname
690    
691  let theme_page_exists page =  let theme_page_exists page =
692          if Sys.file_exists (get_theme_page page) then true else false          if Sys.file_exists (get_theme_page page) then true else false
693    
694  (* if files are small really_input should be okay *)  (* if files are small really_input should be okay *)
695  let read_theme_page page =  let read_theme_page page =
696          let theme_page = get_theme_page page in          let theme_page = get_theme_page page in
697          let file = open_in theme_page in          let file = open_in theme_page in
698          let size = (Unix.stat theme_page).Unix.st_size in          let size = (Unix.stat theme_page).Unix.st_size in
699          let s = String.make size ' ' in          let s = String.make size ' ' in
700          let ok = really_input file s 0 size in          let ok = really_input file s 0 size in
701          close_in file; s          close_in file; s
702      
703  let add_simple_commands buf =  let add_simple_commands buf =
704    let this_page = "commands.html" in    let this_page = "commands.html" in
705    Buffer.add_string buf (    Buffer.add_string buf (
# Line 707  let add_simple_commands buf = Line 707  let add_simple_commands buf =
707        read_theme_page this_page else        read_theme_page this_page else
708      if !!html_mods then !!CommonMessages.web_common_header_mods0      if !!html_mods then !!CommonMessages.web_common_header_mods0
709      else !!CommonMessages.web_common_header_old)      else !!CommonMessages.web_common_header_old)
710      
711  let http_add_gen_header r =  let http_add_gen_header r =
712    add_reply_header r "Server" "MLdonkey";    add_reply_header r "Server" "MLdonkey";
713    add_reply_header r "Connection" "close"    add_reply_header r "Connection" "close"
# Line 716  let add_gzip_headers r = Line 716  let add_gzip_headers r =
716    if Autoconf.has_zlib && !!html_use_gzip then begin    if Autoconf.has_zlib && !!html_use_gzip then begin
717      add_reply_header r "Content-Encoding" "gzip";      add_reply_header r "Content-Encoding" "gzip";
718      add_reply_header r "Vary" "Accept-Encoding";      add_reply_header r "Vary" "Accept-Encoding";
719    end    end
720    
721  let http_add_html_header r =  let http_add_html_header r =
722    http_add_gen_header r;    http_add_gen_header r;
723    add_reply_header r "Pragma" "no-cache";    add_reply_header r "Pragma" "no-cache";
724    add_reply_header r "Content-Type" "text/html; charset=UTF-8";    add_reply_header r "Content-Type" "text/html; charset=UTF-8";
725    add_gzip_headers r    add_gzip_headers r
726    
727  let http_add_css_header r =  let http_add_css_header r =
728    http_add_gen_header r;    http_add_gen_header r;
729    add_reply_header r "Content-Type" "text/css; charset=UTF-8";    add_reply_header r "Content-Type" "text/css; charset=UTF-8";
730    add_gzip_headers r    add_gzip_headers r
# Line 743  let http_add_jpg_header r = Line 743  let http_add_jpg_header r =
743    http_add_gen_header r;    http_add_gen_header r;
744    add_reply_header r "Content-Type" "image/jpg;";    add_reply_header r "Content-Type" "image/jpg;";
745    add_gzip_headers r    add_gzip_headers r
746      
747  let any_ip = Ip.of_inet_addr Unix.inet_addr_any  let any_ip = Ip.of_inet_addr Unix.inet_addr_any
748      
749  let html_open_page buf t r open_body =  let html_open_page buf t r open_body =
750    Buffer.clear buf;    Buffer.clear buf;
751    html_page := true;    html_page := true;
752    http_add_html_header r;    http_add_html_header r;
753      
754    if not !!html_mods then    if not !!html_mods then
755      (Buffer.add_string buf      (Buffer.add_string buf
756        "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\"        "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\"
757          \"http://www.w3.org/TR/html4/frameset.dtd\">\n<HTML>\n<HEAD>\n";)          \"http://www.w3.org/TR/html4/frameset.dtd\">\n<HTML>\n<HEAD>\n";)
758      else Buffer.add_string buf "<html>\n<head>\n";      else Buffer.add_string buf "<html>\n<head>\n";
759      
760    if !CommonInteractive.display_vd then begin    if !CommonInteractive.display_vd then begin
761          let this_page = "dheader.html" in          let this_page = "dheader.html" in
762        Buffer.add_string buf        Buffer.add_string buf
763          (          (
764                  if !!html_mods_theme != "" && theme_page_exists this_page then                  if !!html_mods_theme != "" && theme_page_exists this_page then
765                          read_theme_page this_page else                          read_theme_page this_page else
766                          if !!html_mods then !!CommonMessages.download_html_header_mods0                          if !!html_mods then !!CommonMessages.download_html_header_mods0
767                          else !!CommonMessages.download_html_header_old);                          else !!CommonMessages.download_html_header_old);
768        Printf.bprintf buf "<meta http-equiv=Refresh        Printf.bprintf buf "<meta http-equiv=Refresh
769            content=\"%d\">" !!vd_reload_delay;            content=\"%d\">" !!vd_reload_delay;
770      end else      end else
771          let this_page = "header.html" in          let this_page = "header.html" in
772      Buffer.add_string buf (      Buffer.add_string buf (
773                  if !!html_mods_theme != "" && theme_page_exists this_page then                  if !!html_mods_theme != "" && theme_page_exists this_page then
774                          read_theme_page this_page else                          read_theme_page this_page else
775                          if !!html_mods then !!CommonMessages.html_header_mods0                          if !!html_mods then !!CommonMessages.html_header_mods0
776                          else !!CommonMessages.html_header_old);                          else !!CommonMessages.html_header_old);
777      
778    Buffer.add_string buf "</head>\n";    Buffer.add_string buf "</head>\n";
779    if open_body then Buffer.add_string buf "<body>\n";        if open_body then Buffer.add_string buf "<body>\n";
780    if not !!use_html_frames then add_simple_commands buf;    if not !!use_html_frames then add_simple_commands buf;
781    ()    ()
782      
783  let html_close_page buf =  let html_close_page buf =
784    Buffer.add_string buf "</body>\n";      Buffer.add_string buf "</body>\n";
785    Buffer.add_string buf "</html>\n";    Buffer.add_string buf "</html>\n";
786    ()    ()
787    
788  let clear_page buf =  let clear_page buf =
789    Buffer.clear buf;    Buffer.clear buf;
790    html_page := false    html_page := false
791      
792  let http_handler o t r =  let http_handler o t r =
793    CommonInteractive.display_vd := false;    CommonInteractive.display_vd := false;
794    clear_page buf;    clear_page buf;
795      
796    let user = if r.options.login = "" then "admin" else r.options.login in    let user = if r.options.login = "" then "admin" else r.options.login in
797    if not (valid_password user r.options.passwd) then begin    if not (valid_password user r.options.passwd) then begin
798        clear_page buf;        clear_page buf;
# Line 814  let http_handler o t r = Line 814  let http_handler o t r =
814                add_reply_header r "Server" "MLdonkey";                add_reply_header r "Server" "MLdonkey";
815                add_reply_header r "Connection" "close";                add_reply_header r "Connection" "close";
816                add_reply_header r "Content-Type" "text/vnd.wap.wml";                add_reply_header r "Content-Type" "text/vnd.wap.wml";
817                let dlkbs =                let dlkbs =
818                  (( (float_of_int !udp_download_rate) +. (float_of_int !control_download_rate)) /. 1024.0) in                  (( (float_of_int !udp_download_rate) +. (float_of_int !control_download_rate)) /. 1024.0) in
819                let ulkbs =                let ulkbs =
820                  (( (float_of_int !udp_upload_rate) +. (float_of_int !control_upload_rate)) /. 1024.0) in                  (( (float_of_int !udp_upload_rate) +. (float_of_int !control_upload_rate)) /. 1024.0) in
821                Printf.bprintf buf "                Printf.bprintf buf "
822  <?xml version=\"1.0\"?>  <?xml version=\"1.0\"?>
823  <!DOCTYPE wml PUBLIC \"-//WAPFORUM//DTD WML 1.1//EN\" \"http://www.wapforum.org/DTD/wml_1.1.xml\">  <!DOCTYPE wml PUBLIC \"-//WAPFORUM//DTD WML 1.1//EN\" \"http://www.wapforum.org/DTD/wml_1.1.xml\">
# Line 835  let http_handler o t r = Line 835  let http_handler o t r =
835  (* functions *)  (* functions *)
836                List.iter (fun (arg, value) ->                List.iter (fun (arg, value) ->
837                    match arg with                    match arg with
838                      "VDC" ->                      "VDC" ->
839                        let num = int_of_string value in                        let num = int_of_string value in
840                        let file = file_find num in                        let file = file_find num in
841                        file_cancel file                        file_cancel file
842                    | "VDP" ->                    | "VDP" ->
843                        let num = int_of_string value in                        let num = int_of_string value in
844                        let file = file_find num in                        let file = file_find num in
845                        file_pause file                        file_pause file
846                    | "VDR" ->                    | "VDR" ->
847                        let num = int_of_string value in                        let num = int_of_string value in
848                        let file = file_find num in                        let file = file_find num in
849                        file_resume file                        file_resume file
# Line 855  let http_handler o t r = Line 855  let http_handler o t r =
855                let mfiles = List2.tail_map file_info !!files in                let mfiles = List2.tail_map file_info !!files in
856                List.iter (fun file ->                List.iter (fun file ->
857                    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 />" (if downloading file then "VDP" else "VDR" ) (file.file_num) (if downloading file then "P" else "R" ) (file.file_num) (file.file_num) (file.file_download_rate /. 1024.)(short_name file) (print_human_readable file (Int64.sub file.file_size file.file_downloaded)) (print_human_readable file file.file_size);                    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 />" (if downloading file then "VDP" else "VDR" ) (file.file_num) (if downloading file then "P" else "R" ) (file.file_num) (file.file_num) (file.file_download_rate /. 1024.)(short_name file) (print_human_readable file (Int64.sub file.file_size file.file_downloaded)) (print_human_readable file file.file_size);
858                  
859                ) mfiles;                ) mfiles;
860                Printf.bprintf buf "<br />Downloaded %d/%d files " (List.length !!done_files) (List.length !!files);                Printf.bprintf buf "<br />Downloaded %d/%d files " (List.length !!done_files) (List.length !!files);
861                Printf.bprintf buf "</small></p>";                Printf.bprintf buf "</small></p>";
862                  
                 
863                Printf.bprintf buf "</card></wml>";                Printf.bprintf buf "</card></wml>";
864              end              end
865          | "/commands.html" ->          | "/commands.html" ->
866              html_open_page buf t r true;              html_open_page buf t r true;
867              let this_page = "commands.html" in              let this_page = "commands.html" in
868              Buffer.add_string buf (              Buffer.add_string buf (
869                if !!html_mods_theme != "" && theme_page_exists this_page then                if !!html_mods_theme != "" && theme_page_exists this_page then
870                  read_theme_page this_page else                  read_theme_page this_page else
# Line 874  let http_handler o t r = Line 873  let http_handler o t r =
873          | "/" | "/index.html" ->          | "/" | "/index.html" ->
874              if !!use_html_frames then begin              if !!use_html_frames then begin
875                  html_open_page buf t r false;                  html_open_page buf t r false;
876                  let this_page = "frames.html" in                  let this_page = "frames.html" in
877                  if !!html_mods_theme != "" && theme_page_exists this_page then                  if !!html_mods_theme != "" && theme_page_exists this_page then
878                    Buffer.add_string buf (read_theme_page this_page) else                    Buffer.add_string buf (read_theme_page this_page) else
879                  if !!html_mods then                  if !!html_mods then
880                    Printf.bprintf buf "                    Printf.bprintf buf "
881                           <frameset src=\"index\" rows=\"%d,25,*\">                           <frameset src=\"index\" rows=\"%d,25,*\">
882                    <frame name=\"commands\" NORESIZE SCROLLING=\"NO\" NOSHADE marginwidth=0 marginheight=0 BORDER=0 FRAMESPACING=0 FRAMEBORDER=0 src=\"commands.html\">                    <frame name=\"commands\" NORESIZE SCROLLING=\"NO\" NOSHADE marginwidth=0 marginheight=0 BORDER=0 FRAMESPACING=0 FRAMEBORDER=0 src=\"commands.html\">
883                    <frame name=\"fstatus\" NORESIZE SCROLLING=\"NO\" NOSHADE marginwidth=0 marginheight=0 BORDER=0 FRAMESPACING=0 FRAMEBORDER=0 src=\"noframe.html\">                    <frame name=\"fstatus\" NORESIZE SCROLLING=\"NO\" NOSHADE marginwidth=0 marginheight=0 BORDER=0 FRAMESPACING=0 FRAMEBORDER=0 src=\"noframe.html\">
884                 <frame name=\"output\" NORESIZE NOSHADE marginwidth=0 marginheight=0 BORDER=0 FRAMESPACING=0 FRAMEBORDER=0 src=\"oneframe.html\">                 <frame name=\"output\" NORESIZE NOSHADE marginwidth=0 marginheight=0 BORDER=0 FRAMESPACING=0 FRAMEBORDER=0 src=\"oneframe.html\">
# Line 892  let http_handler o t r = Line 891  let http_handler o t r =
891                    <frame name=\"fstatus\" src=\"noframe.html\">                    <frame name=\"fstatus\" src=\"noframe.html\">
892                 </frameset>                 </frameset>
893                 <frame name=\"output\" src=\"oneframe.html\">                 <frame name=\"output\" src=\"oneframe.html\">
894              </frameset>" !!commands_frame_height;              </frameset>" !!commands_frame_height;
895                end else                end else
896                html_open_page buf t r true                html_open_page buf t r true
897          | "/complex_search.html" ->          | "/complex_search.html" ->
# Line 900  let http_handler o t r = Line 899  let http_handler o t r =
899              CommonSearch.complex_search buf              CommonSearch.complex_search buf
900          | "/noframe.html" ->          | "/noframe.html" ->
901              html_open_page buf t r true              html_open_page buf t r true
902            
903          | "/oneframe.html" ->          | "/oneframe.html" ->
904              html_open_page buf t r true;              html_open_page buf t r true;
905              Buffer.add_string buf !!motd_html              Buffer.add_string buf !!motd_html
# Line 908  let http_handler o t r = Line 907  let http_handler o t r =
907          | "/bw_updown.png" ->          | "/bw_updown.png" ->
908              do_draw_pic "Traffic" "s(kb)" "t(h:m:s)" download_history upload_history;              do_draw_pic "Traffic" "s(kb)" "t(h:m:s)" download_history upload_history;
909              (* Buffer.clear buf; *)              (* Buffer.clear buf; *)
910              html_page := false;              html_page := false;
911              http_add_png_header r;              http_add_png_header r;
912              let showgraph = File.to_string "bw_updown.png" in              let showgraph = File.to_string "bw_updown.png" in
913              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
914            
915          | "/bw_updown.jpg" ->          | "/bw_updown.jpg" ->
916              do_draw_pic "Traffic" "s(kb)" "t(h:m:s)" download_history upload_history;              do_draw_pic "Traffic" "s(kb)" "t(h:m:s)" download_history upload_history;
917              (* Buffer.clear buf;*)              (* Buffer.clear buf;*)
918              html_page := false;              html_page := false;
919              http_add_jpg_header r;              http_add_jpg_header r;
920              let showgraph = File.to_string "bw_updown.jpg" in              let showgraph = File.to_string "bw_updown.jpg" in
921              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
922    
923          | "/bw_download.png" ->          | "/bw_download.png" ->
924              do_draw_down_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_history;              do_draw_down_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_history;
925              html_page := false;              html_page := false;
926              http_add_png_header r;              http_add_png_header r;
927              let showgraph = File.to_string "bw_download.png" in              let showgraph = File.to_string "bw_download.png" in
928              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
# Line 931  let http_handler o t r = Line 930  let http_handler o t r =
930          | "/bw_download.jpg" ->          | "/bw_download.jpg" ->
931              do_draw_down_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_history;              do_draw_down_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_history;
932              Buffer.clear buf;              Buffer.clear buf;
933              html_page := false;              html_page := false;
934              http_add_jpg_header r;              http_add_jpg_header r;
935              let showgraph = File.to_string "bw_download.jpg" in              let showgraph = File.to_string "bw_download.jpg" in
936              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
937    
938          | "/bw_upload.png" ->          | "/bw_upload.png" ->
939              do_draw_up_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_history;              do_draw_up_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_history;
940              html_page := false;              html_page := false;
941              http_add_png_header r;              http_add_png_header r;
942              let showgraph = File.to_string "bw_upload.png" in              let showgraph = File.to_string "bw_upload.png" in
943              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
# Line 946  let http_handler o t r = Line 945  let http_handler o t r =
945          | "/bw_upload.jpg" ->          | "/bw_upload.jpg" ->
946              do_draw_up_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_history;              do_draw_up_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_history;
947              Buffer.clear buf;              Buffer.clear buf;
948              html_page := false;              html_page := false;
949              http_add_jpg_header r;              http_add_jpg_header r;
950              let showgraph = File.to_string "bw_upload.jpg" in              let showgraph = File.to_string "bw_upload.jpg" in
951              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
# Line 954  let http_handler o t r = Line 953  let http_handler o t r =
953          | "/bw_h_updown.png" ->          | "/bw_h_updown.png" ->
954              do_draw_h_pic "Traffic" "s(kb)" "t(h:m:s)" download_h_history upload_h_history;              do_draw_h_pic "Traffic" "s(kb)" "t(h:m:s)" download_h_history upload_h_history;
955              (* Buffer.clear buf; *)              (* Buffer.clear buf; *)
956              html_page := false;              html_page := false;
957              http_add_png_header r;              http_add_png_header r;
958              let showgraph = File.to_string "bw_h_updown.png" in              let showgraph = File.to_string "bw_h_updown.png" in
959              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
# Line 962  let http_handler o t r = Line 961  let http_handler o t r =
961          | "/bw_h_updown.jpg" ->          | "/bw_h_updown.jpg" ->
962              do_draw_h_pic "Traffic" "s(kb)" "t(h:m:s)" download_h_history upload_h_history;              do_draw_h_pic "Traffic" "s(kb)" "t(h:m:s)" download_h_history upload_h_history;
963              (* Buffer.clear buf;*)              (* Buffer.clear buf;*)
964              html_page := false;              html_page := false;
965              http_add_jpg_header r;              http_add_jpg_header r;
966              let showgraph = File.to_string "bw_h_updown.jpg" in              let showgraph = File.to_string "bw_h_updown.jpg" in
967              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
968    
969          | "/bw_h_download.png" ->          | "/bw_h_download.png" ->
970              do_draw_down_h_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_h_history;              do_draw_down_h_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_h_history;
971              html_page := false;              html_page := false;
972              http_add_png_header r;              http_add_png_header r;
973              let showgraph = File.to_string "bw_h_download.png" in              let showgraph = File.to_string "bw_h_download.png" in
974              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
# Line 977  let http_handler o t r = Line 976  let http_handler o t r =
976          | "/bw_h_download.jpg" ->          | "/bw_h_download.jpg" ->
977              do_draw_down_h_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_h_history;              do_draw_down_h_pic "Traffic" "download" "s(kb)" "t(h:m:s)" download_h_history;
978              Buffer.clear buf;              Buffer.clear buf;
979              html_page := false;              html_page := false;
980              http_add_jpg_header r;              http_add_jpg_header r;
981              let showgraph = File.to_string "bw_h_download.jpg" in              let showgraph = File.to_string "bw_h_download.jpg" in
982              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
983    
984          | "/bw_h_upload.png" ->          | "/bw_h_upload.png" ->
985              do_draw_up_h_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_h_history;              do_draw_up_h_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_h_history;
986              html_page := false;              html_page := false;
987              http_add_png_header r;              http_add_png_header r;
988              let showgraph = File.to_string "bw_h_upload.png" in              let showgraph = File.to_string "bw_h_upload.png" in
989              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
# Line 992  let http_handler o t r = Line 991  let http_handler o t r =
991          | "/bw_h_upload.jpg" ->          | "/bw_h_upload.jpg" ->
992              do_draw_up_h_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_h_history;              do_draw_up_h_pic "Traffic" "upload" "s(kb)" "t(h:m:s)" upload_h_history;
993              Buffer.clear buf;              Buffer.clear buf;
994              html_page := false;              html_page := false;
995              http_add_jpg_header r;              http_add_jpg_header r;
996              let showgraph = File.to_string "bw_h_upload.jpg" in              let showgraph = File.to_string "bw_h_upload.jpg" in
997              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
# Line 1000  let http_handler o t r = Line 999  let http_handler o t r =
999    
1000          | "/tag.png" ->          | "/tag.png" ->
1001              do_draw_tag !!html_mods_vd_gfx_tag_title download_history upload_history;              do_draw_tag !!html_mods_vd_gfx_tag_title download_history upload_history;
1002              html_page := false;              html_page := false;
1003              http_add_png_header r;              http_add_png_header r;
1004              let showgraph = File.to_string "tag.png" in              let showgraph = File.to_string "tag.png" in
1005              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
# Line 1008  let http_handler o t r = Line 1007  let http_handler o t r =
1007          | "/tag.jpg" ->          | "/tag.jpg" ->
1008              do_draw_tag !!html_mods_vd_gfx_tag_title download_history upload_history;              do_draw_tag !!html_mods_vd_gfx_tag_title download_history upload_history;
1009              (* Buffer.clear buf;*)              (* Buffer.clear buf;*)
1010              html_page := false;              html_page := false;
1011              http_add_jpg_header r;              http_add_jpg_header r;
1012              let showgraph = File.to_string "tag.jpg" in              let showgraph = File.to_string "tag.jpg" in
1013              Buffer.add_string buf showgraph              Buffer.add_string buf showgraph
1014    
1015          | "/filter" ->          | "/filter" ->
1016              html_open_page buf t r true;              html_open_page buf t r true;
1017              let b = Buffer.create 10000 in              let b = Buffer.create 10000 in
1018              let filter = ref (fun _ -> ()) in              let filter = ref (fun _ -> ()) in
1019              begin                            begin
1020                match r.get_url.Url.args with                match r.get_url.Url.args with
1021                  ("num", num) :: args ->                  ("num", num) :: args ->
1022                    List.iter (fun (arg, value) ->                    List.iter (fun (arg, value) ->
1023                        match arg with                        match arg with
1024                        | "media" ->                        | "media" ->
1025                            let old_filter = !filter in                            let old_filter = !filter in
1026                            filter := (fun r ->                            filter := (fun r ->
1027                                if r.result_type = value then raise Not_found;                                if r.result_type = value then raise Not_found;
1028                                old_filter r                                old_filter r
1029                            )                            )
1030                        | "format" ->                        | "format" ->
1031                            let old_filter = !filter in                            let old_filter = !filter in
1032                            filter := (fun r ->                            filter := (fun r ->
1033                                if r.result_format = value then raise Not_found;                                if r.result_format = value then raise Not_found;
1034                                old_filter r                                old_filter r
1035                            )                            )
1036                        | "size" ->                        | "size" ->
1037                            let old_filter = !filter in                            let old_filter = !filter in
1038                            let mega5 = Int64.of_int (5 * 1024 * 1024) in                            let mega5 = Int64.of_int (5 * 1024 * 1024) in
1039                            let mega20 = Int64.of_int (20 * 1024 * 1024) in                            let mega20 = Int64.of_int (20 * 1024 * 1024) in
# Line 1047  let http_handler o t r = Line 1046  let http_handler o t r =
1046                              | _ -> Int64.zero, Int64.max_int                              | _ -> Int64.zero, Int64.max_int
1047                            in                            in
1048                            filter := (fun r ->                            filter := (fun r ->
1049                                if r.result_size >= min &&                                if r.result_size >= min &&
1050                                  r.result_size <= max then                                  r.result_size <= max then
1051                                  raise Not_found;                                  raise Not_found;
1052                                old_filter r                                old_filter r
1053                            )                            )
1054                        | _ -> ()                        | _ -> ()
1055                    )  args;                    )  args;
1056                      
1057                    let num = int_of_string num in                    let num = int_of_string num in
1058                    let s = search_find num in                    let s = search_find num in
1059                      
1060                    DriverInteractive.print_search b s                    DriverInteractive.print_search b s
1061                      { o with conn_filter = !filter };                      { o with conn_filter = !filter };
1062                      
1063                    Buffer.add_string buf (html_escaped                    Buffer.add_string buf (html_escaped
1064                        (Buffer.contents b))                        (Buffer.contents b))
1065                  
1066                | _ ->                | _ ->
1067                    Buffer.add_string buf "Bad filter"                    Buffer.add_string buf "Bad filter"
1068              end              end
1069            
1070            
1071          | "/results" ->          | "/results" ->
1072              html_open_page buf t r true;              html_open_page buf t r true;
1073              let b = Buffer.create 10000 in              let b = Buffer.create 10000 in
# Line 1076  let http_handler o t r = Line 1075  let http_handler o t r =
1075                  match arg with                  match arg with
1076                    "d" -> begin                    "d" -> begin
1077                        try                        try
1078                          let num = int_of_string value in                          let num = int_of_string value in
1079                          let r = find_result num in                          let r = find_result num in
1080                          let files = result_download r [] false in                          let files = result_download r [] false in
1081                          List.iter CommonInteractive.start_download files;                          List.iter CommonInteractive.start_download files;
1082                                                    
1083                          let module M = CommonMessages in                          let module M = CommonMessages in
1084                          Gettext.buftext buf M.download_started num                          Gettext.buftext buf M.download_started num
1085                        with  e ->                        with  e ->
1086                            Printf.bprintf buf "Error %s with %s<br>"                            Printf.bprintf buf "Error %s with %s<br>"
1087                              (Printexc2.to_string e) value;                              (Printexc2.to_string e) value;
1088                      end                      end
1089                  | _ -> ()                  | _ -> ()
1090              ) r.get_url.Url.args;              ) r.get_url.Url.args;
1091              Buffer.add_string buf (html_escaped (Buffer.contents b))              Buffer.add_string buf (html_escaped (Buffer.contents b))
1092            
           
1093          | "/files" ->          | "/files" ->
1094                
1095              List.iter (fun (arg, value) ->              List.iter (fun (arg, value) ->
1096                  match arg with                  match arg with
1097                    "cancel" ->                    "cancel" ->
1098                      let num = int_of_string value in                      let num = int_of_string value in
1099                      let file = file_find num in                      let file = file_find num in
1100                      file_cancel file                      file_cancel file
1101                  | "pause" ->                  | "pause" ->
1102                      let num = int_of_string value in                      let num = int_of_string value in
1103                      let file = file_find num in                      let file = file_find num in
1104                      file_pause file                      file_pause file
1105                  | "resume" ->                  | "resume" ->
1106                      let num = int_of_string value in                      let num = int_of_string value in
1107                      let file = file_find num in                      let file = file_find num in
1108                      file_resume file                      file_resume file
1109                  | "sortby" ->                  | "sortby" ->
1110                      begin                      begin
1111                        match value with                        match value with
1112                        | "Percent" -> o.conn_sortvd <- ByPercent                        | "Percent" -> o.conn_sortvd <- ByPercent
# Line 1135  let http_handler o t r = Line 1133  let http_handler o t r =
1133              DriverInteractive.display_file_list b o;              DriverInteractive.display_file_list b o;
1134              html_open_page buf t r true;              html_open_page buf t r true;
1135              Buffer.add_string buf (html_escaped (Buffer.contents b))              Buffer.add_string buf (html_escaped (Buffer.contents b))
1136            
1137          | "/submit" ->          | "/submit" ->
1138              begin              begin
1139                match r.get_url.Url.args with                match r.get_url.Url.args with
# Line 1150  let http_handler o t r = Line 1148  let http_handler o t r =
1148                        | "sortby", "priority" -> o.conn_sortvd <- ByPriority                        | "sortby", "priority" -> o.conn_sortvd <- ByPriority
1149                        | _ -> ()                        | _ -> ()
1150                    ) other_args;                    ) other_args;
1151                    let s =                    let s =
1152                      let b = o.conn_buf in                      let b = o.conn_buf in
1153                      clear_page b;                      clear_page b;
1154                      eval (ref true) cmd o;                      eval (ref true) cmd o;
# Line 1161  let http_handler o t r = Line 1159  let http_handler o t r =
1159  (* Konqueror doesn't like html within <pre> *)  (* Konqueror doesn't like html within <pre> *)
1160                    let drop_pre = ref false in                    let drop_pre = ref false in
1161                    let rawcmd = ref cmd in                    let rawcmd = ref cmd in
1162                      
1163                    if String.contains cmd ' ' then                    if String.contains cmd ' ' then
1164                      rawcmd := String.sub cmd 0 (String.index cmd ' ');                      rawcmd := String.sub cmd 0 (String.index cmd ' ');
1165                      
1166                    (match !rawcmd with                    (match !rawcmd with
1167                      | "vm" | "vma" | "view_custom_queries"  | "xs" | "vr"                      | "vm" | "vma" | "view_custom_queries"  | "xs" | "vr"
1168                      | "afr" | "friend_remove" | "reshare" | "recover_temp"                      | "afr" | "friend_remove" | "reshare" | "recover_temp"
1169                      | "c" | "commit" | "bw_stats" | "ovweb" | "friends"                      | "c" | "commit" | "bw_stats" | "ovweb" | "friends"
# Line 1175  let http_handler o t r = Line 1173  let http_handler o t r =
1173                      | "vd" | "vo" | "voo" | "upstats" | "shares" | "share"                      | "vd" | "vo" | "voo" | "upstats" | "shares" | "share"
1174                      | "unshare" | "stats" | "users" -> drop_pre := true;                      | "unshare" | "stats" | "users" -> drop_pre := true;
1175                      | _ -> ());                      | _ -> ());
1176                      
1177                    Printf.bprintf buf "%s\n"                    Printf.bprintf buf "%s\n"
1178                      (if use_html_mods o && !drop_pre then s else "\n<pre>\n" ^ s ^ "</pre>");                      (if use_html_mods o && !drop_pre then s else "\n<pre>\n" ^ s ^ "</pre>");
1179                  
1180                | [ ("custom", query) ] ->                | [ ("custom", query) ] ->
1181                    html_open_page buf t r true;                    html_open_page buf t r true;
1182                    CommonSearch.custom_query buf query                    CommonSearch.custom_query buf query
1183                  
1184                | ("custom", query) :: args ->                | ("custom", query) :: args ->
1185                    html_open_page buf t r true;                    html_open_page buf t r true;
1186                    send_custom_query o.conn_user buf query  args                    send_custom_query o.conn_user buf query args
1187                  
1188                | [ "setoption", _ ; "option", name; "value", value ] ->                | [ "setoption", _ ; "option", name; "value", value ] ->
1189                    html_open_page buf t r true;                    html_open_page buf t r true;
1190                    CommonInteractive.set_fully_qualified_options name value;                    CommonInteractive.set_fully_qualified_options name value;
1191                    Buffer.add_string buf "Option value changed"                    Buffer.add_string buf "Option value changed"
1192                  
1193                | args ->                | args ->
1194                    List.iter (fun (s,v) ->                    List.iter (fun (s,v) ->
1195                        lprintf "[%s]=[%s]\n" (String.escaped s) (String.escaped v))                        lprintf "[%s]=[%s]\n" (String.escaped s) (String.escaped v))
1196                    args;                    args;
1197                    raise Not_found                    raise Not_found
1198              end              end
1199            
1200          | "/preview_download" ->          | "/preview_download" ->
1201              begin              begin
1202                clear_page buf;                clear_page buf;
# Line 1208  let http_handler o t r = Line 1206  let http_handler o t r =
1206                    let file = file_find file_num in                    let file = file_find file_num in
1207                    let fd = file_fd file in                    let fd = file_fd file in
1208                    let size = file_size file in                    let size = file_size file in
1209                      
1210                    let (begin_pos, end_pos) =                    let (begin_pos, end_pos) =
1211                      try                      try
1212                        let (begin_pos, end_pos) = request_range r in                        let (begin_pos, end_pos) = request_range r in
1213                        let end_pos = match end_pos with                        let end_pos = match end_pos with
# Line 1217  let http_handler o t r = Line 1215  let http_handler o t r =
1215                          | Some end_pos -> end_pos in                          | Some end_pos -> end_pos in
1216                        let range_size = end_pos -- begin_pos in                        let range_size = end_pos -- begin_pos in
1217                        add_reply_header r "Content-Length"                        add_reply_header r "Content-Length"
1218                          (Int64.to_string range_size);                                                (Int64.to_string range_size);
1219                        add_reply_header r "Content-Range"                        add_reply_header r "Content-Range"
1220                          (Printf.sprintf "bytes %Ld-%Ld/%Ld"                          (Printf.sprintf "bytes %Ld-%Ld/%Ld"
1221                            begin_pos (end_pos -- one)                            begin_pos (end_pos -- one)
1222                          size);                          size);
# Line 1229  let http_handler o t r = Line 1227  let http_handler o t r =
1227                            (Int64.to_string size);                            (Int64.to_string size);
1228                          zero, size                          zero, size
1229                    in                    in
1230                      
1231                    add_reply_header r "Content-type" "application/binary";                    add_reply_header r "Content-type" "application/binary";
1232                    add_reply_header r "Accept-Ranges" "bytes";                    add_reply_header r "Accept-Ranges" "bytes";
1233    
1234                    let s = String.create 200000 in                    let s = String.create 200000 in
1235                    set_max_output_buffer r.sock (String.length s);                    set_max_output_buffer r.sock (String.length s);
1236                    set_rtimeout r.sock 10000.;                                      set_rtimeout r.sock 10000.;
1237                    let rec stream_file file pos sock =                    let rec stream_file file pos sock =
1238                      let max = (max_refill sock) - 1 in                      let max = (max_refill sock) - 1 in
1239                      if max > 0 && !pos < end_pos then                      if max > 0 && !pos < end_pos then
1240                        let max64 = min (end_pos -- !pos) (Int64.of_int max)  in                        let max64 = min (end_pos -- !pos) (Int64.of_int max) in
1241                        let max = Int64.to_int max64 in                        let max = Int64.to_int max64 in
1242                        Unix32.read fd !pos s 0 max;                        Unix32.read fd !pos s 0 max;
1243                        pos := !pos ++ max64;                        pos := !pos ++ max64;
1244                        set_lifetime sock 60.;                        set_lifetime sock 60.;
1245  (*                      lprintf "HTTPSEND: refill %d %Ld\n" max !pos;*)  (*                      lprintf "HTTPSEND: refill %d %Ld\n" max !pos;*)
1246  (*                    lprintf "HTTPSEND: [%s]\n" (String.escaped  (*                    lprintf "HTTPSEND: [%s]\n" (String.escaped
1247                          (String.sub s 0 max)); *)                          (String.sub s 0 max)); *)
1248                        write sock s 0 max;                        write sock s 0 max;
1249                        if output_buffered sock = 0 then begin                        if output_buffered sock = 0 then begin
# Line 1258  let http_handler o t r = Line 1256  let http_handler o t r =
1256                | args ->                | args ->
1257                    List.iter (fun (s,v) ->                    List.iter (fun (s,v) ->
1258                        lprintf "[%s]=[%s]\n" (String.escaped s) (String.escaped v))                        lprintf "[%s]=[%s]\n" (String.escaped s) (String.escaped v))
1259                    args;                    args;
1260                    raise Not_found                                      raise Not_found
1261              end              end
1262                
1263          | "/h.css" ->          | "/h.css" ->
1264              clear_page buf;              clear_page buf;
1265              http_add_css_header r;              http_add_css_header r;
# Line 1271  let http_handler o t r = Line 1269  let http_handler o t r =
1269                  read_theme_page this_page else                  read_theme_page this_page else
1270                if !!html_mods then !CommonMessages.html_css_mods                if !!html_mods then !CommonMessages.html_css_mods
1271                else !!CommonMessages.html_css_old)                else !!CommonMessages.html_css_old)
1272            
1273          | "/dh.css" ->                    | "/dh.css" ->
1274              clear_page buf;              clear_page buf;
1275              http_add_css_header r;              http_add_css_header r;
1276              let this_page = "dh.css" in              let this_page = "dh.css" in
# Line 1281  let http_handler o t r = Line 1279  let http_handler o t r =
1279                  read_theme_page this_page else                  read_theme_page this_page else
1280                if !!html_mods then !CommonMessages.download_html_css_mods                if !!html_mods then !CommonMessages.download_html_css_mods
1281                else !!CommonMessages.download_html_css_old)                else !!CommonMessages.download_html_css_old)
1282            
1283          | "/i.js" ->          | "/i.js" ->
1284              clear_page buf;              clear_page buf;
1285              http_add_js_header r;              http_add_js_header r;
# Line 1291  let http_handler o t r = Line 1289  let http_handler o t r =
1289                  read_theme_page this_page else                  read_theme_page this_page else
1290                if !!html_mods then !!CommonMessages.html_js_mods0                if !!html_mods then !!CommonMessages.html_js_mods0
1291                else !!CommonMessages.html_js_old)                else !!CommonMessages.html_js_old)
1292            
1293          | "/di.js" ->                    | "/di.js" ->
1294              clear_page buf;              clear_page buf;
1295              http_add_js_header r;              http_add_js_header r;
1296              let this_page = "di.js" in              let this_page = "di.js" in
# Line 1308  let http_handler o t r = Line 1306  let http_handler o t r =
1306            Printf.bprintf buf "\nException %s\n" (Printexc2.to_string e);            Printf.bprintf buf "\nException %s\n" (Printexc2.to_string e);
1307            r.reply_stream <- None            r.reply_stream <- None
1308      end;      end;
1309      
1310    if !html_page then  html_close_page buf;    if !html_page then  html_close_page buf;
1311    let s = Buffer.contents buf in    let s = Buffer.contents buf in
1312    let s = dollar_escape o !!use_html_frames s in    let s = dollar_escape o !!use_html_frames s in
1313    r.reply_content <- if Autoconf.has_zlib && !!html_use_gzip then Autoconf.zlib__gzip_string s else s    r.reply_content <- if Autoconf.has_zlib && !!html_use_gzip then Autoconf.zlib__gzip_string s else s
1314            
1315  let http_options = {  let http_options = {
1316      conn_buf = Buffer.create 10000;      conn_buf = Buffer.create 10000;
1317      conn_output = HTML;      conn_output = HTML;
1318      conn_sortvd = NotSorted;      conn_sortvd = NotSorted;
1319      conn_filter = (fun _ -> ());      conn_filter = (fun _ -> ());
1320      conn_user = default_user;      conn_user = default_user;
1321      conn_width = 80; conn_height = 0;      conn_width = 80; conn_height = 0;
1322    }          }
1323      
1324  let create_http_handler () =  let create_http_handler () =
1325    let config = {    let config = {
1326        bind_addr = Ip.to_inet_addr !!http_bind_addr ;        bind_addr = Ip.to_inet_addr !!http_bind_addr ;
1327        port = !!http_port;        port = !!http_port;
1328        requests = [];        requests = [];
1329        addrs = !!allowed_ips;        addrs = !!allowed_ips;
1330        base_ref = "";        base_ref = "";
1331        default = http_handler http_options;              default = http_handler http_options;
1332      } in      } in
1333    option_hook allowed_ips (fun _ -> config.addrs <- !!allowed_ips);    option_hook allowed_ips (fun _ -> config.addrs <- !!allowed_ips);
1334    let sock = find_port "http server" !!http_bind_addr http_port    let sock = find_port "http server" !!http_bind_addr http_port
1335        (Http_server.handler config) in        (Http_server.handler config) in
1336    config.port <- !!http_port    config.port <- !!http_port
     

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.33

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26