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

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

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

revision 1.16 by spiralvoice, Fri Jul 22 10:58:55 2005 UTC revision 1.17 by spiralvoice, Mon Aug 1 20:15:28 2005 UTC
# Line 34  type 'a client_impl = { Line 34  type 'a client_impl = {
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;
# Line 105  let dummy_client_impl = { Line 104  let dummy_client_impl = {
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
# Line 158  let client_dprint (client: client) o fil Line 157  let client_dprint (client: client) o fil
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
# Line 177  let client_browse client immediate = Line 176  let client_browse client immediate =
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");
# Line 217  let check_client_implementations () = Line 216  let check_client_implementations () =
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";
# Line 236  let check_client_implementations () = Line 235  let check_client_implementations () =
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
# Line 258  let client_must_update_state client = Line 257  let client_must_update_state client =
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
# Line 268  let set_client_state c state = Line 267  let set_client_state c state =
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 =
# Line 277  let client_upload c = Line 276  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;
# Line 291  is still kept open. There should be a ch Line 290  is still kept open. There should be a ch
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
# Line 301  them unaccessable on Windows. Line 300  them unaccessable on Windows.
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;
# Line 317  let new_client (client : 'a client_impl) Line 316  let new_client (client : 'a client_impl)
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
# Line 345  let set_client_type c t = Line 344  let set_client_type c t =
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;
# Line 362  let clients_get_all () = Line 361  let clients_get_all () =
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
# Line 392  let client_print c o = Line 391  let client_print c o =
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 _ -> ""));
# Line 413  let client_print c o = Line 412  let client_print c o =
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

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

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