/[mldonkey]/mldonkey/src/utils/net/ip.ml
ViewVC logotype

Diff of /mldonkey/src/utils/net/ip.ml

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

revision 1.8 by mldonkey, Mon Nov 1 11:23:02 2004 UTC revision 1.9 by spiralvoice, Thu Jul 7 00:25:46 2005 UTC
# Line 23  type t =  int * int * int * int Line 23  type t =  int * int * int * int
23  external of_string : string -> t  = "ml_ints_of_string"  external of_string : string -> t  = "ml_ints_of_string"
24    
25  let allow_local_network = ref false  let allow_local_network = ref false
26      
27  let of_inet_addr t =  let of_inet_addr t =
28    of_string (Unix.string_of_inet_addr t)    of_string (Unix.string_of_inet_addr t)
29      
30  let any = of_inet_addr Unix.inet_addr_any  let any = of_inet_addr Unix.inet_addr_any
31      
32  let null = (0,0,0,0)  let null = (0,0,0,0)
33    
34  let of_ints t = t  let of_ints t = t
# Line 45  let hostname_table = Hashtbl.create 997 Line 45  let hostname_table = Hashtbl.create 997
45  let to_fixed_string ((a4, a3, a2, a1) as t)=  let to_fixed_string ((a4, a3, a2, a1) as t)=
46    try    try
47      Hashtbl.find hostname_table t      Hashtbl.find hostname_table t
48    with _ ->    with _ ->
49        Printf.sprintf "%03d.%03d.%03d.%03d" a4 a3 a2 a1        Printf.sprintf "%03d.%03d.%03d.%03d" a4 a3 a2 a1
50    
51  let to_int64  ((a4, a3, a2, a1) as t) =  let to_int64  ((a4, a3, a2, a1) as t) =
# Line 53  let to_int64  ((a4, a3, a2, a1) as t) = Line 53  let to_int64  ((a4, a3, a2, a1) as t) =
53    Int64.add (Int64.of_int small) (Int64.shift_left (Int64.of_int a4) 24)    Int64.add (Int64.of_int small) (Int64.shift_left (Int64.of_int a4) 24)
54    
55  let const_int32_255 = Int64.of_int 255  let const_int32_255 = Int64.of_int 255
56      
57  let of_int64 i =  let of_int64 i =
58    let a4 = Int64.to_int (Int64.logand (Int64.shift_right i 24) const_int32_255)    let a4 = Int64.to_int (Int64.logand (Int64.shift_right i 24) const_int32_255)
59    in    in
# Line 64  let of_int64 i = Line 64  let of_int64 i =
64    let a1 = Int64.to_int (Int64.logand i const_int32_255)    let a1 = Int64.to_int (Int64.logand i const_int32_255)
65    in    in
66    (a4, a3, a2, a1)    (a4, a3, a2, a1)
67      
68  let resolve_one t =  let resolve_one t =
69    try    try
70      Hashtbl.find hostname_table t      Hashtbl.find hostname_table t
# Line 80  let resolve_one t = Line 80  let resolve_one t =
80        end;        end;
81        to_fixed_string t        to_fixed_string t
82    
83  let valid (j,k,l,i) =  let valid (j,k,l,i) =
84    j > 0 && j < 224 &&    j > 0 && j < 224 &&
85    k >= 0 && k <= 255 &&    k >= 0 && k <= 255 &&
86    l >= 0 && l <= 255 &&    l >= 0 && l <= 255 &&
87    i >= 0 && i <= 255    i >= 0 && i <= 255
88      
89  let reachable ip =  let reachable ip =
90    !allow_local_network ||    !allow_local_network ||
91    match ip with    match ip with
92      192, 168,_,_ -> false      192, 168,_,_ -> false
93    | 10, _, _, _ | 127, _,_,_ -> false    | 10, _, _, _ | 127, _,_,_ -> false
94    | 172, v, _, _ when v > 15 && v < 32 -> false    | 172, v, _, _ when v > 15 && v < 32 -> false
95    | _ -> true    | _ -> true
96      
97      
98  let rec matches ((a4,a3,a2,a1) as a) ips =  let rec matches ((a4,a3,a2,a1) as a) ips =
99    match ips with    match ips with
100      [] -> false      [] -> false
# Line 104  let rec matches ((a4,a3,a2,a1) as a) ips Line 104  let rec matches ((a4,a3,a2,a1) as a) ips
104          (a2 = b2 || b2 = 255) &&          (a2 = b2 || b2 = 255) &&
105          (a1 = b1 || b1 = 255))          (a1 = b1 || b1 = 255))
106        || (matches a tail)        || (matches a tail)
107          
108  let compare ((a4,a3,a2,a1) as a) ((b4,b3,b2,b1) as b) =  let compare ((a4,a3,a2,a1) as a) ((b4,b3,b2,b1) as b) =
109    let c4 = compare a4 b4 in    let c4 = compare a4 b4 in
110    if c4 <> 0 then c4 else    if c4 <> 0 then c4 else
# Line 115  let compare ((a4,a3,a2,a1) as a) ((b4,b3 Line 115  let compare ((a4,a3,a2,a1) as a) ((b4,b3
115    compare a1 b1    compare a1 b1
116    
117  let localhost = of_string "127.0.0.1"  let localhost = of_string "127.0.0.1"
118      
119  let to_sockaddr ip port =  let to_sockaddr ip port =
120    Unix.ADDR_INET (to_inet_addr ip, port)    Unix.ADDR_INET (to_inet_addr ip, port)
121    
# Line 130  let get_non_local_ip list = Line 130  let get_non_local_ip list =
130          else ip          else ip
131    in    in
132    try iter list    try iter list
133    with _ -> match list with [] -> raise Not_found  | ip :: _ -> of_inet_addr ip    with _ ->
134              match list with
135            [] -> raise Not_found
136          | ip :: _ -> of_inet_addr ip
137    
138  let gethostbyname name =  let gethostbyname name =
139    let h = Unix.gethostbyname name in    let h = Unix.gethostbyname name in
140    let list = Array.to_list h.Unix.h_addr_list in    let list = Array.to_list h.Unix.h_addr_list in
141    get_non_local_ip list            get_non_local_ip list
142    
143  let ip_cache = Hashtbl.create 13  let ip_cache = Hashtbl.create 13
144  let resolve_name name =  let resolve_name name =
# Line 151  let resolve_name name = Line 154  let resolve_name name =
154        with _ -> ip        with _ -> ip
155      else ip      else ip
156    with _ ->    with _ ->
157        lprintf "Resolving [%s] ..." name;        lprintf "[NS]: Resolving [%s] ..." name;
158        let ip = gethostbyname name in        let ip = gethostbyname name in
159        lprintf "done\n";        lprintf "[NS]: done\n";
160        Hashtbl.add ip_cache name (ip, current_time +. 3600.);        Hashtbl.add ip_cache name (ip, current_time +. 3600.);
161        ip        ip
162          
163    
164  let from_name name =  let from_name name =
165    try    try
166      if String.length name > 0 && name.[0] >= '0' && name.[0] <= '9' then      if String.length name > 0 && name.[0] >= '0' && name.[0] <= '9' then
167        of_string name        of_string name
168      else      else
169        raise Not_found        raise Not_found
170    with _ ->    with _ ->
# Line 170  let from_name name = Line 173  let from_name name =
173          let ip = resolve_name name in          let ip = resolve_name name in
174  (*        lprintf "..name resolved\n";  *)  (*        lprintf "..name resolved\n";  *)
175          ip          ip
176        with _ ->        with _ ->
177            raise Not_found            raise Not_found
178              
179  let my () =  let my () =
180    try    try
181      let name = Unix.gethostname () in      let name = Unix.gethostname () in
# Line 184  let my () = Line 187  let my () =
187          else          else
188            localhost            localhost
189    with _ -> localhost    with _ -> localhost
190          
191    
192  open Options  open Options
193            
194      let value_to_ip v = of_string (value_to_string v)      let value_to_ip v = of_string (value_to_string v)
195                
196      let ip_to_value ip = string_to_value (to_string ip)      let ip_to_value ip = string_to_value (to_string ip)
197          
198  let option = define_option_class "Ip" value_to_ip ip_to_value        let option = define_option_class "Ip" value_to_ip ip_to_value
199      
200  let rev (a1,a2,a3,a4) = (a4,a3,a2,a1)  let rev (a1,a2,a3,a4) = (a4,a3,a2,a1)
201    
202  let equal a b =  let equal a b =
# Line 208  type job = { Line 211  type job = {
211      handler : (t -> unit);      handler : (t -> unit);
212    }    }
213    
214      
215  external job_done : job -> bool = "ml_ip_job_done"  external job_done : job -> bool = "ml_ip_job_done"
216  external job_start : job -> unit = "ml_ip_job_start"  external job_start : job -> unit = "ml_ip_job_start"
217      
218  let current_job = ref None  let current_job = ref None
219  let ip_fifo = Fifo.create ()  let ip_fifo = Fifo.create ()
220      
221  let async_ip name f =  let async_ip name f =
222    try    try
223  (*    lprintf "async_ip [%s]\n" name; *)  (*    lprintf "async_ip [%s]\n" name; *)
# Line 227  let async_ip name f = Line 230  let async_ip name f =
230        (try f ip with _ -> ())        (try f ip with _ -> ())
231      with _ ->      with _ ->
232          Fifo.put ip_fifo (name, f)          Fifo.put ip_fifo (name, f)
233            
234  (* We check for names every 1/10 second. Too long ? *)  (* We check for names every 1/10 second. Too long ? *)
235  let _ =  let _ =
236    BasicSocket.add_infinite_timer 0.1 (fun _ ->    BasicSocket.add_infinite_timer 0.1 (fun _ ->
237        let current_time = Unix.gettimeofday () in        let current_time = Unix.gettimeofday () in
238        while true do        while true do
239          match !current_job with          match !current_job with
240            None ->            None ->
241              let (name, f) = Fifo.take ip_fifo in              let (name, f) = Fifo.take ip_fifo in
242              (try              (try
243                  let (ip, time) = Hashtbl.find ip_cache name in                  let (ip, time) = Hashtbl.find ip_cache name in
# Line 246  let _ = Line 249  let _ =
249                with _ ->                with _ ->
250  (*                  lprintf "resolving name...\n"; *)  (*                  lprintf "resolving name...\n"; *)
251                    if !BasicSocket.use_threads &&                    if !BasicSocket.use_threads &&
252                      BasicSocket.has_threads () then                          BasicSocket.has_threads () then
253                      let job = {                      let job = {
254                          handler = f;                          handler = f;
255                          name = name;                          name = name;
256                          entries = [||];                          entries = [||];
257                          error = false;                          error = false;
258                        }                        }
259                      in                      in
260                      current_job := Some job;                      current_job := Some job;
261                      job_start job                      job_start job
262                    else begin                    else begin
263  (*                      lprintf "from_name ...\n"; *)  (*                      lprintf "from_name ...\n"; *)
264                        f (from_name name)                        f (from_name name)
265                          
266                      end                      end
267              )              )
268          | Some job ->          | Some job ->
# Line 292  let string_of_addr ip = Line 295  let string_of_addr ip =
295    
296  let addr_of_string s =  let addr_of_string s =
297    try AddrIp (of_string s) with _ -> AddrName s    try AddrIp (of_string s) with _ -> AddrName s
298          
299  let addr_of_ip ip = AddrIp ip  let addr_of_ip ip = AddrIp ip
300  let ip_of_addr addr =  let ip_of_addr addr =
301    match addr with    match addr with
# Line 303  let async_ip_of_addr addr f = Line 306  let async_ip_of_addr addr f =
306    match addr with    match addr with
307      AddrIp ip -> f ip      AddrIp ip -> f ip
308    | AddrName name -> async_ip name f    | AddrName name -> async_ip name f
309          
310                  
311  let value_to_addr v = addr_of_string (value_to_string v)  let value_to_addr v = addr_of_string (value_to_string v)
312      
313  let addr_to_value ip = string_to_value (string_of_addr ip)  let addr_to_value ip = string_to_value (string_of_addr ip)
314          
315  let addr_option = define_option_class "Addr" value_to_addr addr_to_value        let addr_option = define_option_class "Addr" value_to_addr addr_to_value

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

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