|
<syntaxhighlight lang="perl">
package AnomieBOT::API::Cache::Memcached;
use parent AnomieBOT::API::Cache::Encrypted;
use utf8;
use Data::Dumper;
use Carp;
use Storable;
use Socket;
use IO::Socket;
use CryptDigest::GCryptCRC ('crc32');
use Digest::SHA ();
use IO::Compress::Gzip ();
use IO::Uncompress::Gunzip ();
# Work around that neither CRC module is currently installed in Tool Labs.
# Once one is, change this code to just use it.
eval { require String::CRC32; String::CRC32->import('crc32'); };
eval { require Digest::CRC; Digest::CRC->import('crc32'); } if $@;
if($@){
my @crc32_table = ();
for(my $i = 0; $i < 256; $i++) {
my $x = $i;
for(my $j = 0; $j < 8; $j++) {
if ($x & 1) {
$x = ($x >> 1) ^ 0xedb88320;
} else {
$x = $x >> 1;
}
}
$crc32_table[$i] = $x;
}
# Odd syntax so Perl doesn't pick up the sub at compile time.
*crc32 = sub {
my $crc = 0xffffffff;
foreach my $b (unpack('C*', $_[0])) {
$crc = (($crc >> 8) & 0xffffff) ^ $crc32_table[($crc ^ $b) & 0xff];
}
return $crc ^ 0xffffffff;
};
}
use constant {
DATA_ENCRYPTED => 1<<0,
DATA_COMPRESSED => 1<<1,
DATA_FROZEN => 1<<2,
DATA_UTF8 => 1<<3,
};
=pod
Prefix all keys with this string.
=item noreply
Value should be 0 or 1; the default is 1. When a method is called in a void
context and this is set, the 'noreply' option will be passed to memcached.
=item connect_timeout
Username and password to send as an "authenticate" command, for sharp-memcached
used in Tool LabsForge.
=item verbose
}
my $oldself = $class->SUPER::new($optionString);
my $self = {
%$oldself,
servers => \@servers,
num_servers => scalar(@servers),
socknames => {},
namespace => $opts{'namespace'}//'',
noreply => $opts{'noreply'}//1,
connect_timeout => $opts{'connect_timeout'}//0.25,
io_timeout => $opts{'io_timeout'}//1.0,
max_size => $opts{'max_size'}//0,
encrypt => $opts{'encrypt'}//'',
user => $opts{'user'}//'',
pass => $opts{'pass'}//'',
rdbuf => '',
};
if($self->{'encrypt'} ne ''){
# Preprocess key
$self->{'encrypt'} = Digest::SHA::sha256( $self->{'encrypt'} );
} else {
$self->{'encrypt'} = undef;
}
bless $self, $class;
return $self;
}
sub _get_iv {
my ($self, $key, $blklen) = @_;
my $iv;
if(!exists($self->{'ivseed'})){
# Get IV seed
$iv = '';
if(open my $fh, '<:raw', '/dev/urandom'){
while(length($iv) < 32){
last if (read($fh, $iv, 32-length($iv), length($iv))//0) <= 0;
}
close $fh;
}
$iv .= pack("n", rand(2**16)) while length($iv)<32; # Hopefully this isn't needed...
$iv = Digest::SHA::sha256($iv);
$self->{'ivseed'} = $iv;
}
$iv = '';
while(length($iv) < $blklen){
$self->{'ivseed'} = Digest::SHA::sha256(pack('n', rand(2**16)) . $self->{'ivseed'} . pack('n', rand(2**16)));
$iv .= Digest::SHA::sha256($key . $self->{'ivseed'});
}
return substr($iv, 0, $blklen);
}
substr($self->{'rdbuf'}, 0, $bytes+2) = '';
return $ret;
}
=pod
=item $cache->encode_data( $key, $value )
Encodes a Perl data value into binary. C<$value> may be a scalar or anything
accepted by L<Storable::freeze()|Storable(3perl)/MEMORY-STORE>.
Returns the binary data and flags on success, or undef on error.
=cut
sub encode_data {
my ($self, $key, $data) = @_;
my $flags = 0;
if(ref($data)){
eval {
$data = Storable::nfreeze($data);
};
if($@){
$@ = "Could not store object for $key: $@";
carp "$@\n" if $self->{'verbose'};
return undef;
}
$flags |= DATA_FROZEN;
} elsif(utf8::is_utf8($data)){
utf8::encode($data);
$flags |= DATA_UTF8;
}
if(length($data)>=100){
my $zdata;
unless(IO::Compress::Gzip::gzip(\$data => \$zdata, Level => 9, Minimal => 1)){
$@="Compression failed for $key: $IO::Compress::Gzip::GzipError";
carp "$@\n" if $self->{'verbose'};
return undef;
}
if(length($zdata)<length($data)){
$data = $zdata;
$flags |= DATA_COMPRESSED;
}
}
# Simple integers don't get encrypted (so incr/decr can work)
if($self->{'encrypt'} && !($flags == 0 && $data=~/^\d+$/ && $data < 2**64)){
my $cipher = Crypt::GCrypt->new(
type => 'cipher',
algorithm => 'aes256',
mode => 'cbc',
padding => 'standard',
);
$cipher->start('encrypting');
$cipher->setkey($self->{'encrypt'});
my $iv = $self->_get_iv($key, $cipher->blklen);
$cipher->setiv($iv);
$data = $iv . $cipher->encrypt($data) . $cipher->finish;
$flags |= DATA_ENCRYPTED;
}
return ($data, $flags);
}
=pod
=item $cache->decode_data( $key, $data, $flags )
Decodes binary data into a Perl value, the opposite of
C<< $cache->encode_data() >>.
Returns the Perl value on success, or undef on error.
=cut
sub decode_data {
my ($self, $key, $data, $flags) = @_;
if($flags & DATA_ENCRYPTED){
if(!$self->{'encrypt'}){
$@="Encryption key not set, cannot decrypt";
carp "$@\n" if $self->{'verbose'};
return undef;
}
my $cipher = Crypt::GCrypt->new(
type => 'cipher',
algorithm => 'aes256',
mode => 'cbc',
padding => 'standard',
);
if(length($data) % $cipher->blklen){
$@="Invalid encrypted data for $key";
carp "$@\n" if $self->{'verbose'};
return undef;
}
$cipher->start('decrypting');
$cipher->setkey($self->{'encrypt'});
$cipher->setiv(substr($data,0,$cipher->blklen,''));
$data = $cipher->decrypt($data) . $cipher->finish;
}
if($flags & DATA_COMPRESSED){
my $zdata;
unless(IO::Uncompress::Gunzip::gunzip(\$data => \$zdata)){
$@="Invalid compressed data for $key";
carp "$@\n" if $self->{'verbose'};
return undef;
}
$data = $zdata;
}
if($flags & DATA_FROZEN){
eval {
$data = Storable::thaw($data);
};
if($@){
$@="Invalid stored object for $key";
carp "$@\n" if $self->{'verbose'};
return undef;
}
} elsif($flags & DATA_UTF8){
unless(utf8::decode($data)){
$@="Invalid stored UTF-8 string for $key";
carp "$@\n" if $self->{'verbose'};
return undef;
}
}
return $data;
}
sub get {
my ($ret, $tok) = _get( 'get', @_ );
return $ret;
}
}
my $tokens = {};
my $fmt = $cmd.'%s %s %d %d %d';
if($cmd eq 'cas' ){
$fmt .= ' %s';
my ($sock, $mk) = $self->socket_for_key($k);
if($sock){
my $res;
my $res = $self->command($sock, sprintf($fmt, $mk, $flags, $expiry, length($data), $tokens->{$k} // '') . "\r\n$data\r\n", !$noreply) // next;
if ( $cmd eq 'cas' && !defined( $tokens->{$k} ) ) {
$res = $self->command($sock, sprintf($fmt, 'add', $mk, $flags, $expiry, length($data), '') . "\r\n$data\r\n", !$noreply) // next;
} else {
$res = $self->command($sock, sprintf($fmt, $cmd, $mk, $flags, $expiry, length($data), $tokens->{$k} // '') . "\r\n$data\r\n", !$noreply) // next;
}
unless($noreply){
if($res eq 'STORED'){
my $self = shift;
my $key = shift;
$key = $self->{'namespace'} . $key;
my $ret = $self->SUPER::munge_key($key);
$ret = $self->{'namespace'} . $ret if defined( $ret );
carp "$@\n" if !defined($ret) && $self->{'verbose'};
return $ret;
=back
=head1 COPYRIGHT
Copyright 2013 Anomie
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
| 