34 |
mutable impl_client_val : 'a; |
mutable impl_client_val : 'a; |
35 |
mutable impl_client_ops : 'a client_ops; |
mutable impl_client_ops : 'a client_ops; |
36 |
} |
} |
37 |
|
|
38 |
and 'a client_ops = { |
and 'a client_ops = { |
39 |
mutable op_client_network : network; |
mutable op_client_network : network; |
40 |
|
|
41 |
(* force connection to the client. *) |
(* force connection to the client. *) |
42 |
mutable op_client_connect : ('a -> unit); |
mutable op_client_connect : ('a -> unit); |
43 |
|
|
44 |
(* force connection to the client. *) |
(* force connection to the client. *) |
45 |
mutable op_client_disconnect : ('a -> unit); |
mutable op_client_disconnect : ('a -> unit); |
46 |
|
|
47 |
(* convert a client structure to be stored in the option file *) |
(* convert a client structure to be stored in the option file *) |
48 |
mutable op_client_to_option : ('a -> (string * option_value) list); |
mutable op_client_to_option : ('a -> (string * option_value) list); |
49 |
|
|
50 |
(* convert a client to an info structure used in the interfaces *) |
(* convert a client to an info structure used in the interfaces *) |
51 |
mutable op_client_info : ('a -> GuiTypes.client_info); |
mutable op_client_info : ('a -> GuiTypes.client_info); |
52 |
|
|
53 |
(* send a message to a given client *) |
(* send a message to a given client *) |
54 |
mutable op_client_say : ('a -> string -> unit); |
mutable op_client_say : ('a -> string -> unit); |
55 |
|
|
56 |
(* ask a client for its list of files. The boolean argument is used to |
(* ask a client for its list of files. The boolean argument is used to |
57 |
decide whether to connect immediatly or not. *) |
decide whether to connect immediatly or not. *) |
58 |
mutable op_client_browse : ('a -> bool -> unit); |
mutable op_client_browse : ('a -> bool -> unit); |
59 |
|
|
60 |
(* returns the list of files of a client as already known *) |
(* returns the list of files of a client as already known *) |
61 |
mutable op_client_files : ('a -> (string * result) list); |
mutable op_client_files : ('a -> (string * result) list); |
62 |
|
|
63 |
(* used to clear the file list a client *) |
(* used to clear the file list a client *) |
64 |
mutable op_client_clear_files : ('a -> unit); |
mutable op_client_clear_files : ('a -> unit); |
65 |
|
|
66 |
mutable op_client_bprint : ('a -> Buffer.t -> unit); |
mutable op_client_bprint : ('a -> Buffer.t -> unit); |
67 |
|
|
68 |
mutable op_client_dprint : ('a -> CommonTypes.ui_conn -> |
mutable op_client_dprint : ('a -> CommonTypes.ui_conn -> |
69 |
CommonTypes.file -> unit); |
CommonTypes.file -> unit); |
70 |
|
|
71 |
mutable op_client_dprint_html : ('a -> CommonTypes.ui_conn -> |
mutable op_client_dprint_html : ('a -> CommonTypes.ui_conn -> |
72 |
CommonTypes.file -> string -> bool); |
CommonTypes.file -> string -> bool); |
73 |
|
|
74 |
mutable op_client_debug : ('a -> bool -> unit); |
mutable op_client_debug : ('a -> bool -> unit); |
75 |
|
|
76 |
mutable op_client_can_upload : ('a -> int -> unit); |
mutable op_client_can_upload : ('a -> int -> unit); |
77 |
|
|
78 |
mutable op_client_enter_upload_queue : ('a -> unit); |
mutable op_client_enter_upload_queue : ('a -> unit); |
79 |
} |
} |
80 |
|
|
81 |
let client_counter = CommonUser.user_counter |
let client_counter = CommonUser.user_counter |
82 |
|
|
|
|
|
83 |
let as_client (client : 'a client_impl) = |
let as_client (client : 'a client_impl) = |
84 |
let (client : client) = Obj.magic client in |
let (client : client) = Obj.magic client in |
85 |
client |
client |
86 |
|
|
87 |
let as_client_impl (client : client) = |
let as_client_impl (client : client) = |
88 |
let (client : 'a client_impl) = Obj.magic client in |
let (client : 'a client_impl) = Obj.magic client in |
89 |
client |
client |
90 |
|
|
91 |
let client_num c = |
let client_num c = |
92 |
let c = as_client_impl c in |
let c = as_client_impl c in |
93 |
c.impl_client_num |
c.impl_client_num |
94 |
|
|
95 |
let dummy_client_impl = { |
let dummy_client_impl = { |
96 |
impl_client_type = 0; |
impl_client_type = 0; |
97 |
impl_client_state = NewHost; |
impl_client_state = NewHost; |
104 |
} |
} |
105 |
|
|
106 |
let dummy_client = as_client dummy_client_impl |
let dummy_client = as_client dummy_client_impl |
107 |
|
|
108 |
module H = Weak2.Make(struct |
module H = Weak2.Make(struct |
109 |
type t = client |
type t = client |
110 |
let hash c = Hashtbl.hash (client_num c) |
let hash c = Hashtbl.hash (client_num c) |
111 |
|
|
112 |
let equal x y = (client_num x) = (client_num y) |
let equal x y = (client_num x) = (client_num y) |
113 |
end) |
end) |
114 |
|
|
115 |
let clients_by_num = H.create 1027 |
let clients_by_num = H.create 1027 |
116 |
|
|
117 |
let client_network (client : client) = |
let client_network (client : client) = |
118 |
let client = as_client_impl client in |
let client = as_client_impl client in |
119 |
client.impl_client_ops.op_client_network |
client.impl_client_ops.op_client_network |
157 |
let client_dprint_html (client: client) o file str = |
let client_dprint_html (client: client) o file str = |
158 |
let client = as_client_impl client in |
let client = as_client_impl client in |
159 |
client.impl_client_ops.op_client_dprint_html client.impl_client_val o file str |
client.impl_client_ops.op_client_dprint_html client.impl_client_val o file str |
160 |
|
|
161 |
let client_connect client= |
let client_connect client= |
162 |
let client = as_client_impl client in |
let client = as_client_impl client in |
163 |
client.impl_client_ops.op_client_connect client.impl_client_val |
client.impl_client_ops.op_client_connect client.impl_client_val |
176 |
|
|
177 |
let client_enter_upload_queue client = |
let client_enter_upload_queue client = |
178 |
let client = as_client_impl client in |
let client = as_client_impl client in |
179 |
client.impl_client_ops.op_client_enter_upload_queue client.impl_client_val |
client.impl_client_ops.op_client_enter_upload_queue client.impl_client_val |
180 |
|
|
181 |
let ni n m = |
let ni n m = |
182 |
let s = Printf.sprintf "Client.%s not implemented by %s" |
let s = Printf.sprintf "Client.%s not implemented by %s" |
183 |
m n.network_name in |
m n.network_name in |
184 |
lprintf_nl "%s" s; |
lprintf_nl "%s" s; |
185 |
s |
s |
186 |
|
|
187 |
let fni n m = failwith (ni n m) |
let fni n m = failwith (ni n m) |
188 |
let ni_ok n m = ignore (ni n m) |
let ni_ok n m = ignore (ni n m) |
189 |
|
|
190 |
let clients_ops = ref [] |
let clients_ops = ref [] |
191 |
|
|
192 |
let new_client_ops network = |
let new_client_ops network = |
193 |
let c = { |
let c = { |
194 |
op_client_network = network; |
op_client_network = network; |
195 |
op_client_to_option = (fun _ -> fni network "client_to_option"); |
op_client_to_option = (fun _ -> fni network "client_to_option"); |
216 |
lprintf_nl "\n---- Methods not implemented for CommonClient ----\n"; |
lprintf_nl "\n---- Methods not implemented for CommonClient ----\n"; |
217 |
List.iter (fun (c, cc) -> |
List.iter (fun (c, cc) -> |
218 |
let n = c.op_client_network.network_name in |
let n = c.op_client_network.network_name in |
219 |
lprintf_nl "\n Network %s\n" n; |
lprintf_nl "\n Network %s\n" n; |
220 |
if c.op_client_to_option == cc.op_client_to_option then |
if c.op_client_to_option == cc.op_client_to_option then |
221 |
lprintf_nl "op_client_to_option"; |
lprintf_nl "op_client_to_option"; |
222 |
if c.op_client_info == cc.op_client_info then |
if c.op_client_info == cc.op_client_info then |
223 |
lprintf_nl "op_client_info"; |
lprintf_nl "op_client_info"; |
235 |
lprintf_nl "op_client_browse"; |
lprintf_nl "op_client_browse"; |
236 |
) !clients_ops; |
) !clients_ops; |
237 |
lprint_newline () |
lprint_newline () |
238 |
|
|
239 |
let client_find num = |
let client_find num = |
240 |
H.find clients_by_num (as_client { dummy_client_impl with |
H.find clients_by_num (as_client { dummy_client_impl with |
241 |
impl_client_num = num }) |
impl_client_num = num }) |
242 |
|
|
243 |
let client_must_update client = |
let client_must_update client = |
244 |
let impl = as_client_impl client in |
let impl = as_client_impl client in |
245 |
if impl.impl_client_update <> 0 then |
if impl.impl_client_update <> 0 then |
246 |
CommonEvent.add_event (Client_info_event client); |
CommonEvent.add_event (Client_info_event client); |
247 |
impl.impl_client_update <- 0 |
impl.impl_client_update <- 0 |
248 |
|
|
249 |
let client_must_update_state client = |
let client_must_update_state client = |
250 |
let impl = as_client_impl client in |
let impl = as_client_impl client in |
251 |
if impl.impl_client_update > 0 then |
if impl.impl_client_update > 0 then |
257 |
let client_state c = |
let client_state c = |
258 |
let impl = as_client_impl c in |
let impl = as_client_impl c in |
259 |
impl.impl_client_state |
impl.impl_client_state |
260 |
|
|
261 |
let set_client_state c state = |
let set_client_state c state = |
262 |
let impl = as_client_impl c in |
let impl = as_client_impl c in |
263 |
if impl.impl_client_state <> state then begin |
if impl.impl_client_state <> state then begin |
267 |
|
|
268 |
let uploaders = ref Intmap.empty |
let uploaders = ref Intmap.empty |
269 |
|
|
270 |
let client_has_a_slot c = |
let client_has_a_slot c = |
271 |
(as_client_impl c).impl_client_has_slot |
(as_client_impl c).impl_client_has_slot |
272 |
|
|
273 |
let client_upload c = |
let client_upload c = |
276 |
let set_client_upload c sh = |
let set_client_upload c sh = |
277 |
(as_client_impl c).impl_client_upload <- sh; |
(as_client_impl c).impl_client_upload <- sh; |
278 |
client_must_update c |
client_must_update c |
279 |
|
|
280 |
let set_client_has_a_slot c b = |
let set_client_has_a_slot c b = |
281 |
let impl = as_client_impl c in |
let impl = as_client_impl c in |
282 |
if not b && impl.impl_client_has_slot then begin |
if not b && impl.impl_client_has_slot then begin |
283 |
impl.impl_client_has_slot <- false; |
impl.impl_client_has_slot <- false; |
290 |
are currently uploading that file, if not close it. |
are currently uploading that file, if not close it. |
291 |
Until this is coded all files are closed, it does not harm |
Until this is coded all files are closed, it does not harm |
292 |
the work of the core but avoids locking files which makes |
the work of the core but avoids locking files which makes |
293 |
them unaccessable on Windows. |
them unaccessable on Windows. |
294 |
*) |
*) |
295 |
Unix32.close_all () |
Unix32.close_all () |
296 |
end |
end |
300 |
impl.impl_client_has_slot <- b; |
impl.impl_client_has_slot <- b; |
301 |
client_must_update c |
client_must_update c |
302 |
end |
end |
303 |
|
|
304 |
let set_client_disconnected c reason = |
let set_client_disconnected c reason = |
305 |
let impl = as_client_impl c in |
let impl = as_client_impl c in |
306 |
set_client_has_a_slot c false; |
set_client_has_a_slot c false; |
307 |
|
|
308 |
match impl.impl_client_state with |
match impl.impl_client_state with |
309 |
Connected n -> set_client_state c (NotConnected (reason, n)) |
Connected n -> set_client_state c (NotConnected (reason, n)) |
310 |
| _ -> set_client_state c (NotConnected (reason, -1)) |
| _ -> set_client_state c (NotConnected (reason, -1)) |
311 |
|
|
312 |
let new_client (client : 'a client_impl) = |
let new_client (client : 'a client_impl) = |
313 |
incr client_counter; |
incr client_counter; |
314 |
client.impl_client_num <- !client_counter; |
client.impl_client_num <- !client_counter; |
316 |
H.add clients_by_num client; |
H.add clients_by_num client; |
317 |
client_must_update client |
client_must_update client |
318 |
|
|
319 |
let book_client_num () = |
let book_client_num () = |
320 |
incr client_counter; |
incr client_counter; |
321 |
!client_counter |
!client_counter |
322 |
|
|
323 |
let new_client_with_num (client : 'a client_impl) num = |
let new_client_with_num (client : 'a client_impl) num = |
324 |
client.impl_client_num <- num; |
client.impl_client_num <- num; |
325 |
let (client : client) = Obj.magic client in |
let (client : client) = Obj.magic client in |
326 |
H.add clients_by_num client; |
H.add clients_by_num client; |
327 |
client_must_update client |
client_must_update client |
328 |
|
|
329 |
let new_client (client : 'a client_impl) = |
let new_client (client : 'a client_impl) = |
330 |
new_client_with_num client (book_client_num ()) |
new_client_with_num client (book_client_num ()) |
331 |
|
|
332 |
let client_remove c = |
let client_remove c = |
333 |
H.remove clients_by_num c; |
H.remove clients_by_num c; |
334 |
set_client_state c RemovedHost |
set_client_state c RemovedHost |
335 |
|
|
336 |
let client_type c = |
let client_type c = |
337 |
let impl = as_client_impl c in |
let impl = as_client_impl c in |
338 |
impl.impl_client_type |
impl.impl_client_type |
344 |
client_must_update c |
client_must_update c |
345 |
end |
end |
346 |
|
|
347 |
let _ = |
let _ = |
348 |
Heap.add_memstat "CommonClient" (fun level buf -> |
Heap.add_memstat "CommonClient" (fun level buf -> |
349 |
let counter = ref 0 in |
let counter = ref 0 in |
350 |
H.iter (fun _ -> incr counter) clients_by_num; |
H.iter (fun _ -> incr counter) clients_by_num; |
361 |
directly accessing the hashtable. |
directly accessing the hashtable. |
362 |
*) |
*) |
363 |
let clients_by_num = () |
let clients_by_num = () |
364 |
|
|
365 |
let client_new_file (client :client) (dirname:string) r = |
let client_new_file (client :client) (dirname:string) r = |
366 |
CommonEvent.add_event (Client_new_file_event |
CommonEvent.add_event (Client_new_file_event |
367 |
(client, dirname, (r : result))) |
(client, dirname, (r : result))) |
368 |
|
|
369 |
module G = GuiTypes |
module G = GuiTypes |
391 |
html_mods_td buf [ |
html_mods_td buf [ |
392 |
("", "sr", Printf.sprintf "%d" (client_num c)); |
("", "sr", Printf.sprintf "%d" (client_num c)); |
393 |
("", "sr", n.network_name); |
("", "sr", n.network_name); |
394 |
("", "sr", (try match info.G.client_kind with |
("", "sr", (try match info.G.client_kind with |
395 |
Known_location (ip,port) -> Printf.sprintf "%s" (Ip.to_string ip) |
Known_location (ip,port) -> Printf.sprintf "%s" (Ip.to_string ip) |
396 |
| Indirect_location _ -> Printf.sprintf "None" |
| Indirect_location _ -> Printf.sprintf "None" |
397 |
with _ -> "")); |
with _ -> "")); |
412 |
|
|
413 |
let is_friend c = |
let is_friend c = |
414 |
(client_type c) land client_friend_tag <> 0 |
(client_type c) land client_friend_tag <> 0 |
415 |
|
|
416 |
let is_contact c = |
let is_contact c = |
417 |
(client_type c) land client_contact_tag <> 0 |
(client_type c) land client_contact_tag <> 0 |
418 |
|
|
419 |
let set_friend c = |
let set_friend c = |
420 |
set_client_type c (client_type c lor client_friend_tag) |
set_client_type c (client_type c lor client_friend_tag) |
421 |
|
|
422 |
let set_contact c = |
let set_contact c = |
423 |
set_client_type c (client_type c lor client_contact_tag) |
set_client_type c (client_type c lor client_contact_tag) |
424 |
|
|
425 |
let set_not_friend c = |
let set_not_friend c = |
426 |
set_client_type c (client_type c land (lnot client_friend_tag)) |
set_client_type c (client_type c land (lnot client_friend_tag)) |
427 |
|
|
428 |
let set_not_contact c = |
let set_not_contact c = |
429 |
set_client_type c (client_type c land (lnot client_contact_tag)) |
set_client_type c (client_type c land (lnot client_contact_tag)) |
430 |
|
|
431 |
let is_nolimit c = |
let is_nolimit c = |
432 |
(client_type c) land client_nolimit_tag <> 0 |
(client_type c) land client_nolimit_tag <> 0 |
433 |
|
|
434 |
let set_nolimit c = |
let set_nolimit c = |
435 |
set_client_type c (client_type c lor client_nolimit_tag) |
set_client_type c (client_type c lor client_nolimit_tag) |
436 |
|
|
437 |
let is_initialized c = |
let is_initialized c = |
438 |
client_type c land client_initialized_tag <> 0 |
client_type c land client_initialized_tag <> 0 |
439 |
|
|
440 |
let set_initialized c = |
let set_initialized c = |
441 |
set_client_type c (client_type c lor client_initialized_tag) |
set_client_type c (client_type c lor client_initialized_tag) |
442 |
|
|
443 |
let client_has_bitmap (client : client) (file : file) bitmap = |
let client_has_bitmap (client : client) (file : file) bitmap = |
444 |
CommonEvent.add_event (File_update_availability (file, client, bitmap)) |
CommonEvent.add_event (File_update_availability (file, client, bitmap)) |
445 |
|
|
446 |
|
let clear_upload_slots () = |
447 |
|
Intmap.iter (fun _ c -> |
448 |
|
try |
449 |
|
let i = client_info c in |
450 |
|
let ctime = ((BasicSocket.last_time ()) - i.GuiTypes.client_connect_time) / 60 in |
451 |
|
if i.GuiTypes.client_uploaded = Int64.zero && ctime > 1 then |
452 |
|
begin |
453 |
|
client_disconnect c; |
454 |
|
lprintf_nl "disconnected client %d: [%s %s] %s after %d minute of silence." |
455 |
|
(client_num c) |
456 |
|
i.GuiTypes.client_software |
457 |
|
i.GuiTypes.client_release |
458 |
|
i.GuiTypes.client_name |
459 |
|
ctime |
460 |
|
end |
461 |
|
with _ -> () |
462 |
|
) !uploaders |