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 |
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) = |
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 |
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 |
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 |
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 |
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 |
|
|
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 = |
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 _ -> |
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 |
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 = |
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; *) |
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 |
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 -> |
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 |
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 |