1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
3 This file is part of mldonkey.
5 mldonkey is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 mldonkey is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with mldonkey; if not, write to the Free Software
17 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
27 open TcpBufferedSocket
29 let filename = "observer.dat"
31 let motd_html = ref (try File.to_string
"motd.html" with _
-> "")
32 let servers_met = ref (try File.to_string
"servers.met" with _
-> "")
33 let overnet_peers_ocl = ref (try File.to_string
"overnet_peers.ocl" with _
-> "")
34 let kademlia_peers_ocl = ref (try File.to_string
"kademlia_peers.ocl" with _
-> "")
35 let motd_conf = ref (try File.to_string
"motd.conf" with _
-> "")
37 let redirector_info = ref ""
39 let update_redirector_info () =
40 let buf = Buffer.create
1000 in
43 buf_string16
buf !motd_html;
44 buf_string16
buf !servers_met;
45 buf_string16
buf !overnet_peers_ocl;
46 buf_string16
buf !motd_conf;
47 buf_string16
buf !kademlia_peers_ocl;
48 let s = Buffer.contents
buf in
49 (* the len should be (String.length s - 4), but since the IP address (4 bytes)
50 is added at the end, it is (String.length s) *)
51 let len = String.length
s in
52 LittleEndian.str_int
s 0 len;
55 let bin_oc = open_out_gen
[Open_append
; Open_creat
; Open_binary
;
56 Open_wronly
] 0o644
filename
58 let observer_buf = Buffer.create
70000
60 let dump_record t
s ip
=
61 let buf = observer_buf in
66 let m = Buffer.contents
buf in
67 output_string
bin_oc m;
71 let s = String.create
100 in
72 really_input ic
s 0 10;
73 let t = get_int64
s 0 in
74 let ip = get_ip
s 4 in
75 let len = get_int16
s 8 in
76 let s = String.create
len in
77 really_input ic
s 0 len;
90 record
[nrecords
]: servers
102 objects_fifo
: key
Fifo.t;
104 objects_table
: (key
, key
) Hashtbl.t;
107 let create max_objects
= {
108 objects_fifo
= Fifo.create ();
109 max_objects
= max_objects
;
110 objects_table
= Hashtbl.create 127;
114 let (ip, port
) = key
in
115 if Ip.valid
ip && ip <> Ip.localhost
&& Ip.reachable
ip &&
116 not
(Hashtbl.mem
t.objects_table key
) then
118 Hashtbl.add t.objects_table key key
;
119 Fifo.put
t.objects_fifo key
;
120 if Fifo.length
t.objects_fifo
= t.max_objects
then
121 let key = Fifo.take
t.objects_fifo
in
122 Hashtbl.remove
t.objects_table
key
126 Fifo.to_list t.objects_fifo
130 let new_servers = T.create 200
131 let new_overnet_peers = T.create 1000
132 let new_kademlia_peers = T.create 1000
135 let print_record t ip_firewall
s =
137 let ip = get_ip
s 1 in
138 let t = Int64.to_float
t in
140 let t = localtime
t in
141 lprintf
"At %02d:%02d:%02d\n"
146 let opcode = int_of_char
s.[0] in
149 let ips, pos
= get_list get_peer
s 5 in
150 let version, uptime
, shared
, uploaded
, pos
=
152 let version, pos
= get_string
s pos
in
153 let uptime = get_int
s pos
in
154 let shared = get_int64
s (pos
+4) in
155 let uploaded = get_int64
s (pos
+12) in
157 version, uptime, shared, uploaded, pos
+20
162 "unknown", 0, Int64.zero
, Int64.zero
, pos
166 lprintf
"Version: %s, uptime: %02d:%02d, shared: %Ld, uploaded: %Ld\n"
167 version (uptime / 3600) ((uptime/60) mod 60) shared uploaded;
168 List.iter
(fun (ip, port
) ->
169 T.add new_servers (ip, port
);
170 lprintf
" Connected to %s:%d\n"
171 (Ip.to_string
ip) port
;
175 let npeers = get_int
s pos
in
176 lprintf
"Overnet peers: %d\n" npeers;
177 for i
= 0 to npeers - 1 do
178 let ip = get_ip
s (pos
+4+i
*6) in
179 let port = get_int16
s (pos
+6+i
*6) in
180 T.add new_overnet_peers (ip, port);
181 lprintf
" Overnet Peer %s:%d\n"
182 (Ip.to_string
ip) port;
192 lprintf
"MLdonkey on %s (through %s):\n"
194 (Ip.to_string ip_firewall
)
198 let version, pos = get_string
s pos in
199 let uptime = get_int
s pos in
200 let shared = get_int64
s (pos+4) in
201 let uploaded = get_int64
s (pos+12) in
202 let pos = pos + 20 in
204 lprintf
"Version: %s, uptime: %02d:%02d, shared: %Ld, uploaded: %Ld\n"
205 version (uptime / 3600) ((uptime/60) mod 60) shared uploaded;
207 let upload_rate = get_int16
s pos in
208 let download_rate = get_int16
s (pos+2) in
209 lprintf
" upload: %d download: %d\n" upload_rate download_rate;
210 let lost_upload = get_int
s (pos+4) in
211 let load_download = get_int
s (pos+8) in
215 get_list (fun s pos ->
216 let n = get_uint8 s pos in
217 let s, pos = get_string s (pos+4) in
223 let ips, pos = get_list (fun s pos ->
224 (get_ip s pos, get_int16 s (pos+4)), pos
227 List.iter (fun (ip, port) ->
228 new_servers := (ip, port) :: !new_servers;
229 lprintf " Connected to %s:%d\n"
230 (Ip.to_string ip) port;
235 let npeers = get_int s pos in
236 lprintf "Overnet peers: %d\n" npeers;
237 for i = 0 to npeers - 1 do
238 let ip = get_ip s (pos+4+i*6) in
239 let port = get_int16 s (pos+6+i*6) in
240 new_peers := (ip, port) :: !new_peers;
241 lprintf " Overnet Peer %s:%d\n"
242 (Ip.to_string ip) port;
245 lprintf "Unknown fragment %d\n" n
255 lprintf
"MLdonkey on %s (through %s):\n"
256 (Ip.to_string
ip) (Ip.to_string ip_firewall
);
259 let version, pos = get_string
s pos in
260 let uptime = get_int
s pos in
262 let max_upload_rate = get_int16
s (pos+4) in
263 let max_download_rate = get_int16
s (pos+6) in
264 let upload_lost = get_int
s (pos+8) in
265 let download_lost = get_int
s (pos+12) in
266 let pos = pos + 16 in
269 lprintf
"Version: %s, uptime: %02d:%02d\n"
270 version (uptime / 3600) ((uptime/60) mod 60);
271 lprintf
" upload: %d download: %d\n"
272 max_upload_rate max_download_rate;
273 lprintf
" upload lost: %d download lost: %d\n"
274 upload_lost download_lost;
276 let list,pos = get_list
(fun s pos ->
277 let n, pos = get_string
s pos in
278 let s, pos = get_string
s pos in
283 List.iter
(fun (n,s) ->
287 let servers, pos = get_list
(fun s pos ->
288 let ip = get_ip
s pos in
289 let port = get_port
s (pos+4) in
295 List.iter
(fun (ip, port) ->
296 T.add new_servers (ip, port);
297 lprintf
" Connected to %s:%d\n"
298 (Ip.to_string
ip) port;
302 let servers, pos = get_list
(fun s pos ->
303 let ip = get_ip
s pos in
304 let port = get_port
s (pos+4) in
310 List.iter
(fun (ip, port) ->
311 T.add new_overnet_peers (ip, port);
312 lprintf
" Overnet peer %s:%d\n"
313 (Ip.to_string
ip) port;
317 let servers, pos = get_list
(fun s pos ->
318 let ip = get_ip
s pos in
319 let port = get_port
s (pos+4) in
325 List.iter
(fun (ip, port) ->
326 T.add new_kademlia_peers (ip, port);
327 lprintf
" Kademlia peer %s:%d\n"
328 (Ip.to_string
ip) port;
333 let servers, pos = get_list
(fun s pos ->
334 let ip = get_ip
s pos in
335 let port = get_port
s (pos+4) in
341 List.iter
(fun (ip, port) ->
342 T.add new_overnet_peers (ip, port);
343 lprintf
" Overnet peer %s:%d\n"
344 (Ip.to_string
ip) port;
348 let servers, pos = get_list
(fun s pos ->
349 let ip = get_ip
s pos in
350 let udp_port = get_port
s (pos+4) in
351 let tcp_port = get_port
s (pos+6) in
352 (ip, udp_port, tcp_port), pos+8
356 List.iter
(fun (ip, udp_port, tcp_port) ->
357 T.add new_kademlia_peers (ip, udp_port);
358 lprintf
" Kademlia peer %s:%d %d\n"
359 (Ip.to_string
ip) udp_port tcp_port;
364 let len = get_int
s 0 in
365 let ngood_propositions = Array.create len zero
in
366 let nbad_propositions = Array.create len zero
in
368 for i
= 0 to len - 1 do
369 ngood_propositions.(i
) <- get_int64
s (pos+i
*16);
370 nbad_propositions.(i
) <- get_int64
s (pos+8+i
*16);
372 let pos = pos + len * 16 in
373 let waiting = get_int
s pos in
374 let neighbours = get_int
s (pos+4) in
377 for i
= 0 to len - 1 do
378 lprintf
" Good[%d] = %Ld\n" i
ngood_propositions.(i
);
379 lprintf
" Bad[%d] = %Ld\n" i
nbad_propositions.(i
);
381 lprintf
" Waiting propositions: %d\n" waiting;
382 lprintf
" Total neighbours: %d\n" neighbours
385 let total_shared = get_int64
s 0 in
386 let total_uploaded = get_int64
s 8 in
388 lprintf
" SHARED:\n";
389 lprintf
" Shared: %Ld, uploaded: %Ld\n"
390 total_shared total_uploaded;
393 let loop_delay = get_int
s 0 in
396 let ntcp = get_int
s pos in
397 for i
= 0 to ntcp - 1 do
398 let ip = get_ip
s (pos+4+8*i
) in
399 let latency = get_int16
s (pos+8+8*i
) in
400 let samples = get_int16
s (pos+10+8*i
) in
401 lprintf
"TCP %d %s %s %d \n"
403 (Ip.to_string ip_firewall
)
404 (Ip.to_string
ip) latency
407 let pos = pos + 4+ 8 * ntcp in
408 let nudp = get_int
s pos in
409 for i
= 0 to nudp - 1 do
410 let ip = get_ip
s (pos+4+8*i
) in
411 let latency = get_int16
s (pos+8+8*i
) in
412 let samples = get_int16
s (pos+10+8*i
) in
413 lprintf
"UDP %d %s %s %d\n" samples
414 (Ip.to_string ip_firewall
)
415 (Ip.to_string
ip) latency
418 | _ -> lprintf
" Unknown kind of info: %s\n" n;
420 lprintf
" Exception %s while parsing info\n"
421 (Printexc2.to_string e
)
426 lprintf
"Unknown format\n";
434 mutable client_buf
: Buffer.t;
435 mutable client_ok
: bool;
438 let read_client_info c sock nread
=
443 if nread
> 0 && c
.client_ok
then begin
444 Buffer.add_string c
.client_buf
(String.sub
buf pos len);
446 let l = Buffer.length c
.client_buf
in
447 if l > 10000 then begin
448 c
.client_ok
<- false;
449 lprintf
"CLIENT NOT OK\n";
450 close sock Closed_by_user
457 match get_uint8 buf pos with
459 match get_uint8 buf (pos+1) with
464 lprintf "Bad version for connection from %s:%d: %d\n"
465 (Ip.to_string c.client_ip) c.client_port version;
470 lprintf "Bad magic for connection from %s:%d: %d\n"
471 (Ip.to_string c.client_ip) c.client_port magic;
474 (* not enough data *) ()
479 let create_observer port =
480 let sock = UdpSocket.create Unix.inet_addr_any
port
481 (DonkeyProtoCom.udp_basic_handler
(fun s p
->
483 match p
.UdpSocket.udp_addr
with
484 Unix.ADDR_INET
(ip, port) -> Ip.of_inet_addr
ip
488 let t = gettimeofday
() in
489 let t = Int64.of_float
t in
491 dump_record t s ip_firewall;
493 print_record t ip_firewall s
496 let sock = TcpServerSocket.create
502 TcpServerSocket.CONNECTION
(s, Unix.ADDR_INET
(from_ip
, from_port
)) ->
505 client_ip
= Ip.of_inet_addr from_ip
;
506 client_port
= from_port
;
507 client_buf
= Buffer.create 100;
511 let token = TcpBufferedSocket.create_token
TcpBufferedSocket.unlimited_connection_manager
in
512 let sock = TcpBufferedSocket.create token "observer connection" s
515 BASIC_EVENT
(LTIMEOUT
| RTIMEOUT
) ->
516 close
sock Closed_for_timeout
517 | BASIC_EVENT
(CLOSED
_) ->
518 lprintf
"INFO SENT TO %s:%d\n"
519 (Ip.to_string
c.client_ip
) c.client_port
;
520 let s = Buffer.contents
c.client_buf
in
521 let len = String.length
s in
523 let s = String.sub
s 1 (len-1) in
524 let ip_firewall = c.client_ip
in
526 let t = gettimeofday
() in
527 let t = Int64.of_float
t in
529 dump_record t s ip_firewall;
530 print_record t ip_firewall s
534 set_reader
sock (read_client_info c);
535 set_lifetime
sock 300.;
536 set_rtimeout
sock 30.;
537 let b = Buffer.create 100 in
538 Buffer.add_string
b !redirector_info;
539 buf_ip
b (peer_ip
sock);
540 let s = Buffer.contents
b in
541 let len = String.length
s in
542 (* lprintf "Sending %d bytes\n" len; *)
543 set_max_output_buffer
sock (len + 100);
549 let iter_file f g h
=
550 let ic = open_in
filename in
554 let (t, ip, s) = read_record ic in
564 let print_ascii () = iter_file no print_record no
566 let count_records () =
567 let first_record = ref None
in
568 let last_record = ref None
in
569 let counter = ref 0 in
570 let clients = Hashtbl.create 100 in
571 let servers = Hashtbl.create 1000 in
572 let server_counter = ref 0 in
573 iter_file no (fun t ip_firewall s ->
575 match !first_record with
576 None
-> first_record := Some
t
579 last_record := Some
t;
580 let ip = get_ip
s 1 in
581 let ips, pos = get_list get_peer
s 5 in
584 if not
(Hashtbl.mem
clients (ip, ip_firewall)) then
586 Hashtbl.add clients (ip, ip_firewall) ips;
590 if not
(Hashtbl.mem
servers s) then
592 Hashtbl.add servers s ();
597 lprintf
"%d MLdonkey clients" !counter;
598 (match !first_record, !last_record with
600 lprintf
" in %3.0Ld seconds" (Int64.sub t2 t1
)
602 lprintf
" on %d servers\n" !server_counter;
606 let servers_age = ref 60
607 let peers_age = ref 2
610 "-ascii", Arg.Unit
print_ascii, "";
611 "-count", Arg.Unit
count_records, "";
612 "-server_age", Arg.Int
((:=) servers_age), " <int> : max server age (minutes) in servers.met";
613 "-peer_age", Arg.Int
((:=) peers_age), " <int> : max server age (minutes) in servers.met";
618 let dump_list new_hosts adder dumper
=
620 (* lprintf "dump server list\n"; *)
621 dumper
(List2.tail_map adder
(T.to_list new_hosts
));
623 lprintf
"error: %s\n" (Printexc2.to_string e
)
625 let dump_servers_list _ =
626 let module S
= DonkeyImport.Server
in
627 (try motd_html := File.to_string
"motd.html" with _ -> ());
628 (try motd_conf := File.to_string
"motd.conf" with _ -> ());
629 update_redirector_info ();
630 dump_list new_servers
632 { S.ip = ip; S.port = port; S.tags
= []; };)
634 let list,_ = List2.cut
500 list in
635 let buf = Buffer.create 100 in
637 servers_met := (Buffer.contents
buf);
638 File.from_string
"servers.met" !servers_met;
639 update_redirector_info ();
640 (* now, what is the command to send the file to the WEB server ??? *)
643 (Sys.command "scp -B -q servers.met simon_mld@subversions.gnu.org:/upload/mldonkey/network/"); *)
646 let dump_peers_list _ =
647 let store new_peers peers_ocl peers_file
=
651 let buf = Buffer.create 100 in
652 List.iter
(fun (ip, port) ->
653 Printf.bprintf
buf "%s,%d,X\n" (Ip.to_string
ip) port;
655 peers_ocl
:= (Buffer.contents
buf);
656 File.from_string peers_file
!peers_ocl
;
659 store new_overnet_peers
660 overnet_peers_ocl "overnet_peers.ocl";
661 store new_kademlia_peers
662 kademlia_peers_ocl "kademlia_peers.ocl";
663 update_redirector_info ()
667 update_redirector_info ();
668 ignore
(create_observer 3999);
669 ignore
(create_observer 4665)
673 let module S
= DonkeyImport.Server
in
675 let file = File.to_string
"servers.met" in
677 T.add new_servers (s.S.ip , s.S.port)
679 with _ -> lprintf
"Could not load old server list\n";
681 MlUnix.set_signal
Sys.sigpipe
(*Sys.Signal_ignore*)
682 (Sys.Signal_handle
(fun _ -> lprintf
"SIGPIPE\n"));
683 BasicSocket.add_timer
30. dump_servers_list;
684 BasicSocket.add_timer
30. dump_peers_list;
685 BasicSocket.add_infinite_timer
300. dump_servers_list;
686 BasicSocket.add_infinite_timer
300. dump_peers_list;
687 lprintf
"Observer started\n";