/[mldonkey]/mldonkey/src/daemon/common/commonWeb.ml
ViewVC logotype

Diff of /mldonkey/src/daemon/common/commonWeb.ml

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

revision 1.14 by spiralvoice, Sun Jul 10 23:19:16 2005 UTC revision 1.15 by spiralvoice, Thu Jul 14 14:05:25 2005 UTC
# Line 19  Line 19 
19    
20  open Options  open Options
21  open Printf2  open Printf2
22      
23  open AnyEndian  open AnyEndian
24  open LittleEndian  open LittleEndian
25    
26  open BasicSocket    open BasicSocket
27  open TcpBufferedSocket  open TcpBufferedSocket
28      
29  open CommonGlobals  open CommonGlobals
30  open CommonOptions  open CommonOptions
31  open CommonTypes  open CommonTypes
32      
33  let days = ref 0        let days = ref 0
34  let hours = ref 0      let hours = ref 0
35    
36  (*************************************************************************)  (*************************************************************************)
37  (*                                                                       *)  (*                                                                       *)
38  (*                         load_url                                      *)  (*                         load_url                                      *)
39  (*                                                                       *)  (*                                                                       *)
40  (*************************************************************************)  (*************************************************************************)
41    
42  let file_kinds = ref []  let file_kinds = ref []
43    
44  let add_web_kind kind f =  let add_web_kind kind f =
45    file_kinds := (kind,f) :: !file_kinds    file_kinds := (kind,f) :: !file_kinds
46    
47  let mldonkey_wget url f =  let mldonkey_wget url f =
48    let module H = Http_client in    let module H = Http_client in
49    let r = {    let r = {
50        H.basic_request with        H.basic_request with
51        H.req_url = Url.of_string url;        H.req_url = Url.of_string url;
52        H.req_proxy = !CommonOptions.http_proxy;        H.req_proxy = !CommonOptions.http_proxy;
53        H.req_user_agent =        H.req_user_agent =
54        Printf.sprintf "MLdonkey/%s" Autoconf.current_version;        Printf.sprintf "MLdonkey/%s" Autoconf.current_version;
55      } in      } in
56      
57    H.wget r f      H.wget r f
58      
     
59  let load_url kind url =  let load_url kind url =
60    lprintf_nl "CommonWeb: QUERY URL %s" url;    lprintf_nl "CommonWeb: QUERY URL %s" url;
61    let f =    let f =
62      try      try
63        (List.assoc kind !file_kinds) url        (List.assoc kind !file_kinds) url
64      with e -> failwith (Printf.sprintf "Unknown kind [%s]" kind)      with e -> failwith (Printf.sprintf "Unknown kind [%s]" kind)
65    in    in
66    try    try
67      mldonkey_wget url f      mldonkey_wget url f
68    with e -> failwith (Printf.sprintf "Exception %s while loading %s"    with e -> failwith (Printf.sprintf "Exception %s while loading %s"
69            (Printexc2.to_string e) url)            (Printexc2.to_string e) url)
70      
71  let load_file kind file =  let load_file kind file =
72    try    try
73      (List.assoc kind !file_kinds) file file      (List.assoc kind !file_kinds) file file
74    with e ->    with e ->
75        lprintf_nl "Exception %s while loading kind %s"        lprintf_nl "Exception %s while loading kind %s"
76          (Printexc2.to_string e)          (Printexc2.to_string e)
77        kind        kind
78    
# Line 81  let load_file kind file = Line 80  let load_file kind file =
80  (*                                                                       *)  (*                                                                       *)
81  (*                         cut_messages (internal)                       *)  (*                         cut_messages (internal)                       *)
82  (*                                                                       *)  (*                                                                       *)
83  (*************************************************************************)  (*************************************************************************)
84      
85  let cut_messages f sock nread =  let cut_messages f sock nread =
86    let b = buf sock in    let b = buf sock in
87    try    try
# Line 98  let cut_messages f sock nread = Line 97  let cut_messages f sock nread =
97        else raise Not_found        else raise Not_found
98      done      done
99    with Not_found -> ()    with Not_found -> ()
100      
101    
102  (*************************************************************************)  (*************************************************************************)
103  (*                                                                       *)  (*                                                                       *)
104  (*                         add_redirector_info                           *)  (*                         add_redirector_info                           *)
105  (*                                                                       *)  (*                                                                       *)
106  (*************************************************************************)  (*************************************************************************)
107        
108  (* Learn how many people are using mldonkey at a current time, and which  (* Learn how many people are using mldonkey at a current time, and which
109  servers they are connected to --> build a database of servers  servers they are connected to --> build a database of servers
110    
111  Now, get some more information:  Now, get some more information:
# Line 114  Now, get some more information: Line 113  Now, get some more information:
113  - How much data is shared ?  - How much data is shared ?
114    
115  Note that the exact content/type/name of the files is not sent, nor  Note that the exact content/type/name of the files is not sent, nor
116  any private information. Just for statistics. Can be disabled in the  any private information. Just for statistics. Can be disabled in the
117    downloads.ini config file anyway.    downloads.ini config file anyway.
118  *)  *)
119  let buf = TcpBufferedSocket.internal_buf  let buf = TcpBufferedSocket.internal_buf
# Line 126  let buf_addr buf (ip,port) = Line 125  let buf_addr buf (ip,port) =
125  let buf_string buf s =  let buf_string buf s =
126    buf_int16 buf (String.length s);    buf_int16 buf (String.length s);
127    Buffer.add_string buf s    Buffer.add_string buf s
128      
129  let redirector_infos = ref []  let redirector_infos = ref []
130  let add_redirector_info (n : string) (f : Buffer.t -> unit) =  let add_redirector_info (n : string) (f : Buffer.t -> unit) =
131    redirector_infos := (n,f) :: !redirector_infos    redirector_infos := (n,f) :: !redirector_infos
132    
133  let gen_redirector_packet () =  let gen_redirector_packet () =
134      
135    let infos =    let infos =
136      List.map (fun (n,f) ->      List.map (fun (n,f) ->
137          n,          n,
138          ( Buffer.clear buf;          ( Buffer.clear buf;
139            f buf;            f buf;
140            Buffer.contents buf)            Buffer.contents buf)
141      ) !redirector_infos in      ) !redirector_infos in
142      
143    Buffer.clear buf;    Buffer.clear buf;
144    buf_int8 buf 212; (* udp_magic *)    buf_int8 buf 212; (* udp_magic *)
145    buf_int8 buf 2;   (* type of data sent *)    buf_int8 buf 2;   (* type of data sent *)
# Line 156  let gen_redirector_packet () = Line 155  let gen_redirector_packet () =
155    buf_int16 buf !!max_hard_download_rate;    buf_int16 buf !!max_hard_download_rate;
156    buf_int buf (compute_lost_byte upload_control);    buf_int buf (compute_lost_byte upload_control);
157    buf_int buf (compute_lost_byte download_control);    buf_int buf (compute_lost_byte download_control);
158      
159    buf_list (fun buf (n,s) ->    buf_list (fun buf (n,s) ->
160        buf_string buf n;        buf_string buf n;
161        buf_string buf s        buf_string buf s
162    ) buf infos;    ) buf infos;
163      
164    let s = Buffer.contents buf in        let s = Buffer.contents buf in
165    s    s
166    
167  (*************************************************************************)  (*************************************************************************)
# Line 203  support the charge, at least, currently. Line 202  support the charge, at least, currently.
202    let packet = gen_redirector_packet () in    let packet = gen_redirector_packet () in
203    Ip.async_ip name (fun ip ->    Ip.async_ip name (fun ip ->
204        try        try
205          if !verbose_redirector then lprintf "connecting to redirector\n";          if !verbose_redirector then lprintf_nl "connecting to redirector";
206          let token = create_token unlimited_connection_manager in          let token = create_token unlimited_connection_manager in
207          let sock = TcpBufferedSocket.connect token "connect redirector"          let sock = TcpBufferedSocket.connect token "connect redirector"
208              (Ip.to_inet_addr ip) port                          (Ip.to_inet_addr ip) port
209              (fun sock event ->              (fun sock event ->
210                match event with                match event with
211                | BASIC_EVENT (LTIMEOUT | RTIMEOUT) ->                | BASIC_EVENT (LTIMEOUT | RTIMEOUT) ->
212                    TcpBufferedSocket.close sock Closed_for_timeout                    TcpBufferedSocket.close sock Closed_for_timeout
213                | _ -> ())                | _ -> ())
214          in          in
215          TcpBufferedSocket.set_rtimeout sock 30.;          TcpBufferedSocket.set_rtimeout sock 30.;
216          let to_read = ref [] in          let to_read = ref [] in
217          set_reader sock (cut_messages (fun opcode s ->          set_reader sock (cut_messages (fun opcode s ->
218                if !verbose_redirector then lprintf "redirector info received\n";                if !verbose_redirector then lprintf_nl "redirector info received";
219                let module L = LittleEndian in                let module L = LittleEndian in
220    
221                let motd_html_s, pos = L.get_string16 s 2 in                let motd_html_s, pos = L.get_string16 s 2 in
222                let pos = if motd_html_s <> "XX" then                let pos = if motd_html_s <> "XX" then
223                    let servers_met_s, pos = L.get_string16 s pos in                    let servers_met_s, pos = L.get_string16 s pos in
224                    let peers_ocl_s, pos = L.get_string16 s pos in                    let peers_ocl_s, pos = L.get_string16 s pos in
225                    let peers_dat_s, pos = L.get_string16 s pos in                    let peers_dat_s, pos = L.get_string16 s pos in
# Line 231  support the charge, at least, currently. Line 230  support the charge, at least, currently.
230    
231                    let servers_met_file = Filename.temp_file "servers" ".met" in                    let servers_met_file = Filename.temp_file "servers" ".met" in
232                    File.from_string servers_met_file servers_met_s;                    File.from_string servers_met_file servers_met_s;
233                      if !!enable_donkey then
234                    load_file "servers.met" servers_met_file;                    load_file "servers.met" servers_met_file;
235    
236                    let peers_ocl_file = Filename.temp_file "peers" ".ocl" in                    let peers_ocl_file = Filename.temp_file "peers" ".ocl" in
237                    File.from_string peers_ocl_file peers_ocl_s;                    File.from_string peers_ocl_file peers_ocl_s;
238                      if !!enable_overnet then
239                    load_file "ocl" peers_ocl_file;                    load_file "ocl" peers_ocl_file;
240    
241                    let peers_dat_file = Filename.temp_file "contacts" ".dat" in                    let peers_dat_file = Filename.temp_file "contacts" ".dat" in
242                    File.from_string peers_dat_file peers_dat_s;                    File.from_string peers_dat_file peers_dat_s;
243                      if !!enable_overnet then
244                    load_file "contact.dat" peers_dat_file;                    load_file "contact.dat" peers_dat_file;
245    
246                    let motd_conf_file = Filename.temp_file "motd" ".conf" in                    let motd_conf_file = Filename.temp_file "motd" ".conf" in
# Line 247  support the charge, at least, currently. Line 249  support the charge, at least, currently.
249    
250                    let peers_kad_file = Filename.temp_file "peers" ".kad" in                    let peers_kad_file = Filename.temp_file "peers" ".kad" in
251                    File.from_string peers_kad_file peers_kad_s;                    File.from_string peers_kad_file peers_kad_s;
252                      if !!enable_kademlia then
253                    load_file "kad" peers_kad_file;                    load_file "kad" peers_kad_file;
254    
255                    pos                    pos
# Line 275  support the charge, at least, currently. Line 278  support the charge, at least, currently.
278            ));            ));
279          write_string sock packet          write_string sock packet
280    
281        with e ->        with e ->
282            lprintf "Exception %s while connecting redirector\n"            lprintf "Exception %s while connecting redirector\n"
283              (Printexc2.to_string e)              (Printexc2.to_string e)
284    );    );
# Line 285  support the charge, at least, currently. Line 288  support the charge, at least, currently.
288      load_url "motd.conf" (Filename.concat !!network_update_url "motd.conf");      load_url "motd.conf" (Filename.concat !!network_update_url "motd.conf");
289    end;    end;
290    List.iter (fun (kind, period, url) ->    List.iter (fun (kind, period, url) ->
291        if !days mod period = 0 then load_url kind url        if !days mod period = 0 then
292    ) !!CommonOptions.web_infos          match kind with
293            | "contact.dat" -> if !!enable_overnet then load_url kind url
294            | "guarding.p2p" -> load_url kind url
295            | "kad" -> if !!enable_kademlia then load_url kind url
296            | "ocl" -> if !!enable_overnet then load_url kind url
297            | "server.met" -> if !!enable_donkey then load_url kind url
298            | _ -> lprintf_nl "unparsed kind to refresh: %s" kind; load_url kind url
299                ) !!CommonOptions.web_infos
300    
301  type rss_feed = {  type rss_feed = {
302      mutable rss_date : int;      mutable rss_date : int;
303      mutable rss_value : Rss.channel;      mutable rss_value : Rss.channel;
304    }    }
305        
306  let rss_feeds = Hashtbl.create 10  let rss_feeds = Hashtbl.create 10
307    
308    
309  let _ =  let _ =
310    add_web_kind "rss" (fun url filename ->    add_web_kind "rss" (fun url filename ->
311        let c = Rss.channel_of_file filename in        let c = Rss.channel_of_file filename in
312        let feed =        let feed =
313          try Hashtbl.find rss_feeds url with          try Hashtbl.find rss_feeds url with
314            Not_found ->            Not_found ->
315              let feed = {              let feed = {
# Line 320  let udp_latencies_block = ref "" Line 330  let udp_latencies_block = ref ""
330  let _ =  let _ =
331  (* Latency block *)  (* Latency block *)
332    add_redirector_info "LTCY" (fun buf ->    add_redirector_info "LTCY" (fun buf ->
333          
334        if not !initialized then begin        if not !initialized then begin
335            tcp_latencies_block := TcpBufferedSocket.get_latencies verbose_redirector;            tcp_latencies_block := TcpBufferedSocket.get_latencies verbose_redirector;
336            udp_latencies_block := UdpSocket.get_latencies verbose_redirector;            udp_latencies_block := UdpSocket.get_latencies verbose_redirector;
# Line 341  let _ = Line 351  let _ =
351        tcp_latencies_block := TcpBufferedSocket.get_latencies verbose_redirector;        tcp_latencies_block := TcpBufferedSocket.get_latencies verbose_redirector;
352        udp_latencies_block := UdpSocket.get_latencies verbose_redirector;        udp_latencies_block := UdpSocket.get_latencies verbose_redirector;
353    )    )
   

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

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