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

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

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

revision 1.18 by spiralvoice, Fri Jul 22 10:58:55 2005 UTC revision 1.19 by spiralvoice, Mon Aug 8 18:20:43 2005 UTC
# Line 24  open CommonNetwork Line 24  open CommonNetwork
24  open Options  open Options
25  open CommonUser  open CommonUser
26  open CommonTypes  open CommonTypes
27      
28    module G = GuiTypes
29    
30  type 'a server_impl = {  type 'a server_impl = {
31      mutable impl_server_update : int;      mutable impl_server_update : int;
32      mutable impl_server_state : CommonTypes.host_state;      mutable impl_server_state : CommonTypes.host_state;
# Line 50  and 'a server_ops = { Line 52  and 'a server_ops = {
52      mutable op_server_rename : ('a -> string -> unit);      mutable op_server_rename : ('a -> string -> unit);
53    }    }
54    
55  let ni n m =  let ni n m =
56    let s = Printf.sprintf "Server.%s not implemented by %s"    let s = Printf.sprintf "Server.%s not implemented by %s"
57        m n.network_name in        m n.network_name in
58    lprintf_nl "%s" s;    lprintf_nl "%s" s;
59    s    s
60      
61  let fni n m =  failwith (ni n m)  let fni n m =  failwith (ni n m)
62  let ni_ok n m = ignore (ni n m)  let ni_ok n m = ignore (ni n m)
63      
     
64  let as_server  (server : 'a server_impl) =  let as_server  (server : 'a server_impl) =
65    let (server : server) = Obj.magic server in    let (server : server) = Obj.magic server in
66    server    server
# Line 68  let as_server_impl  (server : server) = Line 69  let as_server_impl  (server : server) =
69    let (server : 'a server_impl) = Obj.magic server in    let (server : 'a server_impl) = Obj.magic server in
70    server    server
71    
72        let dummy_server_impl = {
 let  dummy_server_impl = {  
73      impl_server_update = 1;      impl_server_update = 1;
74      impl_server_state = NewHost;      impl_server_state = NewHost;
75      impl_server_num = 0;      impl_server_num = 0;
# Line 84  let dummy_server = as_server dummy_serve Line 84  let dummy_server = as_server dummy_serve
84  let server_num s =  let server_num s =
85    let s = as_server_impl s in    let s = as_server_impl s in
86    s.impl_server_num    s.impl_server_num
87      
88  module H = Weak2.Make(struct  module H = Weak2.Make(struct
89        type t = server        type t = server
90        let hash s = Hashtbl.hash (server_num s)        let hash s = Hashtbl.hash (server_num s)
91          
92        let equal x y =        let equal x y =
93          (server_num x) = (server_num y)          (server_num x) = (server_num y)
94      end)      end)
95    
96  let server_counter = ref 0  let server_counter = ref 0
97  let servers_by_num = H.create 1027  let servers_by_num = H.create 1027
98      
99  let _ =  let _ =
100    Heap.add_memstat "CommonServer" (fun level buf ->    Heap.add_memstat "CommonServer" (fun level buf ->
101        let counter = ref 0 in        let counter = ref 0 in
102        H.iter (fun _ -> incr counter) servers_by_num;        H.iter (fun _ -> incr counter) servers_by_num;
# Line 109  let server_must_update s = Line 109  let server_must_update s =
109    if impl.impl_server_update <> 0 then    if impl.impl_server_update <> 0 then
110      CommonEvent.add_event (Server_info_event s);      CommonEvent.add_event (Server_info_event s);
111    impl.impl_server_update <- 0    impl.impl_server_update <- 0
112      
113  let server_must_update_state s =  let server_must_update_state s =
114    let impl = as_server_impl s in    let impl = as_server_impl s in
115    if impl.impl_server_update > 0 then    if impl.impl_server_update > 0 then
# Line 119  let server_must_update_state s = Line 119  let server_must_update_state s =
119  (*      lprintf "server_must_update YES\n";  *)  (*      lprintf "server_must_update YES\n";  *)
120      end      end
121    
   
       
122  let server_update_num impl =  let server_update_num impl =
123    let server = as_server impl in    let server = as_server impl in
124    incr server_counter;    incr server_counter;
# Line 186  let new_server_ops network = Line 184  let new_server_ops network =
184    servers_ops := (ss, { ss with op_server_network = s.op_server_network })    servers_ops := (ss, { ss with op_server_network = s.op_server_network })
185    :: ! servers_ops;    :: ! servers_ops;
186    s    s
     
187    
188  let check_server_implementations () =  let check_server_implementations () =
189    lprintf_nl "\n----- Methods not implemented for CommonServer ----\n";    lprintf_nl "\n----- Methods not implemented for CommonServer ----\n";
190    List.iter (fun (c, cc) ->    List.iter (fun (c, cc) ->
191        let n = c.op_server_network.network_name in        let n = c.op_server_network.network_name in
192        lprintf_nl "\n  Network %s\n" n;        lprintf_nl "\n  Network %s\n" n;
193        if c.op_server_remove == cc.op_server_remove then        if c.op_server_remove == cc.op_server_remove then
194          lprintf_nl "op_server_remove";          lprintf_nl "op_server_remove";
195        if c.op_server_to_option == cc.op_server_to_option then        if c.op_server_to_option == cc.op_server_to_option then
196          lprintf_nl "op_server_to_option";          lprintf_nl "op_server_to_option";
# Line 220  let check_server_implementations () = Line 217  let check_server_implementations () =
217    ) !servers_ops;    ) !servers_ops;
218    lprint_newline ()    lprint_newline ()
219    
220  let server_find (num : int) =  let server_find (num : int) =
221    H.find servers_by_num  (as_server { dummy_server_impl with    H.find servers_by_num  (as_server { dummy_server_impl with
222        impl_server_num = num })        impl_server_num = num })
223      
224    let server_blocked s =
225      let info = server_info s in
226        Ip_set.ip_blocked (Ip.ip_of_addr info.G.server_addr)
227    
228  let server_connect s =  let server_connect s =
229      if not (server_blocked s) then
230    let server = as_server_impl s in    let server = as_server_impl s in
231    server.impl_server_ops.op_server_connect server.impl_server_val    server.impl_server_ops.op_server_connect server.impl_server_val
232      
233  let server_disconnect s =  let server_disconnect s =
234    let server = as_server_impl s in    let server = as_server_impl s in
235    server.impl_server_ops.op_server_disconnect server.impl_server_val    server.impl_server_ops.op_server_disconnect server.impl_server_val
236    
   
237  let server_state c =  let server_state c =
238    let impl = as_server_impl c in    let impl = as_server_impl c in
239    impl.impl_server_state    impl.impl_server_state
# Line 240  let server_state c = Line 241  let server_state c =
241  let server_num c =  let server_num c =
242    let impl = as_server_impl c in    let impl = as_server_impl c in
243    impl.impl_server_num    impl.impl_server_num
244      
245  let set_server_state c state =  let set_server_state c state =
246    let impl = as_server_impl c in    let impl = as_server_impl c in
247    if impl.impl_server_state <> state then begin    if impl.impl_server_state <> state then begin
# Line 248  let set_server_state c state = Line 249  let set_server_state c state =
249        server_must_update_state c        server_must_update_state c
250      end      end
251    
252  let server_sort () =  let server_sort () =
253    let list = ref [] in    let list = ref [] in
254    H.iter (fun s ->    H.iter (fun s ->
255        let impl = as_server_impl s in        let impl = as_server_impl s in
# Line 256  let server_sort () = Line 257  let server_sort () =
257          RemovedHost -> ()          RemovedHost -> ()
258        | _ ->        | _ ->
259            list := s :: !list;            list := s :: !list;
260            impl.impl_server_sort <-            impl.impl_server_sort <-
261              (try impl.impl_server_ops.op_server_sort impl.impl_server_val              (try impl.impl_server_ops.op_server_sort impl.impl_server_val
262              with _ -> 0);              with _ -> 0);
263    ) servers_by_num;    ) servers_by_num;
264    Sort.list (fun s1 s2 ->    Sort.list (fun s1 s2 ->
265        (as_server_impl s1).impl_server_sort >= (as_server_impl s2).impl_server_sort        (as_server_impl s1).impl_server_sort >= (as_server_impl s2).impl_server_sort
266    ) !list    ) !list
267    
268  let server_iter f =  let server_iter f =
269    H.iter f servers_by_num    H.iter f servers_by_num
270      
271      let com_servers_by_num = servers_by_num
272  let com_servers_by_num = servers_by_num    
     
273  let server_new_user server user =  let server_new_user server user =
274    user_must_update user;    user_must_update user;
275    CommonEvent.add_event (Server_new_user_event (server, user))    CommonEvent.add_event (Server_new_user_event (server, user))
# Line 279  let servers_get_all () = Line 279  let servers_get_all () =
279    H.iter (fun c ->    H.iter (fun c ->
280        list := (server_num c) :: !list) servers_by_num;        list := (server_num c) :: !list) servers_by_num;
281    !list    !list
282      
283  let servers_by_num = ()  let servers_by_num = ()
284      
285        (*
 (*    
286  type server_info = {  type server_info = {
287      server_num : int;      server_num : int;
288      server_network : int;      server_network : int;
289        
290      mutable server_ip : Ip.t;      mutable server_ip : Ip.t;
291      mutable server_port : int;      mutable server_port : int;
292      mutable server_score : int;      mutable server_score : int;
# Line 298  type server_info = { Line 297  type server_info = {
297      mutable server_name : string;      mutable server_name : string;
298      mutable server_description : string;      mutable server_description : string;
299      mutable server_users : int list option;      mutable server_users : int list option;
300    }    }
301      *)      *)
302    
 module G = GuiTypes  
303    
304  let server_banner s o =  let server_banner s o =
305    let buf = o.conn_buf in    let buf = o.conn_buf in
306    let info = server_info s in    let info = server_info s in
307    Printf.bprintf buf "%s"    Printf.bprintf buf "%s"
308        info.G.server_banner        info.G.server_banner
309    
310  let server_print_html_header buf ext =  let server_print_html_header buf ext =
311      html_mods_table_header buf "serversTable" (Printf.sprintf "servers%s" ext) [      html_mods_table_header buf "serversTable" (Printf.sprintf "servers%s" ext) [
312                  ( "1", "srh", "Server number", "#" ) ;                  ( "1", "srh", "Server number", "#" ) ;
313                  ( "0", "srh", "Connect|Disconnect", "C/D" ) ;                  ( "0", "srh", "Connect|Disconnect", "C/D" ) ;
314                  ( "0", "srh", "Remove", "Rem" ) ;                  ( "0", "srh", "Remove", "Rem" ) ;
315      ( "0", "srh", "Preferred", "P" ) ;      ( "0", "srh", "Preferred", "P" ) ;
316                  ( "0", "srh", "[Hi]gh or [Lo]w ID", "ID" ) ;                  ( "0", "srh", "[Hi]gh or [Lo]w ID", "ID" ) ;
317                  ( "0", "srh", "Network name", "Network" ) ;                  ( "0", "srh", "Network name", "Network" ) ;
318                  ( "0", "srh", "Connection status", "Status" ) ;                  ( "0", "srh", "Connection status", "Status" ) ;
319                  ( "0", "srh br", "IP address", "IP address" ) ;                  ( "0", "srh br", "IP address", "IP address" ) ;
320                  ( "1", "srh ar", "Number of connected users", "Users" ) ;                  ( "1", "srh ar", "Number of connected users", "Users" ) ;
321                  ( "1", "srh ar br", "Number of files indexed on server", "Files" ) ;                  ( "1", "srh ar br", "Number of files indexed on server", "Files" ) ;
322                  ( "0", "srh", "Server name", "Name" ) ;                  ( "0", "srh", "Server name", "Name" ) ;
323                  ( "0", "srh", "Server details", "Details" ) ]                    ( "0", "srh", "Server details", "Details" ) ]
324      
325  let server_print s o =  let server_print s o =
326    let impl = as_server_impl s in    let impl = as_server_impl s in
327    let n = impl.impl_server_ops.op_server_network in    let n = impl.impl_server_ops.op_server_network in
328    try    try
329      let info =      let info =
330        try server_info s with e ->        try server_info s with e ->
331            lprintf "Exception %s in server_info (%s)\n"            lprintf "Exception %s in server_info (%s)\n"
332              (Printexc2.to_string e) n.network_name;              (Printexc2.to_string e) n.network_name;
333            raise e in            raise e in
334    
335      let buf = o.conn_buf in      let buf = o.conn_buf in
336                    
337          if use_html_mods o then begin          if use_html_mods o then begin
# Line 356  let server_print s o = Line 355  let server_print s o =
355            (            (
356          Printf.sprintf "%s"          Printf.sprintf "%s"
357          (match impl.impl_server_state with          (match impl.impl_server_state with
358          Connected _ -> Printf.sprintf "title=\\\"Server Banner\\\"          Connected _ -> Printf.sprintf "title=\\\"Server Banner\\\"
359                                                  onMouseOver=\\\"mOvr(this);\\\"                                                  onMouseOver=\\\"mOvr(this);\\\"
360                                                  onMouseOut=\\\"mOut(this);\\\"                                                  onMouseOut=\\\"mOut(this);\\\"
361                                                  onClick=\\\"location.href='submit?q=server_banner+%d'\\\"" snum                                                  onClick=\\\"location.href='submit?q=server_banner+%d'\\\"" snum
362          | _ -> "")          | _ -> "")
363            )            )
364            snum            snum
365        (        (if server_blocked s then
366            Printf.sprintf "\\<TD class=\\\"srb\\\"----\\</TD\\>"
367           else
368          Printf.sprintf          Printf.sprintf
369          "\\<TD class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"          "\\<TD class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
370          onMouseOut=\\\"mOut(this);\\\" title=\\\"Connect|Disconnect\\\"          onMouseOut=\\\"mOut(this);\\\" title=\\\"Connect|Disconnect\\\"
# Line 433  let server_print s o = Line 434  let server_print s o =
434           end           end
435         else "\\>"         else "\\>"
436        )        )
         
437        n.network_name        n.network_name
438     (string_of_connection_state impl.impl_server_state)        (if server_blocked s then
439        (Ip.string_of_addr info.G.server_addr)          "IP blocked"
440          else
441            (string_of_connection_state impl.impl_server_state))
442          (Ip.string_of_addr info.G.server_addr)
443        (Printf.sprintf "%s%s"        (Printf.sprintf "%s%s"
444         (string_of_int info.G.server_port)         (string_of_int info.G.server_port)
445         (if info.G.server_realport <> 0 then         (if info.G.server_realport <> 0 then
# Line 449  let server_print s o = Line 452  let server_print s o =
452          end          end
453     else     else
454          begin          begin
455              
456          Printf.bprintf buf "[%-10s%5d] %15s:%-10s %s\n%45sUsers:%-8Ld Files:%-8Ld State:%s\n"          Printf.bprintf buf "[%-10s%5d] %15s:%-10s %s\n%45sUsers:%-8Ld Files:%-8Ld State:%s\n"
457            (n.network_name)            (n.network_name)
458            (server_num s)            (server_num s)
459            (Ip.string_of_addr info.G.server_addr)            (Ip.string_of_addr info.G.server_addr)
460            (Printf.sprintf "%s%s"            (Printf.sprintf "%s%s"
461             (string_of_int info.G.server_port)             (string_of_int info.G.server_port)
462             (if info.G.server_realport <> 0 then             (if info.G.server_realport <> 0 then
# Line 461  let server_print s o = Line 464  let server_print s o =
464            (info.G.server_name) ("")            (info.G.server_name) ("")
465            (info.G.server_nusers)            (info.G.server_nusers)
466            (info.G.server_nfiles)            (info.G.server_nfiles)
467            (string_of_connection_state impl.impl_server_state);            (if server_blocked s then
468                "IP blocked"
469  (*            else
470    List.iter (fun t ->              (string_of_connection_state impl.impl_server_state));
       Printf.bprintf buf "%-3s "  
         (match t.tag_value with  
           String s -> s  
             | Uint32 i -> Int32.to_string i  
         | Fint32 i -> Int32.to_string i  
         | _ -> "???"  
       )  
 ) info.G.server_tags;  
   
         Printf.bprintf buf " %6d %7d %s" info.G.server_nusers info.G.server_nfiles  
           (string_of_connection_state impl.impl_server_state);  
         Buffer.add_char buf '\n'*)  
471        end;        end;
472        
473    with e ->    with e ->
474        lprintf "Exception %s in CommonServer.server_print\n"        lprintf "Exception %s in CommonServer.server_print\n"
475          (Printexc2.to_string e)          (Printexc2.to_string e)
         

Legend:
Removed from v.1.18  
changed lines
  Added in v.1.19

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