src/perl/lib/OpenSRF/Utils/Cache.pm

   1 package OpenSRF::Utils::Cache;
   2 use strict; use warnings;
   3 use base qw/OpenSRF/;
   4 use Cache::Memcached;
   5 use Digest::MD5 qw(md5_hex);
   6 use OpenSRF::Utils::Logger qw/:level/;
   7 use OpenSRF::Utils::Config;
   8 use OpenSRF::Utils::SettingsClient;
   9 use OpenSRF::EX qw(:try);
  10 use OpenSRF::Utils::JSON;
  11
  12 my $log = 'OpenSRF::Utils::Logger';
  13
  14 =head1 NAME
  15
  16 OpenSRF::Utils::Cache
  17
  18 =head1 SYNOPSIS
  19
  20 This class just subclasses Cache::Memcached.
  21 see Cache::Memcached for more options.
  22
  23 The value passed to the call to current is the cache type
  24 you wish to access.  The below example sets/gets data
  25 from the 'user' cache.
  26
  27 my $cache = OpenSRF::Utils::Cache->current("user");
  28 $cache->set( "key1", "value1" [, $expire_secs ] );
  29 my $val = $cache->get( "key1" );
  30
  31
  32 =cut
  33
  34 sub DESTROY {}
  35
  36 my %caches;
  37
  38 # ------------------------------------------------------
  39 # Persist methods and method names
  40 # ------------------------------------------------------
  41 my $persist_add_slot;
  42 my $persist_push_stack;
  43 my $persist_peek_stack;
  44 my $persist_destroy_slot;
  45 my $persist_slot_get_expire;
  46 my $persist_slot_find;
  47
  48 my $max_persist_time;
  49 my $persist_add_slot_name        = "opensrf.persist.slot.create_expirable";
  50 my $persist_push_stack_name      = "opensrf.persist.stack.push";
  51 my $persist_peek_stack_name      = "opensrf.persist.stack.peek";
  52 my $persist_destroy_slot_name    = "opensrf.persist.slot.destroy";
  53 my $persist_slot_get_expire_name = "opensrf.persist.slot.get_expire";
  54 my $persist_slot_find_name       = "opensrf.persist.slot.find";;
  55
  56 # ------------------------------------------------------
  57
  58 =head1 METHODS
  59
  60 =head2 current
  61
  62 Return a named cache if it exists
  63
  64 =cut
  65
  66 sub current {
  67         my ( $class, $c_type )  = @_;
  68         return undef unless $c_type;
  69         return $caches{$c_type} if exists $caches{$c_type};
  70         return $caches{$c_type} = $class->new( $c_type );
  71 }
  72
  73
  74 =head2 new
  75
  76 Create a new named memcache object.
  77
  78 =cut
  79
  80 sub new {
  81
  82         my( $class, $cache_type, $persist ) = @_;
  83         $cache_type ||= 'global';
  84         $class = ref( $class ) || $class;
  85
  86         return $caches{$cache_type} if (defined $caches{$cache_type});
  87
  88         my $conf = OpenSRF::Utils::SettingsClient->new;
  89         my $servers = $conf->config_value( cache => $cache_type => servers => 'server' );
  90         $max_persist_time = $conf->config_value( cache => $cache_type => 'max_cache_time' );
  91
  92         $servers = [ $servers ] if(!ref($servers));
  93
  94         my $self = {};
  95         $self->{persist} = $persist || 0;
  96         $self->{memcache} = Cache::Memcached->new( { servers => $servers } );
  97         if(!$self->{memcache}) {
  98                 throw OpenSRF::EX::PANIC ("Unable to create a new memcache object for $cache_type");
  99         }
 100
 101         bless($self, $class);
 102         $caches{$cache_type} = $self;
 103         return $self;
 104 }
 105
 106
 107 =head2 put_cache
 108
 109 =cut
 110
 111 sub put_cache {
 112         my($self, $key, $value, $expiretime ) = @_;
 113
 114         return undef unless( defined $key and defined $value );
 115
 116         $key = _clean_cache_key($key);
 117
 118         return undef if( $key eq '' ); # no zero-length keys
 119
 120         $value = OpenSRF::Utils::JSON->perl2JSON($value);
 121
 122         if($self->{persist}){ _load_methods(); }
 123
 124         $expiretime ||= $max_persist_time;
 125
 126         unless( $self->{memcache}->set( $key, $value, $expiretime ) ) {
 127                 $log->error("Unable to store $key => [".length($value)." bytes]  in memcached server" );
 128                 return undef;
 129         }
 130
 131         $log->debug("Stored $key => $value in memcached server", INTERNAL);
 132
 133         if($self->{"persist"}) {
 134
 135                 my ($slot) = $persist_add_slot->run("_CACHEVAL_$key", $expiretime . "s");
 136
 137                 if(!$slot) {
 138                         # slot may already exist
 139                         ($slot) = $persist_slot_find->run("_CACHEVAL_$key");
 140                         if(!defined($slot)) {
 141                                 throw OpenSRF::EX::ERROR ("Unable to create cache slot $key in persist server" );
 142                         } else {
 143                                 #XXX destroy the slot and rebuild it to prevent DOS
 144                         }
 145                 }
 146
 147                 ($slot) = $persist_push_stack->run("_CACHEVAL_$key", $value);
 148
 149                 if(!$slot) {
 150                         throw OpenSRF::EX::ERROR ("Unable to push data onto stack in persist slot _CACHEVAL_$key" );
 151                 }
 152         }
 153
 154         return $key;
 155 }
 156
 157
 158 =head2 delete_cache
 159
 160 =cut
 161
 162 sub delete_cache {
 163         my( $self, $key ) = @_;
 164         return undef unless defined $key;
 165         $key = _clean_cache_key($key);
 166         return undef if $key eq ''; # no zero-length keys
 167         if($self->{persist}){ _load_methods(); }
 168         $self->{memcache}->delete($key);
 169         if( $self->{persist} ) {
 170                 $persist_destroy_slot->run("_CACHEVAL_$key");
 171         }
 172         return $key;
 173 }
 174
 175
 176 =head2 get_cache
 177
 178 =cut
 179
 180 sub get_cache {
 181         my($self, $key ) = @_;
 182
 183         return undef unless defined $key;
 184
 185         $key = _clean_cache_key($key);
 186
 187         return undef if $key eq ''; # no zero-length keys
 188
 189         my $val = $self->{memcache}->get( $key );
 190         return OpenSRF::Utils::JSON->JSON2perl($val) if defined($val);
 191
 192         if($self->{persist}){ _load_methods(); }
 193
 194         # if not in memcache but we are persisting, the put it into memcache
 195         if( $self->{"persist"} ) {
 196                 $val = $persist_peek_stack->( "_CACHEVAL_$key" );
 197                 if(defined($val)) {
 198                         my ($expire) = $persist_slot_get_expire->run("_CACHEVAL_$key");
 199                         if($expire)     {
 200                                 $self->{memcache}->set( $key, $val, $expire);
 201                         } else {
 202                                 $self->{memcache}->set( $key, $val, $max_persist_time);
 203                         }
 204                         return OpenSRF::Utils::JSON->JSON2perl($val);
 205                 }
 206         }
 207         return undef;
 208 }
 209
 210
 211 =head2 _load_methods
 212
 213 =cut
 214
 215 sub _load_methods {
 216
 217         if(!$persist_add_slot) {
 218                 $persist_add_slot =
 219                         OpenSRF::Application->method_lookup($persist_add_slot_name);
 220                 if(!ref($persist_add_slot)) {
 221                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_add_slot_name");
 222                 }
 223         }
 224
 225         if(!$persist_push_stack) {
 226                 $persist_push_stack =
 227                         OpenSRF::Application->method_lookup($persist_push_stack_name);
 228                 if(!ref($persist_push_stack)) {
 229                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_push_stack_name");
 230                 }
 231         }
 232
 233         if(!$persist_peek_stack) {
 234                 $persist_peek_stack =
 235                         OpenSRF::Application->method_lookup($persist_peek_stack_name);
 236                 if(!ref($persist_peek_stack)) {
 237                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_peek_stack_name");
 238                 }
 239         }
 240
 241         if(!$persist_destroy_slot) {
 242                 $persist_destroy_slot =
 243                         OpenSRF::Application->method_lookup($persist_destroy_slot_name);
 244                 if(!ref($persist_destroy_slot)) {
 245                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_destroy_slot_name");
 246                 }
 247         }
 248         if(!$persist_slot_get_expire) {
 249                 $persist_slot_get_expire =
 250                         OpenSRF::Application->method_lookup($persist_slot_get_expire_name);
 251                 if(!ref($persist_slot_get_expire)) {
 252                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_get_expire_name");
 253                 }
 254         }
 255         if(!$persist_slot_find) {
 256                 $persist_slot_find =
 257                         OpenSRF::Application->method_lookup($persist_slot_find_name);
 258                 if(!ref($persist_slot_find)) {
 259                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_find_name");
 260                 }
 261         }
 262 }
 263
 264
 265 =head2 _clean_cache_key
 266
 267 Try to make the requested cache key conform to memcached's requirements. Per
 268 https://github.com/memcached/memcached/blob/master/doc/protocol.txt:
 269
 270 """
 271 Data stored by memcached is identified with the help of a key. A key
 272 is a text string which should uniquely identify the data for clients
 273 that are interested in storing and retrieving it.  Currently the
 274 length limit of a key is set at 250 characters (of course, normally
 275 clients wouldn't need to use such long keys); the key must not include
 276 control characters or whitespace.
 277 """
 278
 279 =cut
 280
 281 sub _clean_cache_key {
 282     my $key = shift;
 283
 284     $key =~ s{(\p{Cntrl}|\s)}{}g;
 285     if (length($key) > 250) { # max length of memcahed key
 286         $key = 'shortened_' . md5_hex($key);
 287     }
 288
 289     return $key;
 290 }
 291
 292 1;
 293