File Coverage

blib/lib/Metabrik/Client/Whois.pm
Criterion Covered Total %
statement 12 223 5.3
branch 0 106 0.0
condition 0 32 0.0
subroutine 4 13 30.7
pod 1 7 14.2
total 17 381 4.4


line stmt bran cond sub pod time code
1             #
2             # $Id$
3             #
4             # client::whois Brik
5             #
6             package Metabrik::Client::Whois;
7 1     1   852 use strict;
  1         3  
  1         29  
8 1     1   5 use warnings;
  1         2  
  1         27  
9              
10 1     1   6 use base qw(Metabrik);
  1         1  
  1         1110  
11              
12             sub brik_properties {
13             return {
14 0     0 1   revision => '$Revision$',
15             tags => [ qw(unstable) ],
16             author => 'GomoR ',
17             license => 'http://opensource.org/licenses/BSD-3-Clause',
18             attributes => {
19             use_normalization => [ qw(0|1) ],
20             },
21             attributes_default => {
22             use_normalization => 1,
23             },
24             commands => {
25             from_ip => [ qw(ip_address) ],
26             from_domain => [ qw(domain) ],
27             is_available_domain => [ qw(domain) ],
28             parse_raw_ip_whois => [ qw($lines_list) ],
29             normalize_raw_ip_whois => [ qw($chunks $lines_list) ],
30             is_ip_from_owner => [ qw(ip_address owner) ],
31             },
32             require_modules => {
33             'Metabrik::Network::Address' => [ ],
34             'Metabrik::Network::Whois' => [ ],
35             'Metabrik::String::Parse' => [ ],
36             },
37             };
38             }
39              
40             sub parse_raw_ip_whois {
41 0     0 0   my $self = shift;
42 0           my ($lines) = @_;
43              
44 0 0         $self->brik_help_run_undef_arg('parse_raw_ip_whois', $lines) or return;
45              
46 0 0         my $sp = Metabrik::String::Parse->new_from_brik_init($self) or return;
47 0 0         my $chunks = $sp->split_by_blank_line($lines) or return;
48              
49 0           my @abuse = ();
50 0           my @chunks = ();
51 0           for my $this (@$chunks) {
52 0           my $new = {};
53 0           for (@$this) {
54             # Some whois prefix every line by 'network:'
55 0           s/^\s*network\s*:\s*//;
56              
57             # If an abuse email adress can be found, we gather it.
58 0 0 0       if (/abuse/i && /\@/) {
59 0           my ($new) = $_ =~ /([A-Za-z0-9\._-]+\@[A-Za-z0-9\._-]+)/;
60 0 0         if (defined($new)) {
61 0 0         defined($new) ? ($new =~ s/['"]//g) : ();
62 0           push @abuse, $new;
63             }
64             }
65              
66 0 0         if (/^\s*%error 230 No objects found/i) {
    0          
    0          
    0          
67 0           $new->{match} = 0;
68             }
69             elsif (/^\s*%error 350 Invalid Query Syntax/i) {
70 0           $new->{has_error} = 1;
71             }
72             elsif (/^\s*%error 501 Service Not Available: exceeded max client sessions/i) {
73 0           $new->{has_error} = 1;
74             }
75             elsif (/^\s*%ok\s*$/) {
76 0           $new->{has_error} = 1;
77             }
78              
79 0 0         next if (/^\s*%/); # Skip comments
80 0 0         next if (/^\s*#/); # Skip comments
81              
82             # We default to split by the first encountered : char
83 0 0         if (/^\s*([^:]+?)\s*:\s*(.*)\s*$/) {
    0          
    0          
84 0 0 0       if (defined($1) && defined($2)) {
85 0           my $k = lc($1);
86 0           my $v = $2;
87 0           $k =~ s{[ /-]}{_}g;
88 0 0         if (exists($new->{$k})) {
89 0           $new->{$k} .= "\n$v";
90             }
91             else {
92 0           $new->{$k} = $v;
93             }
94             }
95             }
96             # We try to guess an inetnum. Example:
97             # Akamai Technologies, Inc. AKAMAI (NET-104-64-0-0-1) 104.64.0.0 - 104.127.255.255
98             elsif (/^\s*([^\(]+)\(([^\)]+)\)\s*(\S+\s*-\s*\S+)$/) {
99 0           my $description = $1;
100 0           my $netname = $2;
101 0           my $inetnum = $3;
102 0           $new->{description} = $description;
103 0           $new->{netname} = $netname;
104 0           $new->{inetnum} = $inetnum;
105             }
106             # Nothing known. Exemple:
107             # No match found for aaa
108             elsif (/^\s*No match found for /i) {
109 0           $new->{match} = 0;
110             }
111             }
112              
113             # If we found some email address along with 'abuse' string, we add this email address
114 0 0         if (@abuse > 0) {
115 0           $new->{abuse} = join("\n", @abuse);
116             }
117              
118 0 0 0       if (keys %$new > 0 && ! exists($new->{match})) {
119 0           $new->{match} = 1;
120             }
121              
122 0 0         if (keys %$new > 0) {
123 0           push @chunks, $new;
124             }
125             }
126              
127 0           return \@chunks;
128             }
129              
130             sub _ip_lookup {
131 0     0     my $self = shift;
132 0           my ($this, $key, $normalize, $result) = @_;
133              
134 0           return $self->_domain_lookup($this, $key, $normalize, $result);
135             }
136              
137             sub normalize_raw_ip_whois {
138 0     0 0   my $self = shift;
139 0           my ($chunks, $lines) = @_;
140              
141 0 0         $self->brik_help_run_undef_arg('normalize_raw_ip_whois', $chunks) or return;
142 0 0         $self->brik_help_run_undef_arg('normalize_raw_ip_whois', $lines) or return;
143              
144 0           my $r = { raw => $lines };
145             #my $r = {};
146              
147 0           my $n_chunks = @$chunks;
148 0 0         if (@$chunks <= 0) {
149 0           return $self->log->error("normalize_raw_ip_whois: nothing to normalize");
150             }
151              
152             # We search for the first chunk with an inetnum.
153 0           my $general;
154 0           for (@$chunks) {
155 0 0 0       if (exists($_->{inetnum}) || exists($_->{netrange}) || exists($_->{network}) || exists($_->{ip_network})) {
      0        
      0        
156 0           $general = $_;
157 0           last;
158             }
159             }
160 0 0         if (! defined($general)) {
161 1     1   9 use Data::Dumper;
  1         5  
  1         1675  
162 0           print Dumper($chunks)."\n";
163 0           return $self->log->error("normalize_raw_ip_whois: no inetnum found in this record");
164             }
165              
166             # inetnum,netrange,network,ip_network
167 0           $self->_ip_lookup($general, 'inetnum', 'inetnum', $r);
168 0           $self->_ip_lookup($general, 'netrange', 'inetnum', $r);
169 0           $self->_ip_lookup($general, 'network', 'inetnum', $r);
170 0           $self->_ip_lookup($general, 'ip_network', 'inetnum', $r);
171             # cidr,
172 0           $self->_ip_lookup($general, 'cidr', 'cidr', $r);
173             # nethandle,
174 0           $self->_ip_lookup($general, 'nethandle', 'nethandle', $r);
175             # created,
176 0           $self->_ip_lookup($general, 'created', 'date_created', $r);
177             # updated,last_modified,
178 0           $self->_ip_lookup($general, 'updated', 'date_updated', $r);
179 0           $self->_ip_lookup($general, 'last_modified', 'date_updated', $r);
180             # originas,origin,
181 0           $self->_ip_lookup($general, 'originas', 'originas', $r);
182 0           $self->_ip_lookup($general, 'origin', 'originas', $r);
183             # netname,ownerid,
184 0           $self->_ip_lookup($general, 'netname', 'netname', $r);
185 0           $self->_ip_lookup($general, 'ownerid', 'netname', $r);
186             # descr,
187 0           $self->_ip_lookup($general, 'descr', 'description', $r);
188             # parent,
189 0           $self->_ip_lookup($general, 'parent', 'netparent', $r);
190             # nettype,
191 0           $self->_ip_lookup($general, 'nettype', 'nettype', $r);
192             # organization,org,owner,org_name,
193 0           $self->_ip_lookup($general, 'organization', 'organization', $r);
194 0           $self->_ip_lookup($general, 'org', 'organization', $r);
195 0           $self->_ip_lookup($general, 'owner', 'organization', $r);
196 0           $self->_ip_lookup($general, 'org_name', 'organization', $r);
197             # regdate,
198 0           $self->_ip_lookup($general, 'regdate', 'date_registered', $r);
199             # ref,
200 0           $self->_ip_lookup($general, 'ref', 'ref', $r);
201             # country,
202 0           $self->_ip_lookup($general, 'country', 'country', $r);
203             # source,
204 0           $self->_ip_lookup($general, 'source', 'source', $r);
205             # status,
206 0           $self->_ip_lookup($general, 'status', 'status', $r);
207             # abuse,abuse_c,
208 0           $self->_ip_lookup($general, 'abuse', 'abuse', $r);
209 0           $self->_ip_lookup($general, 'abuse_c', 'abuse', $r);
210             # nserver,
211 0           $self->_ip_lookup($general, 'nserver', 'nserver', $r);
212             # phone,
213 0           $self->_ip_lookup($general, 'phone', 'phone', $r);
214             # responsible,
215 0           $self->_ip_lookup($general, 'responsible', 'responsible', $r);
216             # address,
217 0           $self->_ip_lookup($general, 'address', 'address', $r);
218             # city,
219 0           $self->_ip_lookup($general, 'city', 'city', $r);
220             # sponsoring_org,
221 0           $self->_ip_lookup($general, 'sponsoring_org', 'sponsoring_org', $r);
222             # route,inetnum-up,
223 0           $self->_ip_lookup($general, 'route', 'route', $r);
224 0           $self->_ip_lookup($general, 'inetnum_up', 'route', $r);
225              
226             # We search for a chunk with AS information (usually the last chunk)
227 0           my $asinfo;
228 0           for (reverse @$chunks) {
229 0 0 0       if (exists($_->{origin}) && exists($_->{route})) {
230 0           $asinfo = $_;
231 0           last;
232             }
233             }
234              
235 0           $self->_ip_lookup($asinfo, 'route', 'route', $r);
236 0           $self->_ip_lookup($asinfo, 'origin', 'originas', $r);
237              
238 0           my @fields = qw(
239             inetnum
240             cidr
241             nethandle
242             date_created
243             date_updated
244             originas
245             netname
246             description
247             netparent
248             nettype
249             organization
250             date_registered
251             ref
252             country
253             source
254             status
255             abuse
256             nserver
257             phone
258             responsible
259             address
260             city
261             sponsoring_org
262             route
263             );
264              
265             # Put default values for missing fields
266 0           for (@fields) {
267 0   0       $r->{$_} ||= 'undef';
268             }
269              
270             # Dedups lines
271 0           for (keys %$r) {
272 0 0         next if $_ eq 'raw';
273 0 0         if (my @toks = split(/\n/, $r->{$_})) {
274 0           my %uniq = map { $_ => 1 } @toks;
  0            
275 0           $r->{$_} = join("\n", sort { $a cmp $b } keys %uniq); # With a sort
  0            
276             }
277             }
278              
279 0           return $r;
280             }
281              
282             sub from_ip {
283 0     0 0   my $self = shift;
284 0           my ($ip) = @_;
285              
286 0 0         $self->brik_help_run_undef_arg('ip', $ip) or return;
287              
288 0 0         my $na = Metabrik::Network::Address->new_from_brik_init($self) or return;
289 0 0         if (! $na->is_ip($ip)) {
290 0           return $self->log->error("ip: not a valid IP address [$ip]");
291             }
292              
293 0 0         my $nw = Metabrik::Network::Whois->new_from_brik_init($self) or return;
294 0 0         my $lines = $nw->target($ip) or return;
295              
296 0           my $r = {};
297 0 0         if ($self->use_normalization) {
298 0 0         my $chunks = $self->parse_raw_ip_whois($lines) or return;
299 0 0         $r = $self->normalize_raw_ip_whois($chunks, $lines) or return;
300             }
301              
302 0           $r->{date_queried} = localtime();
303 0           $r->{whois_server} = $nw->last_server;
304 0           $r->{raw} = $lines;
305              
306 0           return $r;
307             }
308              
309             sub _domain_lookup {
310 0     0     my $self = shift;
311 0           my ($this, $key, $normalize, $result) = @_;
312              
313 0 0         if (exists($this->{$key})) {
314             exists($result->{$normalize})
315             ? ($result->{$normalize} .= "\n".$this->{$key})
316 0 0         : ($result->{$normalize} = $this->{$key});
317             }
318              
319 0           return $this;
320             }
321              
322             sub from_domain {
323 0     0 0   my $self = shift;
324 0           my ($domain) = @_;
325              
326 0 0         $self->brik_help_run_undef_arg('domain', $domain) or return;
327              
328 0 0         my $na = Metabrik::Network::Address->new_from_brik_init($self) or return;
329 0 0         if ($na->is_ip($domain)) {
330 0           return $self->log->error("domain: domain [$domain] must not be an IP address");
331             }
332              
333 0 0         my $nw = Metabrik::Network::Whois->new_from_brik_init($self) or return;
334 0 0         my $lines = $nw->target($domain) or return;
335              
336 0           my $r = { raw => $lines };
337 0           $r->{date_queried} = localtime();
338 0           $r->{whois_server} = $nw->last_server;
339              
340 0 0         if ($self->use_normalization) {
341 0           my $chunks = $self->parse_raw_ip_whois($lines);
342              
343             # 4 categories: general, registrant, admin, tech
344 0           for (@$chunks) {
345             # Registrar,Sponsoring Registrar,
346 0           $self->_domain_lookup($_, 'registrar', 'registrar', $r);
347 0           $self->_domain_lookup($_, 'sponsoring_registrar', 'registrar', $r);
348              
349             # Whois Server,
350 0           $self->_domain_lookup($_, 'whois_server', 'whois_server', $r);
351              
352             # Domain Name,Dominio,domain,
353 0           $self->_domain_lookup($_, 'domain_name', 'domain_name', $r);
354 0           $self->_domain_lookup($_, 'dominio', 'domain_name', $r);
355 0           $self->_domain_lookup($_, 'domain', 'domain_name', $r);
356              
357             # Creation Date,Fecha de registro,created,
358 0           $self->_domain_lookup($_, 'creation_date', 'creation_date', $r);
359 0           $self->_domain_lookup($_, 'fecha_de_registro', 'creation_date', $r);
360 0           $self->_domain_lookup($_, 'created', 'creation_date', $r);
361              
362             # Updated Date,last-update,
363 0           $self->_domain_lookup($_, 'updated_date', 'updated_date', $r);
364 0           $self->_domain_lookup($_, 'last_update', 'updated_date', $r);
365              
366             # Registrar Registration Expiration Date,Expiration Date,Registry Expiry Date,Fecha de vencimiento,Expiry Date,
367 0           $self->_domain_lookup($_, 'registrar_registration_expiration_date', 'expiration_date', $r);
368 0           $self->_domain_lookup($_, 'expiration_date', 'expiration_date', $r);
369 0           $self->_domain_lookup($_, 'registry_expiry_date', 'expiration_date', $r);
370 0           $self->_domain_lookup($_, 'fecha_de_vencimiento', 'expiration_date', $r);
371 0           $self->_domain_lookup($_, 'expiry_date', 'expiration_date', $r);
372              
373             # Registrar URL,Referral URL,
374 0           $self->_domain_lookup($_, 'registrar_url', 'registrar_url', $r);
375 0           $self->_domain_lookup($_, 'referral_url', 'registrar_url', $r);
376              
377             # DNSSEC,
378 0           $self->_domain_lookup($_, 'dnssec', 'dnssec', $r);
379              
380             # Domain Status,Status,
381 0           $self->_domain_lookup($_, 'domain_status', 'domain_status', $r);
382 0           $self->_domain_lookup($_, 'status', 'domain_status', $r);
383              
384             # Name Server,nserver,
385 0           $self->_domain_lookup($_, 'name_server', 'name_server', $r);
386 0           $self->_domain_lookup($_, 'nserver', 'name_server', $r);
387              
388             # Registrant Name,
389 0           $self->_domain_lookup($_, 'registrant_name', 'registrant_name', $r);
390              
391             # Registrant Organization,Organizacion,
392 0           $self->_domain_lookup($_, 'registrant_organization', 'registrant_organization', $r);
393 0           $self->_domain_lookup($_, 'organizacion', 'registrar', $r);
394              
395             # Registrant Street,
396 0           $self->_domain_lookup($_, 'registrant_street', 'registrant_street', $r);
397              
398             # Registrant City,Ciudad,
399 0           $self->_domain_lookup($_, 'registrant_city', 'registrant_city', $r);
400 0           $self->_domain_lookup($_, 'ciudad', 'registrant_city', $r);
401              
402             # Registrant Postal Code,
403 0           $self->_domain_lookup($_, 'registrant_postal_code', 'registrant_postal_code', $r);
404              
405             # Registrant State/Province,
406 0           $self->_domain_lookup($_, 'registrant_state_province', 'registrant_state_province', $r);
407              
408             # Registrant Country,Pais,
409 0           $self->_domain_lookup($_, 'registrant_country', 'registrant_country', $r);
410 0           $self->_domain_lookup($_, 'pais', 'registrant_country', $r);
411              
412             # Registrant Email,
413 0           $self->_domain_lookup($_, 'registrant_email', 'registrant_email', $r);
414             }
415              
416             # Dedups lines
417 0           for (keys %$r) {
418 0 0         next if $_ eq 'raw';
419 0 0         if (my @toks = split(/\n/, $r->{$_})) {
420 0           my %uniq = map { $_ => 1 } @toks;
  0            
421 0           $r->{$_} = join("\n", sort { $a cmp $b } keys %uniq); # With a sort
  0            
422             }
423             }
424              
425             # If there is more than the raw key, domain exists
426 0 0         if (keys %$r > 1) {
427 0           $r->{domain_exists} = 1;
428             }
429             else {
430 0           $r->{domain_exists} = 0;
431             }
432             }
433              
434 0           return $r;
435             }
436              
437             sub is_available_domain {
438 0     0 0   my $self = shift;
439 0           my ($domain) = shift;
440              
441 0 0         $self->brik_help_run_undef_arg('is_available_domain', $domain) or return;
442              
443 0 0         my $info = $self->domain($domain) or return;
444              
445 0           return $info->{domain_exists};
446             }
447              
448             sub is_ip_from_owner {
449 0     0 0   my $self = shift;
450 0           my ($ip, $owner) = @_;
451              
452 0 0         $self->brik_help_run_undef_arg('is_ip_from_owner', $ip) or return;
453 0 0         $self->brik_help_run_undef_arg('is_ip_from_owner', $owner) or return;
454              
455 0 0         my $r = $self->ip($ip) or return;
456 0 0 0       if ((exists($r->{description}) && $r->{description} =~ m{$owner}i)
      0        
      0        
457             || (exists($r->{organization}) && $r->{organization} =~ m{$owner}i)) {
458 0           return 1;
459             }
460              
461 0           return 0;
462             }
463              
464             1;
465              
466             __END__