File Coverage

blib/lib/Net/Google/SafeBrowsing2/Redis.pm

Criterion	Covered	Total	%
statement	18	228	7.8
branch	0	60	0.0
condition	0	102	0.0
subroutine	6	34	17.6
pod	18	28	64.2
total	42	452	9.2

package Net::Google::SafeBrowsing2::Redis;

use strict;
use warnings;

use base 'Net::Google::SafeBrowsing2::Storage';


use Carp;
use Redis::hiredis;
use Net::Google::SafeBrowsing2;


our $VERSION = '0.7';


=head1 NAME

Net::Google::SafeBrowsing2::Redis - Redis as back-end storage for the Google Safe Browsing v2 database.

The source code is available on github at L.

=head1 SYNOPSIS

  use Net::Google::SafeBrowsing2::Redis;

  my $storage = Net::Google::SafeBrowsing2::Redis->new(host => '127.0.0.1', database => 1);
  ...

=head1 DESCRIPTION

This is an implementation of L using Redis.

=cut


=head1 CONSTRUCTOR

=over 4

=head2 new()

Create a Net::Google::SafeBrowsing2::Redis object

  my $storage = Net::Google::SafeBrowsing2::Redis->new(
      host     => '127.0.0.1',
      database => 0,
  );

Arguments

=over 4

=item host

Optional. Redis host name. "127.0.01" by default

=item database

Optional. Redis database name to connect to. 0 by default.

=item port

Optional. Redis port number to connect to. 6379 by default.

=item backward_compatible

Optional. Stay backward compatible with 0.3, but requires a bigger Redis database. 0 (disabled) by default

=item keep_all

Optional. Keel all full hashes, even after they expire (45 minutes). 0 (disabled) by default

=back

=back

=cut

sub new {
	my ($class, %args) = @_;

	my $self = { # default arguments
		host		=> '127.0.0.1',
		database	=> 0,
		port		=> 6379,
		backward_compatible	=> 0,
		keep_all	=> 0,

		%args,
	};

	bless $self, $class or croak "Can't bless $class: $!";

    return $self;
}

=head1 PUBLIC FUNCTIONS

=over 4

See L for the list of public functions.

=cut


sub redis {
	my ($self, %args) 	= @_;

	if (! exists ($self->{redis})) {
		my $redis = Redis::hiredis->new();
		$redis->connect( $self->{host}, $self->{port} );
		$redis->select( $self->{database} );
		$self->{redis} = $redis;
	}

	return $self->{redis};
}

my %mapping = (
	Net::Google::SafeBrowsing2::MALWARE 	=> 'm',
	Net::Google::SafeBrowsing2::PHISHING 	=> 'p',

	'm'	=> Net::Google::SafeBrowsing2::MALWARE,
	'p'	=> Net::Google::SafeBrowsing2::PHISHING,
);

sub map {
	my ($self, $key) 	= @_;

	return $key if ($self->{backward_compatible});

	return $mapping{$key} || $key;
}


sub add_chunks {
	my ($self, %args) 	= @_;
	my $type			= $args{type}		|| 'a';
	my $chunknum		= $args{chunknum}	|| 0;
	my $chunks			= $args{chunks}		|| [];
	my $list			= $args{'list'}		|| '';

	$list = $self->map($list) unless ($self->{backward_compatible});

	if ($type eq 's') {
		$self->add_chunks_s(chunknum => $chunknum, chunks => $chunks, list => $list);
	}
	elsif ($type eq 'a') {
		$self->add_chunks_a(chunknum => $chunknum, chunks => $chunks, list => $list);
	}

	my $redis = $self->redis();

	my $key = $type . $list;
	$redis->zadd($key, $chunknum, $chunknum);

	if (scalar @$chunks == 0) { # keep empty chunks
		my $key = $type . $chunknum . $list;

		$redis->sadd($type . "l$chunknum$list", $key);
	}
}

sub add_chunks_a {
	my ($self, %args) 	= @_;
	my $chunknum		= $args{chunknum}	|| 0;
	my $chunks			= $args{chunks}		|| [];
	my $list			= $args{'list'}		|| '';

	# list already mapped by add_chunks
	my $redis = $self->redis();

	foreach my $chunk (@$chunks) {
		my $key = "a$chunknum" . $chunk->{host} . $chunk->{prefix} . $list;
		$redis->hmset($key, "list", $list, "hostkey", $chunk->{host}, "prefix", $chunk->{prefix}, "chunknum", $chunknum);

		$redis->sadd("al$chunknum$list", $key);
		$redis->sadd("ah" . $chunk->{host}, $key);
	}
}

sub add_chunks_s {
	my ($self, %args) 	= @_;
	my $chunknum		= $args{chunknum}	|| 0;
	my $chunks			= $args{chunks}		|| [];
	my $list			= $args{'list'}		|| '';

	# list already mapped by add_chunks
	my $redis = $self->redis();

	foreach my $chunk (@$chunks) {
		my $key = "s$chunknum" . $chunk->{host} . $chunk->{prefix} . $chunk->{add_chunknum} . $list;
		$redis->hmset($key, "list", $list, "hostkey", $chunk->{host}, "prefix", $chunk->{prefix}, "addchunknum", $chunk->{add_chunknum}, "chunknum", $chunknum);

		$redis->sadd("sl$chunknum$list", $key);
		$redis->sadd("sh" . $chunk->{host}, $key);
	}
}


# TODO: avoid duplicate code
sub get_add_chunks {
	my ($self, %args) 	= @_;
	my $hostkey			= $args{hostkey}	|| '';

	my @list = ();
	my $redis = $self->redis();

	my $keys = $redis->smembers("ah$hostkey");

	foreach my $key (@$keys) {
		if (! $redis->exists($key)) { # clean up
			$redis->srem("ah$hostkey", $key);
			next;
		}
		my $chunk = to_hash($redis->hgetall($key));
		$chunk->{list} = $self->map($chunk->{list}) unless ($self->{backward_compatible});
		push(@list, $chunk) if ($chunk->{hostkey} eq $hostkey);
	}

	return @list;
}

sub get_sub_chunks {
	my ($self, %args) = @_;
	my $hostkey			= $args{hostkey}	|| '';

	my @list = ();
	my $redis = $self->redis();
	my $keys = $redis->smembers("sh$hostkey");

	foreach my $key (@$keys) {
		if (! $redis->exists($key)) { # cleanup
			$redis->srem("sh$hostkey", $key);
			next;
		}

		my $chunk = to_hash($redis->hgetall($key));
		$chunk->{list} = $self->map($chunk->{list}) unless ($self->{backward_compatible});
		push(@list, $chunk) if ($chunk->{hostkey} eq $hostkey);
	}

	return @list;
}

sub get_add_chunks_nums {
	my ($self, %args) 	= @_;
	my $list			= $args{'list'}		|| '';

	# list already mapped by get_chunks_nums
	return $self->get_chunks_nums(type => 'a', list => $list);
}

sub get_sub_chunks_nums {
	my ($self, %args) 	= @_;
	my $list			= $args{'list'}		|| '';

	# list already mapped by get_chunks_nums
	return $self->get_chunks_nums(type => 's', list => $list);
}

sub get_chunks_nums {
	my ($self, %args) 	= @_;
	my $list			= $args{'list'}		|| '';
	my $type			= $args{type}		|| 'a';

	$list = $self->map($list) unless ($self->{backward_compatible});
	my $key = "$type$list";
	my $values = $self->redis()->zrangebyscore($key, "-inf", "+inf");
	return @$values;
}


sub delete_add_ckunks {
	my ($self, %args) 	= @_;
	my $chunknums		= $args{chunknums}	|| [];
	my $list		= $args{'list'}		|| '';

	$list = $self->map($list) unless ($self->{backward_compatible});
	my $redis = $self->redis();

	foreach my $num (@$chunknums) {
		my $list2 = "al$num$list";
		while ($redis->scard($list2) > 0) {
			my $key = $redis->spop($list2);

			my $host = $redis->hget($key, 'hostkey');
			# Remove key from this list
			$redis->srem("ah$host", $key);
			if ($redis->scard("ah$host") == 0) {
				$redis->del("ah$host");
			}

			$redis->del($key);
		}
		$redis->del($list); # list is empty now

		$redis->zrem("a$list", $num);

		# empty chunks
		$redis->del("a$num" . $list);
	}
}


sub delete_sub_ckunks {
	my ($self, %args) 	= @_;
	my $chunknums		= $args{chunknums}	|| [];
	my $list		= $args{'list'}		|| '';

	$list = $self->map($list) unless ($self->{backward_compatible});
	my $redis = $self->redis();

	foreach my $num (@$chunknums) {
		my $list2 = "sl$num$list";
		while ($redis->scard($list2) > 0) {
			my $key = $redis->spop($list2);

			my $host = $redis->hget($key, 'hostkey');
			# Remove key from this list
			$redis->srem("sh$host", $key);
			if ($redis->scard("sh$host") == 0) {
				$redis->del("sh$host");
			}

			$redis->del($key);
		}
		$redis->del($list); # list is empty now

		$redis->zrem("s$list", $num);

		# empty chunks
		$redis->del("s$num" . $list);
	}
}

sub get_full_hashes {
	my ($self, %args) = @_;
	my $chunknum		= $args{chunknum}	|| 0;
	my $timestamp		= $args{timestamp}	|| 0;
	my $list			= $args{list}		|| '';

	$list = $self->map($list) unless ($self->{backward_compatible});
	my @hashes = ();
	my $redis = $self->redis();

	my $keys = $redis->keys("h$chunknum*$list");
	foreach my $key (@$keys) {
		my $chunk = to_hash($redis->hgetall($key));
		push(@hashes, $chunk->{hash}) if ($chunk->{chunknum} == $chunknum
			&& exists($chunk->{timestamp}) && exists($chunk->{hash})
			&& $chunk->{timestamp} >= $timestamp);
	}

	return @hashes;
}

sub updated {
	my ($self, %args) 	= @_;
	my $time			= $args{'time'}	|| time();
	my $wait			= $args{'wait'}	|| 1800;
	my $list			= $args{'list'}	|| '';

	$list = $self->map($list) unless ($self->{backward_compatible});
	$self->redis()->hmset($list, "time", $time, "errors", 0, "wait", $wait);
}

sub update_error {
	my ($self, %args) 	= @_;
	my $time			= $args{'time'}	|| time();
	my $list			= $args{'list'}	|| '';
	my $wait			= $args{'wait'}	|| 60;
	my $errors			= $args{errors}	|| 1;

	$list = $self->map($list) unless ($self->{backward_compatible});
	$self->redis()->hmset($list, "time", $time, "errors", $errors, "wait", $wait);
}

sub last_update {
	my ($self, %args) 	= @_;
	my $list			= $args{'list'}	|| '';

	$list = $self->map($list) unless ($self->{backward_compatible});
	my $keys = $self->redis()->keys($list);
	if (scalar @$keys > 0) {
		return to_hash($self->redis()->hgetall($keys->[0]));
	}
	else {
		return {'time' => 0, 'wait' => 0, errors => 0};
	}
}

sub add_full_hashes {
	my ($self, %args) 	= @_;
	my $timestamp		= $args{timestamp}		|| time();
	my $full_hashes		= $args{full_hashes}	|| [];

	my $redis = $self->redis();

	foreach my $hash (@$full_hashes) {
		my $key = "h" . $hash->{chunknum} . $hash->{hash} . $self->map( $hash->{list} );
		$redis->hmset($key, "chunknum",  $hash->{chunknum}, "hash",  $hash->{hash}, "timestamp", $timestamp);
		$redis->expire($key, 45 * 60) unless ($self->{keep_all});
	}
}


sub delete_full_hashes {
	my ($self, %args) 	= @_;
	my $chunknums		= $args{chunknums}	|| [];
	my $list			= $args{list}		|| croak "Missing list name\n";

	$list = $self->map($list) unless ($self->{backward_compatible});
	my $redis = $self->redis();

	my @keys = $redis->keys("h*$list");
	foreach my $key (@keys) {
		foreach my $num (@$chunknums) {
			$redis->del($key) if ($key =~ /^h$num/);
		}
	}
}


sub full_hash_error {
	my ($self, %args) 	= @_;
	my $timestamp		= $args{timestamp}	|| time();
	my $prefix			= $args{prefix}		|| '';

	my $key = "eh$prefix";

	my $keys = $self->redis()->keys($key);
	if (scalar(@$keys) == 0) {
			$self->redis()->hmset($key, "prefix", $prefix, "errors", 0, "timestamp", $timestamp);
	}
	else {
		$self->redis()->hincrby($key, "errors", 1);
		$self->redis()->hset($key, "timestamp", $timestamp);
	}
}

sub full_hash_ok {
	my ($self, %args) 	= @_;
	my $timestamp		= $args{timestamp}	|| time();
	my $prefix			= $args{prefix}		|| '';

	$self->redis()->del("eh$prefix");
}

sub get_full_hash_error {
	my ($self, %args) 	= @_;
	my $prefix			= $args{prefix}		|| '';

	my $key = "eh$prefix";
	my $keys = $self->redis()->keys($key);

	if (scalar(@$keys) > 0 ) {
		return to_hash( $self->redis()->hgetall($key) );
	}
	else {
		# no error
		return undef;
	}
}

# TODO: init() to set empty mac keys
sub get_mac_keys {
	my ($self, %args) 	= @_;

	if (scalar($self->redis()->keys("mac")) == 0) {
		return { client_key => '', wrapped_key => '' };
	}
	else {
		return to_hash($self->redis()->hgetall("mac"));
	}
}

sub add_mac_keys {
	my ($self, %args) 	= @_;
	my $client_key		= $args{client_key}		|| '';
	my $wrapped_key		= $args{wrapped_key}	|| '';

	$self->redis()->hmset("mac", "client_key", $client_key, "wrapped_key", $wrapped_key);
}

sub delete_mac_keys {
	my ($self, %args) 	= @_;

	$self->redis()->hmset("mac", "client_key", '', "wrapped_key", '');
}


sub reset {
	my ($self, %args) 	= @_;

	$self->redis()->flushdb();
}

sub close {
	my ($self, %args) 	= @_;
}


sub to_hash {
	my ($data) = @_;

	my $result = { };

	my @elements = @$data;
	while(my ($key, $value) = splice(@elements,0,2)) {
		$result->{$key} = $value
	}

	return $result;
}

=back

=head1 BENCHMARK

=over 4

Here are some numbers comparing the MySQL 0.6 back-end and Redis 0.4 back-end:

Database update, from empty to full update:
MySQL: 1330s
Redis 2.4: 351s

10,000 URLs lookup
MySQL: 6s
Redis 2.4: 5s

Storage:
MySQL: 154MB
Redis 2.4: 780MB

=back


=head1 CHANGELOG

=over 4

=item 0.7

FIX: chunks were not deleted correctly.

=item 0.6

FIX: some keys were never deleted from Redis.

=item 0.4

New options backward_compatible and keep_all.

Save 140MB in Redis (as of 08/01/2012)

=item 0.3

Break backward compatibility with previous versions. Make sure you start from a fresh database (reset your existing database if needed).

Improve performances, fixes lookup. Requires 920MB for a full database (as of 07/31/2012)

=back

=head1 SEE ALSO

See L for handling Google Safe Browsing v2.

See L for the list of public functions.

See L for a back-end using Sqlite.

Google Safe Browsing v2 API: L


=head1 AUTHOR

Julien Sobrier, [e-mail] or [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2012 by Julien Sobrier

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.


=cut

1;