File Coverage

blib/lib/Net/Google/SafeBrowsing2.pm
Criterion Covered Total %
statement 140 649 21.5
branch 16 202 7.9
condition 6 140 4.2
subroutine 27 58 46.5
pod 35 36 97.2
total 224 1085 20.6


line stmt bran cond sub pod time code
1             package Net::Google::SafeBrowsing2;
2              
3 1     1   15524 use strict;
  1         2  
  1         33  
4 1     1   4 use warnings;
  1         1  
  1         25  
5              
6 1     1   4 use Carp;
  1         4  
  1         86  
7 1     1   1730 use LWP::UserAgent;
  1         40294  
  1         29  
8 1     1   6 use URI;
  1         2  
  1         19  
9 1     1   1072 use Digest::SHA qw(sha256);
  1         2818  
  1         83  
10 1     1   6 use List::Util qw(first);
  1         1  
  1         56  
11 1     1   446 use Text::Trim;
  1         515  
  1         55  
12 1     1   407 use Digest::HMAC_SHA1 qw(hmac_sha1 hmac_sha1_hex);
  1         1110  
  1         48  
13 1     1   446 use MIME::Base64::URLSafe;
  1         1239  
  1         49  
14 1     1   5 use MIME::Base64;
  1         1  
  1         35  
15 1     1   443 use String::HexConvert;
  1         288  
  1         36  
16 1     1   512 use File::Slurp;
  1         10689  
  1         62  
17 1     1   754 use IO::Socket::SSL 'inet4' ;
  1         67429  
  1         8  
18              
19              
20 1     1   203 use Exporter 'import';
  1         1  
  1         60  
21             our @EXPORT = qw(DATABASE_RESET MAC_ERROR MAC_KEY_ERROR INTERNAL_ERROR SERVER_ERROR NO_UPDATE NO_DATA SUCCESSFUL MALWARE PHISHING);
22              
23             our $VERSION = '1.12';
24              
25             BEGIN {
26 1     1   29 IO::Socket::SSL::set_ctx_defaults(
27             # verify_mode => Net::SSLeay->VERIFY_PEER(),
28             SSL_verify_mode => 0,
29             );
30             }
31              
32              
33             =head1 NAME
34              
35             Net::Google::SafeBrowsing2 - Perl extension for the Google Safe Browsing v2 API. (Google Safe Browsing v1 has been deprecated by Google.)
36              
37             =head1 SYNOPSIS
38              
39             use Net::Google::SafeBrowsing2;
40             use Net::Google::SafeBrowsing2::Sqlite;
41            
42             my $storage = Net::Google::SafeBrowsing2::Sqlite->new(file => 'google-v2.db');
43             my $gsb = Net::Google::SafeBrowsing2->new(
44             key => "my key",
45             storage => $storage,
46             );
47            
48             $gsb->update();
49             my $match = $gsb->lookup(url => 'http://www.gumblar.cn/');
50            
51             if ($match eq MALWARE) {
52             print "http://www.gumblar.cn/ is flagged as a dangerous site\n";
53             }
54              
55             $storage->close();
56              
57             =head1 DESCRIPTION
58              
59             Net::Google::SafeBrowsing2 implements the Google Safe Browsing v2 API.
60              
61             The library passes most of the unit tests listed in the API documentation. See the documentation (L) for more details about the failed tests.
62              
63             The Google Safe Browsing database must be stored and managed locally. L uses Sqlite as the storage back-end, L uses MySQL. Other storage mechanisms (databases, memory, etc.) can be added and used transparently with this module.
64              
65             You may want to look at "Google Safe Browsing v2: Implementation Notes" (L), a collection of notes and real-world numbers about the API. This is intended for people who want to learn more about the API, whether as a user or to make their own implementation.
66              
67             The source code is available on github at L.
68              
69             If you do not need to inspect more than 10,000 URLs a day, you can use L with the Google Safe Browsing v2 Lookup API which does not require to store and maintain a local database.
70              
71             IMPORTANT: If you start with an empty database, you will need to perform several updates to retrieve all the Google Safe Browsing information. This may require up to 24 hours. This is a limitation of the Google API, not of this module. See "Google Safe Browsing v2: Implementation Notes" at L.
72              
73             =head1 CONSTANTS
74              
75             Several constants are exported by this module:
76              
77             =over 4
78              
79             =item DATABASE_RESET
80              
81             Google requested to reset (empty) the local database.
82              
83             =item MAC_ERROR
84              
85             The replies from Google could not be validated with the MAC keys.
86              
87             =item MAC_KEY_ERROR
88              
89             The request for the MAC keys failed.
90              
91             =item INTERNAL_ERROR
92              
93             An internal error occurred.
94              
95             =item SERVER_ERROR
96              
97             The server sent an error back to the client.
98              
99             =item NO_UPDATE
100              
101             No update was performed, probably because it is too early to make a new request to Google Safe Browsing.
102              
103             =item NO_DATA
104              
105             No data was sent back by Google to the client, probably because the database is up to date.
106              
107             =item SUCCESSFUL
108              
109             The operation was successful.
110              
111             =item MALWARE
112              
113             Name of the Malware list in Google Safe Browsing (shortcut to 'goog-malware-shavar')
114              
115             =item PHISHING
116              
117             Name of the Phishing list in Google Safe Browsing (shortcut to 'googpub-phish-shavar')
118              
119             =back
120              
121             =cut
122              
123             use constant {
124 1         228 DATABASE_RESET => -6,
125             MAC_ERROR => -5,
126             MAC_KEY_ERROR => -4,
127             INTERNAL_ERROR => -3, # internal/parsing error
128             SERVER_ERROR => -2, # Server sent an error back
129             NO_UPDATE => -1, # no update (too early)
130             NO_DATA => 0, # no data sent
131             SUCCESSFUL => 1, # data sent
132             MALWARE => 'goog-malware-shavar',
133             PHISHING => 'googpub-phish-shavar',
134             FULL_HASH_TIME => 45 * 60,
135             INTERVAL_FULL_HASH_TIME => 'INTERVAL 45 MINUTE',
136 1     1   108 };
  1         2  
137              
138              
139             =head1 CONSTRUCTOR
140              
141             =over 4
142              
143             =back
144              
145             =head2 new()
146              
147             Create a Net::Google::SafeBrowsing2 object
148              
149             my $gsb = Net::Google::SafeBrowsing2->new(
150             key => "my key",
151             storage => Net::Google::SafeBrowsing2::Sqlite->new(file => 'google-v2.db'),
152             debug => 0,
153             mac => 0,
154             list => MALWARE,
155             );
156              
157             Arguments
158              
159             =over 4
160              
161             =item server
162              
163             Safe Browsing Server. https://safebrowsing.clients.google.com/safebrowsing/ by default
164              
165             =item mac_server
166              
167             Safe Browsing MAC Server. https://sb-ssl.google.com/safebrowsing/ by default
168              
169             =item key
170              
171             Required. Your Google Safe browsing API key
172              
173             =item storage
174              
175             Required. Object which handle the storage for the Google Safe Browsing database. See L for more details.
176              
177             =item list
178              
179             Optional. The Google Safe Browsing list to handle. By default, handles both MALWARE and PHISHING.
180              
181             =item mac
182              
183             Optional. Set to 1 to enable Message Authentication Code (MAC). 0 (disabled) by default.
184              
185             =item debug
186              
187             Optional. Set to 1 to enable debugging. 0 (disabled) by default.
188              
189             The debug output maybe quite large and can slow down significantly the update and lookup functions.
190              
191             =item errors
192              
193             Optional. Set to 1 to show errors to STDOUT. 0 (disabled by default).
194              
195             =item perf
196              
197             Optional. Set to 1 to show performance information.
198              
199             =item version
200              
201             Optional. Google Safe Browsing version. 2.2 by default
202              
203             =back
204              
205             =cut
206              
207             sub new {
208 1     1 1 469 my ($class, %args) = @_;
209              
210 1         12 my $self = { # default arguments
211             server => 'https://safebrowsing.clients.google.com/safebrowsing/',
212             mac_server => 'https://sb-ssl.google.com/safebrowsing/',
213             list => ['googpub-phish-shavar', 'goog-malware-shavar'],
214             key => '',
215             version => '2.2',
216             debug => 0,
217             errors => 0,
218             last_error => '',
219             mac => 0,
220             perf => 0,
221              
222             %args,
223             };
224              
225 1 50       4 if (! exists $self->{storage}) {
226 1     1   398 use Net::Google::SafeBrowsing2::Storage;
  1         2  
  1         6920  
227 1         8 $self->{storage} = Net::Google::SafeBrowsing2::Storage->new();
228             }
229 1 50       4 if (ref $self->{list} ne 'ARRAY') {
230 0         0 $self->{list} = [$self->{list}];
231             }
232              
233 1 50       7 bless $self, $class or croak "Can't bless $class: $!";
234 1         3 return $self;
235             }
236              
237              
238             =head1 PUBLIC FUNCTIONS
239              
240             =over 4
241              
242             =back
243              
244             =head2 update()
245              
246             Perform a database update.
247              
248             $gsb->update();
249              
250             Return the status of the update (see the list of constants above): INTERNAL_ERROR, SERVER_ERROR, NO_UPDATE, NO_DATA or SUCCESSFUL
251              
252             This function can handle two lists at the same time. If one of the list should not be updated, it will automatically skip it and update the other one. It is faster to update two lists at once rather than doing them one by one.
253              
254             NOTE: If you start with an empty database, you will need to perform several updates to retrieve all the Google Safe Browsing information. This may require up to 24 hours. This is a limitation of the Google API, not of this module. See "Google Safe Browsing v2: Implementation Notes" at L.
255              
256              
257             Arguments
258              
259             =over 4
260              
261             =item list
262              
263             Optional. Update a specific list. Use the list(s) from new() by default.
264              
265             =item mac
266              
267             Optional. Set to 1 to enable Message Authentication Code (MAC). Use the value from new() by default.
268              
269             =item force
270              
271             Optional. Force the update (1). Disabled by default (0).
272              
273             Be careful if you set this option to 1 as too frequent updates might result in the blacklisting of your API key.
274              
275             =back
276              
277             =cut
278              
279             sub update {
280 0     0 1 0 my ($self, %args) = @_;
281             # my @lists = @{[$args{list}]} || @{$self->{list}} || croak "Missing list name\n";
282 0         0 my $list = $args{list};
283 0   0     0 my $force = $args{force} || 0;
284 0   0     0 my $mac = $args{mac} || $self->{mac} || 0;
285              
286              
287 0         0 my @lists = @{$self->{list}};
  0         0  
288 0 0       0 @lists = @{[$args{list}]} if (defined $list);
  0         0  
289              
290 0         0 my $result = 0;
291              
292             # Too early to update?
293 0         0 my $start = time();
294 0         0 my $i = 0;
295 0         0 while ($i < scalar @lists) {
296 0         0 my $list = $lists[$i];
297 0         0 my $info = $self->{storage}->last_update(list => $list);
298            
299 0 0 0     0 if ($info->{'time'} + $info->{'wait'} > time && $force == 0) {
300 0         0 $self->debug("Too early to update $list\n");
301 0         0 splice(@lists, $i, 1);
302             }
303             else {
304 0         0 $self->debug("OK to update $list: " . time() . "/" . ($info->{'time'} + $info->{'wait'}) . "\n");
305 0         0 $i++;
306             }
307             }
308              
309 0 0       0 if (scalar @lists == 0) {
310 0         0 $self->debug("Too early to update any list\n");
311 0         0 return NO_UPDATE;
312             }
313 0         0 $self->perf("OK to update check: " . (time() - $start) . "s\n");
314            
315             # MAC?
316 0         0 my $client_key = '';
317 0         0 my $wrapped_key = '';
318              
319 0 0       0 if ($mac) {
320 0         0 ($client_key, $wrapped_key) = $self->get_mac_keys();
321              
322 0 0 0     0 if ($client_key eq '' || $wrapped_key eq '') {
323 0         0 return MAC_KEY_ERROR;
324             }
325             }
326            
327              
328              
329 0         0 my $ua = $self->ua;
330              
331 0         0 my $url = $self->{server} . "downloads?client=api&apikey=" . $self->{key} . "&appver=$VERSION&pver=" . $self->{version};
332 0 0       0 $url .= "&wrkey=$wrapped_key" if ($mac);
333              
334 0         0 my $body = '';
335 0         0 foreach my $list (@lists) {
336             # Report existng chunks
337 0         0 $start = time();
338 0         0 my $a_range = $self->create_range(numbers => [$self->{storage}->get_add_chunks_nums(list => $list)]);
339 0         0 my $s_range = $self->create_range(numbers => [$self->{storage}->get_sub_chunks_nums(list => $list)]);
340 0         0 $self->perf("Create add and sub ranges: " . (time() - $start) . "s\n");
341            
342 0         0 my $chunks_list = '';
343 0 0       0 if ($a_range ne '') {
344 0         0 $chunks_list .= "a:$a_range";
345             }
346 0 0       0 if ($s_range ne '') {
347 0 0       0 $chunks_list .= ":" if ($a_range ne '');
348 0         0 $chunks_list .= "s:$s_range";
349             }
350              
351 0         0 $body .= "$list;$chunks_list";
352 0 0       0 $body .= ":mac" if ($mac);
353 0         0 $body .= "\n";
354             }
355              
356 0         0 my $start_req = time();
357 0         0 my $res = $ua->post($url, Content => $body);
358 0         0 $self->perf("$body\n");
359              
360             # $self->debug($res->request->as_string . "\n" . $res->as_string . "\n");
361 0 0       0 $self->debug($res->request->as_string . "\n") if ($self->{debug});
362 0 0       0 $self->debug($res->as_string . "\n") if ($self->{debug});
363 0         0 my $duration_req = time() - $start_req;
364              
365 0 0       0 if (! $res->is_success) {
366 0         0 $self->error("Request failed\n");
367              
368 0         0 foreach my $list (@lists) {
369 0         0 $self->update_error('time' => time(), list => $list);
370             }
371              
372 0         0 return SERVER_ERROR;
373             }
374              
375 0         0 my $last_update = time;
376 0         0 my $wait = 0;
377              
378 0         0 my @redirections = ();
379 0         0 my $del_add_duration = 0;
380 0         0 my $del_sub_duration = 0;
381 0         0 my $add_range_info = '';
382              
383 0         0 my @lines = split/\s/, $res->decoded_content;
384 0         0 $list = '';
385 0         0 foreach my $line (@lines) {
386 0 0 0     0 if ($line =~ /n:\s*(\d+)\s*$/) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
387 0         0 $self->debug("Next poll: $1 seconds\n");
388 0         0 $wait = $1;
389             }
390             elsif ($line =~ /i:\s*(\S+)\s*$/) {
391 0         0 $self->debug("List: $1\n");
392 0         0 $list = $1;
393             }
394             elsif ($line =~ /u:\s*(\S+),(\S+)\s*$/) {
395 0         0 $self->debug("Redirection: $1\n");
396 0         0 $self->debug("MAC: $2\n");
397 0         0 push(@redirections, [$1, $list, $2]);
398             }
399             elsif ($line =~ /u:\s*(\S+)\s*$/) {
400 0         0 $self->debug("Redirection: $1\n");
401 0         0 push(@redirections, [$1, $list, '']);
402             }
403             elsif ($line =~ /ad:(\S+)$/) {
404 0         0 $self->debug("Delete Add Chunks: $1\n");
405              
406 0         0 my $del_add_start = time();
407 0         0 $add_range_info = $1 . " $list";
408 0         0 my @nums = $self->expand_range(range => $1);
409 0         0 $self->{storage}->delete_add_ckunks(chunknums => [@nums], list => $list);
410              
411             # Delete full hash as well
412 0         0 $self->{storage}->delete_full_hashes(chunknums => [@nums], list => $list);
413 0         0 $del_add_duration = time() - $del_add_start;
414              
415 0         0 $result = 1;
416             }
417             elsif ($line =~ /sd:(\S+)$/) {
418 0         0 $self->debug("Delete Sub Chunks: $1\n");
419              
420 0         0 my $del_sub_start = time();
421 0         0 my @nums = $self->expand_range(range => $1);
422 0         0 $self->{storage}->delete_sub_ckunks(chunknums => [@nums], list => $list);
423 0         0 $del_add_duration = time() - $del_sub_start;
424              
425 0         0 $result = 1;
426             }
427             elsif ($line =~ /m:(\S+)$/ && $mac) {
428 0         0 my $hmac = $1;
429 0         0 $self->debug("MAC of request: $hmac\n");
430              
431             # Remove this line for data
432 0         0 my $data = $res->decoded_content;
433 0         0 $data =~ s/^m:(\S+)\n//g;
434              
435 0 0       0 if (! $self->validate_data_mac(data => $data, key => $client_key, digest => $hmac) ) {
436 0         0 $self->error("MAC error on main request\n");
437              
438 0         0 return MAC_ERROR;
439             }
440             }
441             elsif ($line =~ /e:pleaserekey/ && $mac) {
442 0         0 $self->debug("MAC key has been expired\n");
443              
444 0         0 $self->{storage}->delete_mac_keys();
445 0         0 return $self->update(list => $list, force => $force, mac => $mac);
446             }
447             elsif ($line =~ /r:pleasereset/) {
448 0         0 $self->debug("Database must be reset\n");
449              
450 0         0 $self->{storage}->reset(list => $list);
451              
452 0         0 return DATABASE_RESET;
453             }
454             }
455 0         0 $self->debug("\n");
456 0         0 $self->perf("Handle first request: " . (time() - $last_update) . "s (POST: ${duration_req}s, DEL add: ${del_add_duration}s, DEL sub: ${del_sub_duration}s, ADD range: ${add_range_info})\n");
457              
458 0 0       0 $result = 1 if (scalar @redirections > 0);
459              
460 0         0 $self->perf("Parse redirections: ");
461 0         0 foreach my $data (@redirections) {
462 0         0 $start = time();
463 0         0 my $redirection = $data->[0];
464 0         0 $list = $data->[1];
465 0         0 my $hmac = $data->[2];
466              
467 0         0 $self->debug("Checking redirection https://$redirection ($list)\n");
468 0         0 $res = $ua->get("https://$redirection");
469 0 0       0 if (! $res->is_success) {
470 0         0 $self->error("Request to $redirection failed\n");
471              
472 0         0 foreach my $list (@lists) {
473 0         0 $self->update_error('time' => $last_update, list => $list);
474             }
475              
476 0         0 return SERVER_ERROR;
477             }
478            
479 0 0       0 $self->debug(substr($res->as_string, 0, 250) . "\n\n") if ($self->{debug});
480 0 0       0 $self->debug(substr($res->content, 0, 250) . "\n\n") if ($self->{debug});
481            
482 0         0 my $data = $res->content;
483 0 0 0     0 if ($mac && ! $self->validate_data_mac(data => $data, key => $client_key, digest => $hmac) ) {
484 0         0 $self->error("MAC error on redirection\n");
485 0         0 $self->debug("Length of data: " . length($data) . "\n");
486              
487 0         0 return MAC_ERROR;
488             }
489              
490 0         0 my $result = $self->parse_data(data => $data, list => $list);
491 0 0       0 if ($result != SUCCESSFUL) {
492 0         0 foreach my $list (@lists) {
493 0         0 $self->update_error('time' => $last_update, list => $list);
494             }
495              
496 0         0 return $result;
497             }
498 0         0 $self->perf((time() - $start) . "s ");
499             }
500 0         0 $self->perf("\n");
501              
502 0         0 foreach my $list (@lists) {
503 0         0 $self->debug("List update: $last_update $wait $list\n");
504 0         0 $self->{storage}->updated('time' => $last_update, 'wait' => $wait, list => $list);
505             }
506              
507 0         0 return $result; # ok
508             }
509              
510             =head2 import_chunks()
511              
512             Import add and sub chunks from a file.
513              
514             my $result = $gsb->import_chunks(list => MALWARE, file => 'malware.dat');
515              
516             Return the status of the import: INTERNAL_ERROR or SUCCESSFUL.
517              
518             This function should be used to initialize an empty back-end storage.
519              
520              
521             Arguments
522              
523             =over 4
524              
525             =item list
526              
527             Required. Google list to use.
528              
529             =item file
530              
531             Required. File that contains the list of chunks. This file can be created with the C function inherited from C.
532              
533             =back
534              
535             =cut
536              
537             sub import_chunks {
538 0     0 1 0 my ($self, %args) = @_;
539 0   0     0 my $list = $args{list} || '';
540 0   0     0 my $file = $args{file} || "$list.dat";
541              
542 0         0 my $data = read_file($file, { binmode => ':raw' });
543              
544 0         0 return $self->parse_data(data => $data, list => $list);
545              
546             }
547              
548             =head2 lookup()
549              
550             Lookup a URL against the Google Safe Browsing database.
551              
552             my $match = $gsb->lookup(url => 'http://www.gumblar.cn');
553              
554             Returns the name of the list if there is any match, returns an empty string otherwise.
555              
556             Arguments
557              
558             =over 4
559              
560             =item list
561              
562             Optional. Lookup against a specific list. Use the list(s) from new() by default.
563              
564             =item url
565              
566             Required. URL to lookup.
567              
568             =back
569              
570             =cut
571              
572             sub lookup {
573 0     0 1 0 my ($self, %args) = @_;
574 0   0     0 my $list = $args{list} || '';
575 0   0     0 my $url = $args{url} || return '';
576              
577 0         0 my @lists = @{$self->{list}};
  0         0  
578 0 0       0 @lists = @{[$args{list}]} if ($list ne '');
  0         0  
579              
580              
581             # TODO: create our own URI management for canonicalization
582             # fix for http:///foo.com (3 ///)
583 0         0 $url =~ s/^(https?:\/\/)\/+/$1/;
584              
585              
586              
587 0         0 my $uri = URI->new($url)->canonical;
588              
589 0         0 my $domain = $uri->host;
590            
591 0         0 my @hosts = $self->canonical_domain_suffixes($domain); # only top-3 in this case
592              
593 0         0 foreach my $host (@hosts) {
594 0         0 $self->debug("Domain for key: $domain => $host\n");
595 0         0 my $suffix = $self->prefix("$host/"); # Don't forget trailing hash
596 0         0 $self->debug("Host key: " . $self->hex_to_ascii($suffix) . "\n");
597              
598 0         0 my $match = $self->lookup_suffix(lists => [@lists], url => $url, suffix => $suffix);
599 0 0       0 return $match if ($match ne '');
600             }
601              
602 0         0 return '';
603             }
604              
605              
606              
607             =head2 get_lists()
608              
609             Returns the name of all the Google Safe Browsing lists
610              
611             my $@lists = $gsb->get_lists();
612              
613             NOTE: this function is useless in practice because Google includes some lists which cannot be used by the Google Safe Browsing API, like lists used by the Google toolbar.
614              
615             =cut
616              
617             sub get_lists {
618 0     0 1 0 my ($self, %args) = @_;
619              
620 0         0 my $url = $self->{server} . "list?client=api&apikey=" . $self->{key} . "&appver=$VERSION&pver=" . $self->{version};
621              
622 0         0 my $res = $self->ua->get($url);
623              
624 0         0 return split/\s/, $res->decoded_content; # 1 list per line
625             }
626              
627              
628             =head2 last_error()
629              
630             Get/Set the last error message.
631              
632             print "Last error: ", $gsb->last_error(), "\n";
633             $gsb->last_error(''); # Reset last error
634              
635             NOTE: the last error message might not come from the last call. Returns an empty string if no errors.
636              
637             =cut
638              
639             sub last_error {
640 0     0 1 0 my ($self, $message) = @_;
641              
642 0 0       0 if (defined $message) {
643 0         0 $self->{last_error} = $message;
644             }
645             else {
646 0         0 return $self->{last_error};
647             }
648             }
649              
650              
651             =pod
652              
653             =head1 PRIVATE FUNCTIONS
654              
655             These functions are not intended to be used externally.
656              
657             =over 4
658              
659             =back
660              
661             =head2 lookup_suffix()
662              
663             Lookup a host prefix.
664              
665             =cut
666              
667             sub lookup_suffix {
668 0     0 1 0 my ($self, %args) = @_;
669 0   0     0 my $lists = $args{lists} || croak "Missing lists\n";
670 0   0     0 my $url = $args{url} || return '';
671 0   0     0 my $suffix = $args{suffix} || return '';
672              
673             # Calculate prefixes
674 0         0 my @full_hashes = $self->full_hashes($url); # Get the prefixes from the first 4 bytes
675 0         0 my @full_hashes_prefix = map (substr($_, 0, 4), @full_hashes);
676              
677             # Local lookup
678 0         0 my @add_chunks = $self->local_lookup_suffix(lists => $lists, url => $url, suffix => $suffix, full_hashes_prefix => [@full_hashes_prefix]);
679 0 0       0 if (scalar @add_chunks == 0) {
680 0         0 $self->debug("No hit in local lookup\n");
681 0         0 return '';
682             }
683              
684              
685             # Check against full hashes
686 0         0 my $found = '';
687              
688             # get stored full hashes
689 0         0 foreach my $add_chunk (@add_chunks) {
690            
691 0         0 my @hashes = $self->{storage}->get_full_hashes( chunknum => $add_chunk->{chunknum}, timestamp => time() - FULL_HASH_TIME, list => $add_chunk->{list});
692              
693 0         0 $self->debug("Full hashes already stored for chunk " . $add_chunk->{chunknum} . ": " . scalar @hashes . "\n");
694 0         0 foreach my $full_hash (@full_hashes) {
695 0         0 foreach my $hash (@hashes) {
696 0 0 0 0   0 if ($hash eq $full_hash && defined first { $add_chunk->{list} eq $_ } @$lists) {
  0         0  
697 0         0 $self->debug("Full hash was found in storage: " . $self->hex_to_ascii($hash) . "\n");
698 0         0 $found = $add_chunk->{list};
699 0         0 last;
700             }
701             # elsif ($hash ne $full_hash) {
702             # $self->debug($self->hex_to_ascii($hash) . " ne " . $self->hex_to_ascii($full_hash) . "\n\n");
703             # }
704             }
705 0 0       0 last if ($found ne '');
706             }
707 0 0       0 last if ($found ne '');
708             }
709              
710 0 0       0 return $found if ($found ne '');
711              
712              
713             # ask for new hashes
714             # TODO: make sure we don't keep asking for the same over and over
715 0   0     0 my @hashes = $self->request_full_hash(prefixes => [ map($_->{prefix} || $_->{hostkey}, @add_chunks) ]);
716 0         0 $self->{storage}->add_full_hashes(full_hashes => [@hashes], timestamp => time());
717              
718 0         0 foreach my $full_hash (@full_hashes) {
719 0     0   0 my $hash = first { $_->{hash} eq $full_hash} @hashes;
  0         0  
720 0 0       0 next if (! defined $hash);
721              
722 0     0   0 my $list = first { $hash->{list} eq $_ } @$lists;
  0         0  
723              
724 0 0 0     0 if (defined $hash && defined $list) {
725             # $self->debug($self->hex_to_ascii($hash->{hash}) . " eq " . $self->hex_to_ascii($full_hash) . "\n\n");
726              
727 0         0 $self->debug("Match: " . $self->hex_to_ascii($full_hash) . "\n");
728              
729 0         0 return $hash->{list};
730             }
731             # elsif (defined $hash) {
732             # $self->debug("hash: " . $self->hex_to_ascii($hash->{hash}) . "\n");
733             # $self->debug("list: " . $hash->{list} . "\n");
734             # }
735             }
736            
737 0         0 $self->debug("No match\n");
738 0         0 return '';
739             }
740              
741             =head2 local_lookup_suffix()
742              
743             Lookup a host prefix in the local database only.
744              
745             =cut
746             sub local_lookup_suffix {
747 0     0 1 0 my ($self, %args) = @_;
748 0   0     0 my $lists = $args{lists} || croak "Missing lists\n";
749 0   0     0 my $url = $args{url} || return ();
750 0   0     0 my $suffix = $args{suffix} || return ();
751 0   0     0 my $full_hashe_list = $args{full_hashes} || [];
752 0   0     0 my $full_hashes_prefix_list = $args{full_hashes_prefix} || [];
753              
754              
755             # Step 1: get all add chunks for this host key
756             # Do it for all lists
757 0         0 my @add_chunks = $self->{storage}->get_add_chunks(hostkey => $suffix);
758             # return scalar @add_chunks;
759 0 0       0 if (scalar @add_chunks == 0) { # no match
760 0         0 $self->debug("No host key\n");
761 0         0 return @add_chunks;
762             }
763              
764             # Step 2: calculate prefixes if not provided
765             # Get the prefixes from the first 4 bytes
766 0         0 my @full_hashes_prefix = @{$full_hashes_prefix_list};
  0         0  
767 0 0       0 if (scalar @full_hashes_prefix == 0) {
768 0         0 my @full_hashes = @{$full_hashe_list};
  0         0  
769 0 0       0 @full_hashes = $self->full_hashes($url) if (scalar @full_hashes == 0);
770              
771 0         0 @full_hashes_prefix = map (substr($_, 0, 4), @full_hashes);
772             }
773              
774             # Step 3: filter out add_chunks with prefix
775 0         0 my $i = 0;
776 0         0 while ($i < scalar @add_chunks) {
777 0 0       0 if ($add_chunks[$i]->{prefix} ne '') {
778 0         0 my $found = 0;
779 0         0 foreach my $hash_prefix (@full_hashes_prefix) {
780 0 0       0 if ( $add_chunks[$i]->{prefix} eq $hash_prefix) {
781 0         0 $found = 1;
782 0         0 last;
783             }
784             # else {
785             # $self->debug( $self->hex_to_ascii($add_chunks[$i]->{prefix}) . " ne " . $self->hex_to_ascii($hash_prefix) . "\n" );
786             # }
787             }
788              
789 0 0       0 if ($found == 0) {
790 0         0 $self->debug("No prefix found\n");
791 0         0 splice(@add_chunks, $i, 1);
792             }
793             else {
794 0         0 $i++;
795             }
796             }
797             else {
798 0         0 $i++;
799             }
800             }
801 0 0       0 if (scalar @add_chunks == 0) {
802 0         0 $self->debug("No prefix match for any host key\n");
803 0         0 return @add_chunks;
804             }
805              
806              
807             # Step 4: get all sub chunks for this host key
808 0         0 my @sub_chunks = $self->{storage}->get_sub_chunks(hostkey => $suffix);
809              
810 0         0 foreach my $sub_chunk (@sub_chunks) {
811 0         0 my $i = 0;
812 0         0 while ($i < scalar @add_chunks) {
813 0         0 my $add_chunk = $add_chunks[$i];
814              
815 0 0 0     0 if ($add_chunk->{chunknum} != $sub_chunk->{addchunknum} || $add_chunk->{list} ne $sub_chunk->{list}) {
816 0         0 $i++;
817 0         0 next;
818             }
819              
820 0 0       0 if ($sub_chunk->{prefix} eq $add_chunk->{prefix}) {
821 0         0 splice(@add_chunks, $i, 1);
822             }
823             else {
824 0         0 $i++;
825             }
826             }
827             }
828              
829 0 0       0 if (scalar @add_chunks == 0) {
830 0         0 $self->debug("All add_chunks have been removed by sub_chunks\n");
831             }
832              
833 0         0 return @add_chunks;
834             }
835              
836             =head2 local_lookup()
837              
838             Lookup a URL against the local Google Safe Browsing database URL. This should be used for debugging purpose only. See the lookup for normal use.
839              
840             my $match = $gsb->local_lookup(url => 'http://www.gumblar.cn');
841              
842             Returns the name of the list if there is any match, returns an empty string otherwise.
843              
844             Arguments
845              
846             =over 4
847              
848             =item list
849              
850             Optional. Lookup against a specific list. Use the list(s) from new() by default.
851              
852             =item url
853              
854             Required. URL to lookup.
855              
856             =back
857              
858             =cut
859             sub local_lookup {
860 0     0 1 0 my ($self, %args) = @_;
861 0   0     0 my $list = $args{list} || '';
862 0   0     0 my $url = $args{url} || return '';
863              
864 0         0 my @lists = @{$self->{list}};
  0         0  
865 0 0       0 @lists = @{[$args{list}]} if ($list ne '');
  0         0  
866              
867              
868             # TODO: create our own URI management for canonicalization
869             # fix for http:///foo.com (3 ///)
870 0         0 $url =~ s/^(https?:\/\/)\/+/$1/;
871              
872              
873              
874 0         0 my $uri = URI->new($url)->canonical;
875              
876 0         0 my $domain = $uri->host;
877            
878 0         0 my @hosts = $self->canonical_domain_suffixes($domain); # only top-3 in this case
879              
880 0         0 foreach my $host (@hosts) {
881 0         0 $self->debug("Domain for key: $domain => $host\n");
882 0         0 my $suffix = $self->prefix("$host/"); # Don't forget trailing hash
883 0         0 $self->debug("Host key: " . $self->hex_to_ascii($suffix) . "\n");
884              
885 0         0 my @matches = $self->local_lookup_suffix(lists => [@lists], url => $url, suffix => $suffix);
886             # return $matches[0]->{list} if (scalar @matches > 0);
887 0 0       0 return $matches[0]->{list} . " " . $matches[0]->{chunknum} if (scalar @matches > 0);
888             }
889              
890 0         0 return '';
891              
892             }
893              
894             =head2 request_key()
895              
896             Request the Message Authentication Code (MAC) keys
897              
898             =cut
899              
900             sub get_mac_keys {
901 0     0 0 0 my ($self, %args) = @_;
902              
903 0         0 my $keys = $self->{storage}->get_mac_keys();
904              
905 0 0 0     0 if ($keys->{client_key} eq '' || $keys->{wrapped_key} eq '') {
906 0         0 my ($client_key, $wrapped_key) = $self->request_mac_keys();
907              
908             # $self->debug("Client key: $client_key\n");
909 0         0 $self->{storage}->add_mac_keys(client_key => $client_key, wrapped_key => $wrapped_key);
910              
911 0         0 return ($client_key, $wrapped_key);
912             }
913              
914 0         0 return ($keys->{client_key}, $keys->{wrapped_key});
915             }
916              
917              
918             =head2 request_mac_keys()
919              
920             Request the Message Authentication Code (MAC) keys from Google.
921              
922             =cut
923              
924             sub request_mac_keys {
925 0     0 1 0 my ($self, %args) = @_;
926              
927 0         0 my $client_key = '';
928 0         0 my $wrapped_key = '';
929              
930 0         0 my $url = $self->{mac_server} . "newkey?client=api&apikey=" . $self->{key} . "&appver=$VERSION&pver=" . $self->{version};
931              
932 0         0 my $res = $self->ua->get($url);
933              
934 0 0       0 if (! $res->is_success) {
935 0         0 $self->error("Key request failed: " . $res->code . "\n");
936 0         0 return ($client_key, $wrapped_key);
937             }
938              
939            
940              
941 0         0 my $data = $res->decoded_content;
942 0 0       0 if ($data =~ s/^clientkey:(\d+)://mi) {
943 0         0 my $length = $1;
944 0         0 $self->debug("MAC client key length: $length\n");
945 0         0 $client_key = substr($data, 0, $length, '');
946 0         0 $self->debug("MAC client key: $client_key\n");
947              
948 0         0 substr($data, 0, 1, ''); # remove \n
949              
950 0 0       0 if ($data =~ s/^wrappedkey:(\d+)://mi) {
951 0         0 $length = $1;
952 0         0 $self->debug("MAC wrapped key length: $length\n");
953 0         0 $wrapped_key = substr($data, 0, $length, '');
954 0         0 $self->debug("MAC wrapped key: $wrapped_key\n");
955              
956 0         0 return (decode_base64($client_key), $wrapped_key);
957             }
958             else {
959 0         0 return ('', '');
960             }
961             }
962              
963 0         0 return ($client_key, $wrapped_key);
964             }
965              
966             =head2 validate_data_mac()
967              
968             Validate data against the MAC keys.
969              
970             =cut
971              
972             sub validate_data_mac {
973 0     0 1 0 my ($self, %args) = @_;
974 0   0     0 my $data = $args{data} || '';
975 0   0     0 my $key = $args{key} || '';
976 0   0     0 my $digest = $args{digest} || '';
977              
978              
979             # my $hash = urlsafe_b64encode trim hmac_sha1($data, decode_base64($key));
980             # my $hash = urlsafe_b64encode (trim (hmac_sha1($data, decode_base64($key))));
981 0         0 my $hash = urlsafe_b64encode(hmac_sha1($data, $key));
982 0         0 $hash .= '=';
983              
984 0         0 $self->debug("$hash / $digest\n");
985             # $self->debug(urlsafe_b64encode(hmac_sha1($data, decode_base64($key))) . "\n");
986             # $self->debug(urlsafe_b64encode(trim(hmac_sha1($data, decode_base64($key)))) . "\n");
987              
988 0         0 return ($hash eq $digest);
989             }
990              
991             =head2 update_error()
992              
993             Handle server errors during a database update.
994              
995             =cut
996              
997             sub update_error {
998 0     0 1 0 my ($self, %args) = @_;
999 0   0     0 my $time = $args{'time'} || time;
1000 0   0     0 my $list = $args{'list'} || '';
1001              
1002 0         0 my $info = $self->{storage}->last_update(list => $list);
1003 0 0       0 $info->{errors} = 0 if (! exists $info->{errors});
1004 0         0 my $errors = $info->{errors} + 1;
1005 0         0 my $wait = 0;
1006              
1007 0 0       0 $wait = $errors == 1 ? 60
    0          
    0          
    0          
    0          
    0          
1008             : $errors == 2 ? int(30 * 60 * (rand(1) + 1)) # 30-60 mins
1009             : $errors == 3 ? int(60 * 60 * (rand(1) + 1)) # 60-120 mins
1010             : $errors == 4 ? int(2 * 60 * 60 * (rand(1) + 1)) # 120-240 mins
1011             : $errors == 5 ? int(4 * 60 * 60 * (rand(1) + 1)) # 240-480 mins
1012             : $errors > 5 ? 480 * 60
1013             : 0;
1014              
1015 0         0 $self->{storage}->update_error('time' => $time, list => $list, 'wait' => $wait, errors => $errors);
1016              
1017             }
1018              
1019              
1020             =head2 lookup_whitelist()
1021              
1022             Lookup a host prefix and suffix in the whitelist (s chunks)
1023              
1024             =cut
1025              
1026             sub lookup_whitelist {
1027 0     0 1 0 my ($self, %args) = @_;
1028 0   0     0 my $suffix = $args{suffix} || return 0;
1029 0   0     0 my $prefix = $args{prefix} || '';
1030 0   0     0 my $chuknum = $args{chunknum} || return 0;
1031              
1032              
1033 0         0 foreach my $schunknum (keys %{ $self->{s_chunks} }) {
  0         0  
1034 0         0 foreach my $chunk ( @{ $self->{s_chunks}->{$schunknum} }) {
  0         0  
1035 0 0 0     0 if ($chunk->{host} eq $suffix && ($chunk->{prefix} eq $prefix || $chunk->{prefix} eq '') && $chunk->{add_chunknum} == $chuknum) {
      0        
      0        
1036 0         0 return 1;
1037             }
1038             }
1039             }
1040              
1041 0         0 return 0;
1042             }
1043              
1044              
1045             =head2 ua()
1046              
1047             Create LWP::UserAgent to make HTTP requests to Google.
1048              
1049             =cut
1050              
1051             sub ua {
1052 0     0 1 0 my ($self, %args) = @_;
1053              
1054 0 0       0 if (! exists $self->{ua}) {
1055 0         0 my $ua = LWP::UserAgent->new;
1056 0         0 $ua->timeout(60);
1057              
1058 0         0 $self->{ua} = $ua;
1059             }
1060              
1061 0         0 return $self->{ua};
1062             }
1063              
1064              
1065             =head2 parse_data()
1066              
1067             Parse data from a rediration (add and sub chunk information).
1068              
1069             =cut
1070              
1071             sub parse_data {
1072 0     0 1 0 my ($self, %args) = @_;
1073 0   0     0 my $data = $args{data} || '';
1074 0   0     0 my $list = $args{list} || '';
1075              
1076 0         0 my $chunk_num = 0;
1077 0         0 my $hash_length = 0;
1078 0         0 my $chunk_length = 0;
1079              
1080 0         0 while (length $data > 0) {
1081             # print "Length 1: ", length $data, "\n"; # 58748
1082            
1083 0         0 my $type = substr($data, 0, 2, ''); # s:34321:4:137
1084             # print "Length 1.5: ", length $data, "\n"; # 58746 -2
1085            
1086 0 0       0 if ($data =~ /^(\d+):(\d+):(\d+)\n/sgi) {
1087 0         0 $chunk_num = $1;
1088 0         0 $hash_length = $2;
1089 0         0 $chunk_length = $3;
1090            
1091             # shorten data
1092 0         0 substr($data, 0, length($chunk_num) + length($hash_length) + length($chunk_length) + 3, '');
1093             # print "Remove ", length($chunk_num) + length($hash_length) + length($chunk_length) + 3, "\n";
1094             # print "Length 2: ", length $data, "\n"; # 58741 -5
1095            
1096 0         0 my $encoded = substr($data, 0, $chunk_length, '');
1097             # print "Length 3: ", length $data, "\n"; # 58604 -137
1098            
1099 0 0       0 if ($type eq 's:') {
    0          
1100 0         0 my @chunks = $self->parse_s(value => $encoded, hash_length => $hash_length);
1101              
1102 0         0 $self->{storage}->add_chunks(type => 's', chunknum => $chunk_num, chunks => [@chunks], list => $list); # Must happen all at once => not 100% sure
1103             }
1104             elsif ($type eq 'a:') {
1105 0         0 my @chunks = $self->parse_a(value => $encoded, hash_length => $hash_length);
1106 0         0 $self->{storage}->add_chunks(type => 'a', chunknum => $chunk_num, chunks => [@chunks], list => $list); # Must happen all at once => not 100% sure
1107             }
1108             else {
1109 0         0 $self->error("Incorrect chunk type: $type, should be a: or s:\n");
1110 0         0 return INTERNAL_ERROR;# failed
1111             }
1112            
1113 0         0 $self->debug("$type$chunk_num:$hash_length:$chunk_length OK\n");
1114            
1115             }
1116             else {
1117 0         0 $self->error("could not parse header\n");
1118 0         0 return INTERNAL_ERROR;# failed
1119             }
1120             }
1121              
1122 0         0 return SUCCESSFUL;
1123             }
1124              
1125              
1126             =head2 parse_s()
1127              
1128             Parse s chunks information for a database update.
1129              
1130             =cut
1131              
1132             sub parse_s {
1133 0     0 1 0 my ($self, %args) = @_;
1134 0   0     0 my $value = $args{value} || return ();
1135 0   0     0 my $hash_length = $args{hash_length} || 4;
1136              
1137 0         0 my @data = ();
1138              
1139              
1140 0         0 while (length $value > 0) {
1141             # my $host = $self->hex_to_ascii( substr($value, 0, 4, '') ); # Host hash
1142 0         0 my $host = substr($value, 0, 4, ''); # HEX
1143             # print "\t Host key: $host\n";
1144              
1145 0         0 my $count = substr($value, 0, 1, ''); # hex value
1146 0         0 $count = ord($count);
1147              
1148             # my $add_chunk_num_hex;
1149              
1150 0 0       0 if ($count == 0) { # ADDCHUNKNUM only
1151             # $self->debug("\nadd_chuknum: " . substr($value, 0, 4) . " => ");
1152 0         0 my $add_chunknum = hex($self->hex_to_ascii( substr($value, 0, 4, '') ) ); #chunk num
1153             # $self->debug("$add_chunknum\n");
1154              
1155 0         0 push(@data, { host => $host, add_chunknum => $add_chunknum, prefix => '' });
1156              
1157 0 0       0 if ($self->{debug}) {
1158 0         0 $self->debug("\t" . $self->hex_to_ascii($host) . " $add_chunknum\n");
1159             }
1160             }
1161             else { # ADDCHUNKNUM + PREFIX
1162 0         0 for(my $i = 0; $i < $count; $i++) {
1163             # my $add_chunknum = $self->hex_to_ascii( substr($value, 0, 4, '') ); #chunk num - ACII
1164             # $self->debug("\nadd_chuknum: " . substr($value, 0, 4) . " => ");
1165 0         0 my $add_chunknum = hex($self->hex_to_ascii( substr($value, 0, 4, '') )); # DEC
1166             # $self->debug("$add_chunknum\n");
1167              
1168             # my $prefix = $self->hex_to_ascii( substr($value, 0, $hash_length, '') ); # ASCII
1169 0         0 my $prefix = substr($value, 0, $hash_length, ''); # HEX
1170              
1171 0         0 push(@data, { host => $host, add_chunknum => $add_chunknum, prefix => $prefix });
1172              
1173 0 0       0 if ($self->{debug}) {
1174 0         0 $self->debug("\t" . $self->hex_to_ascii($host) . " $add_chunknum " . $self->hex_to_ascii($prefix) . "\n");
1175             }
1176             }
1177             }
1178             }
1179              
1180 0         0 return @data;
1181             }
1182              
1183              
1184             =head2 parse_a()
1185              
1186             Parse a chunks information for a database update.
1187              
1188             =cut
1189              
1190             sub parse_a {
1191 0     0 1 0 my ($self, %args) = @_;
1192 0   0     0 my $value = $args{value} || return ();
1193 0   0     0 my $hash_length = $args{hash_length} || 4;
1194              
1195 0         0 my @data = ();
1196              
1197              
1198 0         0 while (length $value > 0) {
1199             # my $host = $self->hex_to_ascii( substr($value, 0, 4, '') ); # Host hash
1200 0         0 my $host = substr($value, 0, 4, ''); # HEX
1201             # print "\t Host key: $host\n";
1202              
1203 0         0 my $count = substr($value, 0, 1, ''); # hex value
1204 0         0 $count = ord($count);
1205              
1206              
1207 0 0       0 if ($count > 0) { # ADDCHUNKNUM only
1208 0         0 for(my $i = 0; $i < $count; $i++) {
1209             # my $prefix = $self->hex_to_ascii( substr($value, 0, $hash_length, '') ); # ASCII
1210 0         0 my $prefix = substr($value, 0, $hash_length, ''); # HEX
1211              
1212 0         0 push(@data, { host => $host, prefix => $prefix });
1213              
1214 0 0       0 if ($self->{debug}) {
1215 0         0 $self->debug("\t" . $self->hex_to_ascii($host) . " " . $self->hex_to_ascii($prefix) . "\n");
1216             }
1217             }
1218             }
1219             else {
1220 0         0 push(@data, { host => $host, prefix => '' });
1221              
1222 0 0       0 if ($self->{debug}) {
1223 0         0 $self->debug("\t" . $self->hex_to_ascii($host) . "\n");
1224             }
1225             }
1226             }
1227              
1228 0         0 return @data;
1229             }
1230              
1231              
1232             =head2 hex_to_ascii()
1233              
1234             Transform hexadecimal strings to printable ASCII strings. Used mainly for debugging.
1235              
1236             print $gsb->hex_to_ascii('hex value');
1237              
1238             =cut
1239              
1240             sub hex_to_ascii {
1241 2     2 1 7 my ($self, $hex) = @_;
1242              
1243 2         6 return String::HexConvert::ascii_to_hex($hex);
1244             # my $ascii = '';
1245             #
1246             # while (length $hex > 0) {
1247             # $ascii .= sprintf("%02x", ord( substr($hex, 0, 1, '') ) );
1248             # }
1249             #
1250             # return $ascii;
1251             }
1252              
1253              
1254             =head2 ascii_to_hex()
1255              
1256             Transform ASCII strings to hexadecimal strings.
1257              
1258             =cut
1259              
1260             sub ascii_to_hex {
1261 4     4 1 305 my ($self, $ascii) = @_;
1262              
1263 4         8 my $hex = '';
1264 4         24 for (my $i = 0; $i < int(length($ascii) / 2); $i++) {
1265 16         47 $hex .= chr hex( substr($ascii, $i * 2, 2) );
1266             }
1267              
1268 4         21 return $hex;
1269             }
1270              
1271             =head2 debug()
1272              
1273             Print debug output.
1274              
1275             =cut
1276              
1277             sub debug {
1278 0     0 1 0 my ($self, $message) = @_;
1279              
1280 0 0       0 print $message if ($self->{debug} > 0);
1281             }
1282              
1283              
1284             =head2 error()
1285              
1286             Print error message.
1287              
1288             =cut
1289              
1290             sub error {
1291 0     0 1 0 my ($self, $message) = @_;
1292              
1293 0 0 0     0 print "ERROR - ", $message if ($self->{debug} > 0 || $self->{errors} > 0);
1294 0         0 $self->{last_error} = $message;
1295             }
1296              
1297              
1298             =head2 error()
1299              
1300             Print performance message.
1301              
1302             =cut
1303              
1304             sub perf {
1305 0     0 1 0 my ($self, $message) = @_;
1306              
1307 0 0       0 print $message if ($self->{perf} > 0);
1308             }
1309              
1310             =head2 canonical_domain_suffixes()
1311              
1312             Find all suffixes for a domain.
1313              
1314             =cut
1315              
1316             sub canonical_domain_suffixes {
1317 3     3 1 3857 my ($self, $domain) = @_;
1318              
1319 3         5 my @domains = ();
1320              
1321 3 50       12 if ($domain =~ /^\d+\.\d+\.\d+\.\d+$/) { # loose check for IP address, should be enough
1322 0         0 return ($domain);
1323             }
1324              
1325 3         10 my @parts = split/\./, $domain; # take 3 components
1326 3 100       9 if (scalar @parts >= 3) {
1327 2         6 @parts = splice (@parts, -3, 3);
1328              
1329 2         7 push(@domains, join('.', @parts));
1330              
1331 2         5 splice(@parts, 0, 1);
1332             }
1333              
1334 3         6 push(@domains, join('.', @parts));
1335              
1336 3         11 return @domains;
1337             }
1338              
1339              
1340             =head2 canonical_domain()
1341              
1342             Find all canonical domains a domain.
1343              
1344             =cut
1345              
1346             sub canonical_domain {
1347 3     3 1 72 my ($self, $domain) = @_;
1348              
1349 3         6 my @domains = ($domain);
1350              
1351              
1352 3 50       16 if ($domain =~ /^\d+\.\d+\.\d+\.\d+$/) { # loose check for IP address, should be enough
1353 0         0 return @domains;
1354             }
1355              
1356 3         13 my @parts = split/\./, $domain;
1357 3         7 splice(@parts, 0, -6); # take 5 top most compoments
1358              
1359              
1360 3         10 while (scalar @parts > 2) {
1361 6         8 shift @parts;
1362 6         31 push(@domains, join(".", @parts) );
1363             }
1364              
1365 3         26 return @domains;
1366             }
1367              
1368             =head2 canonical_path()
1369              
1370             Find all canonical paths for a URL.
1371              
1372             =cut
1373              
1374             sub canonical_path {
1375 3     3 1 43 my ($self, $path) = @_;
1376              
1377 3         5 my @paths = ($path); # return full path
1378            
1379 3 100       9 if ($path =~ /\?/) {
1380 1         5 $path =~ s/\?.*$//;
1381              
1382 1         1 push(@paths, $path);
1383             }
1384              
1385 3         9 my @parts = split /\//, $path;
1386 3         7 my $previous = '';
1387 3   66     20 while (scalar @parts > 1 && scalar @paths < 6) {
1388 3         5 my $val = shift(@parts);
1389 3         5 $previous .= "$val/";
1390              
1391 3         10 push(@paths, $previous);
1392             }
1393            
1394 3         10 return @paths;
1395             }
1396              
1397             =head2 canonical()
1398              
1399             Find all canonical URLs for a URL.
1400              
1401             =cut
1402              
1403             sub canonical {
1404 3     3 1 11400 my ($self, $url) = @_;
1405              
1406 3         7 my @urls = ();
1407              
1408             # my $uri = URI->new($url)->canonical;
1409 3         8 my $uri = $self->canonical_uri($url);
1410 3         187 my @domains = $self->canonical_domain($uri->host);
1411 3         20 my @paths = $self->canonical_path($uri->path_query);
1412              
1413 3         8 foreach my $domain (@domains) {
1414 9         9 foreach my $path (@paths) {
1415 20         61 push(@urls, "$domain$path");
1416             }
1417             }
1418              
1419 3         24 return @urls;
1420             }
1421              
1422              
1423             =head2 canonical_uri()
1424              
1425             Create a canonical URI.
1426              
1427             NOTE: URI cannot handle all the test cases provided by Google. This method is a hack to pass most of the test. A few tests are still failing. The proper way to handle URL canonicalization according to Google would be to create a new module to handle URLs. However, I believe most real-life cases are handled correctly by this function.
1428              
1429             =cut
1430              
1431             sub canonical_uri {
1432 39     39 1 19547 my ($self, $url) = @_;
1433              
1434 39         103 $url = trim $url;
1435              
1436             # Special case for \t \r \n
1437 39         841 while ($url =~ s/^([^?]+)[\r\t\n]/$1/sgi) { }
1438              
1439 39         141 my $uri = URI->new($url)->canonical; # does not deal with directory traversing
1440              
1441             # $self->debug("0. $url => " . $uri->as_string . "\n");
1442              
1443            
1444 39 100 66     15306 if (! $uri->scheme() || $uri->scheme() eq '') {
1445 3         29 $uri = URI->new("http://$url")->canonical;
1446             }
1447              
1448 39         1243 $uri->fragment('');
1449              
1450 39         421 my $escape = $uri->as_string;
1451              
1452             # Reduce double // to single / in path
1453 39         272 while ($escape =~ s/^([a-z]+:\/\/[^?]+)\/\//$1\//sgi) { }
1454              
1455              
1456             # Remove empty fragment
1457 39         105 $escape =~ s/#$//;
1458              
1459             # canonial does not handle ../
1460             # $self->debug("\t$escape\n");
1461 39         110 while($escape =~ s/([^\/])\/([^\/]+)\/\.\.([\/?].*)$/$1$3/gi) { }
1462 39         123 while($escape =~ s/([^\/])\/([^\/]+)\/\.\.$/$1/gi) { }
1463              
1464             # May have removed ending /
1465             # $self->debug("\t$escape\n");
1466 39 100       110 $escape .= "/" if ($escape =~ /^[a-z]+:\/\/[^\/\?]+$/);
1467 39         77 $escape =~ s/^([a-z]+:\/\/[^\/]+)(\?.*)$/$1\/$2/gi;
1468             # $self->debug("\t$escape\n");
1469              
1470             # other weird case if domain = digits only, try to translate it to IP address
1471 39 100       94 if ((my $domain = URI->new($escape)->host) =~/^\d+$/) {
1472 3         196 my $ip = Socket::inet_ntoa(Socket::inet_aton($domain));
1473              
1474 3         11 $uri = URI->new($escape);
1475 3         111 $uri->host($ip);
1476              
1477 3         253 $escape = $uri->as_string;
1478             }
1479              
1480             # $self->debug("1. $url => $escape\n");
1481              
1482             # Try to escape the path again
1483 39         2625 $url = $escape;
1484 39         161 while (($escape = URI::Escape::uri_unescape($url)) ne $escape) { # wrong for %23 -> #
1485 0         0 $url = $escape;
1486             }
1487             # while (($escape = URI->new($url)->canonical->as_string) ne $escape) { # breask more unit tests than previous
1488             # $url = $escape;
1489             # }
1490              
1491             # Fix for %23 -> #
1492 39         407 while($escape =~ s/#/%23/sgi) { }
1493              
1494             # $self->debug("2. $url => $escape\n");
1495              
1496             # Fix over escaping
1497 39         80 while($escape =~ s/^([^?]+)%%(%.*)$/$1%25%25$2/sgi) { }
1498 39         111 while($escape =~ s/^([^?]+)%%/$1%25%25/sgi) { }
1499              
1500             # URI has issues with % in domains, it gets the host wrong
1501              
1502             # 1. fix the host
1503             # $self->debug("Domain: " . URI->new($escape)->host . "\n");
1504 39         38 my $exception = 0;
1505 39         277 while ($escape =~ /^[a-z]+:\/\/[^\/]*([^a-z0-9%_.-\/:])[^\/]*(\/.*)$/) {
1506 3         4 my $source = $1;
1507 3         11 my $target = sprintf("%02x", ord($source));
1508              
1509 3         54 $escape =~ s/^([a-z]+:\/\/[^\/]*)\Q$source\E/$1%\Q$target\E/;
1510              
1511 3         18 $exception = 1;
1512             }
1513              
1514             # 2. need to parse the path again
1515 39 50 66     88 if ($exception && $escape =~ /^[a-z]+:\/\/[^\/]+\/(.+)/) {
1516 0         0 my $source = $1;
1517 0         0 my $target = URI::Escape::uri_unescape($source);
1518              
1519             # print "Source: $source\n";
1520 0         0 while ($target ne URI::Escape::uri_unescape($target)) {
1521 0         0 $target = URI::Escape::uri_unescape($target);
1522             }
1523              
1524            
1525 0         0 $escape =~ s/\/\Q$source\E/\/$target/;
1526              
1527 0         0 while ($escape =~ s/#/%23/sgi) { } # fragement has been removed earlier
1528 0         0 while ($escape =~ s/^([a-z]+:\/\/[^\/]+\/.*)%5e/$1\&/sgi) { } # not in the host name
1529             # while ($escape =~ s/%5e/&/sgi) { }
1530              
1531 0         0 while ($escape =~ s/%([^0-9a-f]|.[^0-9a-f])/%25$1/sgi) { }
1532             }
1533              
1534             # $self->debug("$url => $escape\n");
1535             # $self->debug(URI->new($escape)->as_string . "\n");
1536              
1537 39         102 return URI->new($escape);
1538             }
1539              
1540             =head2 full_hashes()
1541              
1542             Return all possible full hashes for a URL.
1543              
1544             =cut
1545              
1546             sub full_hashes {
1547 0     0 1 0 my ($self, $url) = @_;
1548              
1549 0         0 my @urls = $self->canonical($url);
1550 0         0 my @hashes = ();
1551              
1552 0         0 foreach my $url (@urls) {
1553             # $self->debug("$url\n");
1554 0         0 push(@hashes, sha256($url));
1555             # $self->debug("$url " . $self->hex_to_ascii(sha256($url)) . "\n");
1556             }
1557              
1558 0         0 return @hashes;
1559             }
1560              
1561             =head2 prefix()
1562              
1563             Return a hash prefix. The size of the prefix is set to 4 bytes.
1564              
1565             =cut
1566              
1567             sub prefix {
1568 4     4 1 273 my ($self, $string) = @_;
1569              
1570 4         10302 return substr(sha256($string), 0, 4);
1571             }
1572              
1573             =head2 request_full_hash()
1574              
1575             Request full full hashes for specific prefixes from Google.
1576              
1577             =cut
1578              
1579             sub request_full_hash {
1580 0     0 1   my ($self, %args) = @_;
1581 0   0       my $prefixes = $args{prefixes} || return ();
1582 0   0       my $size = $args{size} || length $prefixes->[0];
1583              
1584             # # Handle errors
1585 0           my $i = 0;
1586 0           my $errors;
1587             my $delay = sub {
1588 0     0     my $time = shift;
1589 0 0         if ((time() - $errors->{timestamp}) < $time) {
1590 0           splice(@$prefixes, $i, 1);
1591             }
1592             else {
1593 0           $i++;
1594             }
1595 0           };
1596              
1597 0           while ($i < scalar @$prefixes) {
1598 0           my $prefix = $prefixes->[$i];
1599              
1600 0           $errors = $self->{storage}->get_full_hash_error(prefix => $prefix);
1601 0 0 0       if (defined $errors && $errors->{errors} > 2) { # 2 errors is OK
1602 0 0         $errors->{errors} == 3 ? $delay->(30 * 60) # 30 minutes
    0          
1603             : $errors->{errors} == 4 ? $delay->(60 * 60) # 1 hour
1604             : $delay->(2 * 60 * 60); # 2 hours
1605             }
1606             else {
1607 0           $i++;
1608             }
1609             }
1610              
1611 0           my $url = $self->{server} . "gethash?client=api&apikey=" . $self->{key} . "&appver=$VERSION&pver=" . $self->{version};
1612              
1613 0           my $prefix_list = join('', @$prefixes);
1614 0           my $header = "$size:" . scalar @$prefixes * $size;
1615              
1616             # print @{$args{prefixes}}, "\n";
1617             # print $$prefixes[0], "\n"; return;
1618              
1619              
1620 0           my $res = $self->ua->post($url, Content => "$header\n$prefix_list");
1621              
1622 0 0         if (! $res->is_success) {
1623 0           $self->error("Full hash request failed\n");
1624 0           $self->debug($res->as_string . "\n");
1625              
1626 0           foreach my $prefix (@$prefixes) {
1627 0           my $errors = $self->{storage}->get_full_hash_error(prefix => $prefix);
1628 0 0 0       if (defined $errors && (
      0        
1629             $errors->{errors} >=2 # backoff mode
1630             || $errors->{errors} == 1 && (time() - $errors->{timestamp}) > 5 * 60)) { # 5 minutes
1631 0           $self->{storage}->full_hash_error(prefix => $prefix, timestamp => time()); # more complicate than this, need to check time between 2 errors
1632             }
1633             }
1634              
1635 0           return ();
1636             }
1637             else {
1638 0           $self->debug("Full hash request OK\n");
1639              
1640 0           foreach my $prefix (@$prefixes) {
1641 0           $self->{storage}->full_hash_ok(prefix => $prefix, timestamp => time());
1642             }
1643             }
1644              
1645 0           $self->debug($res->request->as_string . "\n");
1646 0           $self->debug($res->as_string . "\n");
1647             # $self->debug(substr($res->content, 0, 250), "\n\n");
1648              
1649 0           return $self->parse_full_hashes($res->content);
1650             }
1651              
1652             =head2 parse_full_hashes()
1653              
1654             Process the request for full hashes from Google.
1655              
1656             =cut
1657              
1658             sub parse_full_hashes {
1659 0     0 1   my ($self, $data) = @_;
1660              
1661 0           my @hashes = ();
1662              
1663             # goog-malware-shavar:22428:32\nHEX
1664 0           while (length $data > 0) {
1665 0 0         if ($data !~ /^[a-z-]+:\d+:\d+\n/) {
1666 0           $self->error("list not found\n");
1667 0           return ();
1668             }
1669 0           $data =~ s/^([a-z-]+)://;
1670 0           my $list = $1;
1671            
1672 0           $data =~ s/^(\d+)://;
1673 0           my $chunknum = $1;
1674              
1675 0           $data =~ s/^(\d+)\n//;
1676 0           my $length = $1;
1677              
1678 0           my $current = 0;
1679 0           while ($current < $length) {
1680 0           my $hash = substr($data, 0, 32, '');
1681 0           push(@hashes, { hash => $hash, chunknum => $chunknum, list => $list });
1682              
1683 0           $current += 32;
1684             }
1685             }
1686              
1687 0           return @hashes;
1688             }
1689              
1690             =head2 get_a_range()
1691              
1692             Get the list of a chunks ranges for a list update.
1693              
1694             =cut
1695              
1696             sub get_a_range {
1697 0     0 1   my ($self, %args) = @_;
1698 0   0       my $list = $args{'list'} || '';
1699              
1700 0           my @nums = $self->{storage}->get_add_chunks_nums(); # trust storage to torder list, or reorder it here?
1701              
1702 0           return $self->create_range(numbers => [@nums]);
1703             }
1704              
1705             =head2 get_s_range()
1706              
1707             Get the list of s chunks ranges for a list update.
1708              
1709             =cut
1710              
1711             sub get_s_range {
1712 0     0 1   my ($self, %args) = @_;
1713 0   0       my $list = $args{'list'} || '';
1714              
1715 0           my @nums = $self->{storage}->get_sub_chunks_nums(); # trust storage to torder list, or reorder it here?
1716              
1717 0           return $self->create_range(numbers => [@nums]);
1718             }
1719              
1720             =head2 create_range()
1721              
1722             Create a list of ranges (1-3, 5, 7-11) from a list of numbers.
1723              
1724             =cut
1725              
1726             sub create_range {
1727 0     0 1   my ($self, %args) = @_;
1728 0   0       my $numbers = $args{numbers} || []; # should already be ordered
1729              
1730 0 0         return '' if (scalar @$numbers == 0);
1731              
1732 0           my $range = $$numbers[0];
1733 0           my $new_range = 0;
1734 0           for(my $i = 1; $i < scalar @$numbers; $i++) {
1735             # next if ($$numbers[$i] == $$numbers[$i-1]); # should not happen
1736              
1737 0 0         if ($$numbers[$i] != $$numbers[$i-1] + 1) {
    0          
1738 0 0 0       $range .= $$numbers[$i-1] if ($i > 1 && $new_range == 1);
1739 0           $range .= ',' . $$numbers[$i];
1740              
1741 0           $new_range = 0
1742             }
1743             elsif ($new_range == 0) {
1744 0           $range .= "-";
1745 0           $new_range = 1;
1746             }
1747             }
1748 0 0         $range .= $$numbers[scalar @$numbers - 1] if ($new_range == 1);
1749              
1750 0           return $range;
1751             }
1752              
1753             =head2 expand_range()
1754              
1755             Explode list of ranges (1-3, 5, 7-11) into a list of numbers (1,2,3,5,7,8,9,10,11).
1756              
1757             =cut
1758              
1759             sub expand_range {
1760 0     0 1   my ($self, %args) = @_;
1761 0   0       my $range = $args{range} || return ();
1762              
1763 0           my @list = ();
1764 0           my @elements = split /,/, $range;
1765              
1766 0           foreach my $data (@elements) {
1767 0 0         if ($data =~ /^\d+$/) { # single number
    0          
1768 0           push(@list, $data);
1769             }
1770             elsif ($data =~ /^(\d+)-(\d+)$/) {
1771 0           my $start = $1;
1772 0           my $end = $2;
1773              
1774 0           for(my $i = $start; $i <= $end; $i++) {
1775 0           push(@list, $i);
1776             }
1777             }
1778             }
1779              
1780 0           return @list;
1781             }
1782              
1783              
1784             =head1 CHANGELOG
1785              
1786             =over 4
1787              
1788             =item 1.11
1789              
1790             Add dependency on IO::Socket::SSL.
1791             Remove dependency on Net::IPAddress.
1792              
1793             =item 1.10
1794              
1795             Force IPv4 to solve bug on CentOS.
1796              
1797             =item 1.09
1798              
1799             Use HTTPS to access safebrowsing.clients.google.com/.
1800              
1801             =item 1.07
1802              
1803             Add C feature to import add chunks and sub chunks from a file.
1804              
1805             =item 1.05
1806              
1807             No code change. Move C to PRIVATE FUNCTIONS to avoid confusions.
1808              
1809             =item 1.04
1810              
1811             Introduce L. Remind people that Google Safe Browsing v1 has been deprecated by Google.
1812              
1813             =item 1.03
1814              
1815             The source code is available on github at L.
1816              
1817             =item 1.02
1818              
1819             Fix uninitialized $self->{errors} variable
1820              
1821             =item 1.01
1822              
1823             Use String::HexConvert for faster hex_to_ascii.
1824              
1825             =item 1.0
1826              
1827             Separate the error output from the debug output.
1828              
1829             =item 0.9
1830              
1831             Fix bug with local whitelisting (sub chunks). Fix the parsing of full hashes.
1832              
1833             =item 0.8
1834              
1835             Reduce the number of full hash requests.
1836              
1837             =item 0.7
1838              
1839             Add local_lookup to perform a lookup against the local database only. This function should be used for debugging purpose only.
1840             Small code optimizations.
1841              
1842             =item 0.6
1843              
1844             Handle local database reset.
1845              
1846             =item 0.5
1847              
1848             Update documentation.
1849              
1850             =item 0.4
1851              
1852             Speed update the database update. The first update went down from 20 minutes to 20 minutes.
1853              
1854             =item 0.3
1855              
1856             Fix typos in the documentation.
1857              
1858             Remove dependency on Switch (thanks to Curtis Jewel).
1859              
1860             Fix value of FULL_HASH_TIME.
1861              
1862             =item 0.2
1863              
1864             Add support for Message Authentication Code (MAC)
1865              
1866             =back
1867              
1868             =head1 SEE ALSO
1869              
1870             Source code available at L.
1871              
1872             See L, L and L for information on storing and managing the Google Safe Browsing database.
1873              
1874             Google Safe Browsing v2 API: L
1875              
1876             L (Google Safe Browsing v1) is deprecated by Google since 12/01/2011.
1877              
1878             L (Google Safe Browsing v2) will deprecated by Google on 12/01/2014.
1879              
1880             =head1 AUTHOR
1881              
1882             Julien Sobrier, Ejsobrier@zscaler.comE or Ejulien@sobrier.netE
1883              
1884             =head1 COPYRIGHT AND LICENSE
1885              
1886             Copyright (C) 2012 by Julien Sobrier
1887              
1888             This library is free software; you can redistribute it and/or modify
1889             it under the same terms as Perl itself, either Perl version 5.8.8 or,
1890             at your option, any later version of Perl 5 you may have available.
1891              
1892              
1893             =cut
1894              
1895             1;