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; |
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 |
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; |
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; |
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 |
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; |
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"; |
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 |
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 |
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 |
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)) |
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; |
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 |
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\\\" |
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 |
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 |
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) |
|
|
|