|
<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 Digest::CRC ('crc32');
use Crypt::GCrypt;
use Digest::SHA ();
use IO::Compress::Gzip ();
use IO::Uncompress::Gunzip ();
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
}
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;
| 