Caching: add global cache based on Redis (experimental)

MANIFEST

@@ -24,6 +24,8 @@ lib/Zonemaster/Engine/Logger.pm
 lib/Zonemaster/Engine/Logger/Entry.pm
 lib/Zonemaster/Engine/Nameserver.pm
 lib/Zonemaster/Engine/Nameserver/Cache.pm
+lib/Zonemaster/Engine/Nameserver/Cache/LocalCache.pm
+lib/Zonemaster/Engine/Nameserver/Cache/RedisCache.pm
 lib/Zonemaster/Engine/Normalization.pm
 lib/Zonemaster/Engine/Normalization/Error.pm
 lib/Zonemaster/Engine/Net/IP.pm

lib/Zonemaster/Engine/Nameserver.pm

@@ -237,7 +237,10 @@ sub _build_dns {
 sub _build_cache {
     my ( $self ) = @_;
 
-    Zonemaster::Engine::Nameserver::Cache->new( { address => $self->address } );
+    my $cache_type = Zonemaster::Engine::Nameserver::Cache->get_cache_type( Zonemaster::Engine::Profile->effective );
+    my $cache_class = Zonemaster::Engine::Nameserver::Cache->get_cache_class( $cache_type );
+
+    $cache_class->new( { address => $self->address } );
 }
 
 ###
@@ -361,12 +364,14 @@ sub query {
     else {
         $md5->add( q{EDNS_UDP_SIZE} , 0);
     }
-    
+
     my $idx = $md5->b64digest();
-    if ( not exists( $self->cache->data->{$idx} ) ) {
-        $self->cache->data->{$idx} = $self->_query( $name, $type, $href );
+
+    my ( $in_cache, $p) = $self->cache->get_key( $idx );
+    if ( not $in_cache ) {
+        $p = $self->_query( $name, $type, $href );
+        $self->cache->set_key( $idx, $p );
     }
-    $p = $self->cache->data->{$idx};
 
     Zonemaster::Engine->logger->add( CACHED_RETURN => { packet => ( $p ? $p->string : 'undef' ) } );
 
@@ -612,6 +617,9 @@ sub restore {
         }
       );
 
+    my $cache_type = Zonemaster::Engine::Nameserver::Cache->get_cache_type( Zonemaster::Engine::Profile->effective );
+    my $cache_class = Zonemaster::Engine::Nameserver::Cache->get_cache_class( $cache_type );
+
     open my $fh, '<', $filename or die "Failed to open restore data file: $!\n";
     while ( my $line = <$fh> ) {
         my ( $name, $addr, $data ) = split( / /, $line, 3 );
@@ -620,7 +628,7 @@ sub restore {
             {
                 name    => $name,
                 address => Net::IP::XS->new($addr),
-                cache   => Zonemaster::Engine::Nameserver::Cache->new( { data => $ref, address => Net::IP::XS->new( $addr ) } )
+                cache   => $cache_class->new( { data => $ref, address => Net::IP::XS->new( $addr ) } )
             }
         );
     }

lib/Zonemaster/Engine/Nameserver/Cache.pm

@@ -5,38 +5,45 @@ use version; our $VERSION = version->declare("v1.0.4");
 use 5.014002;
 use warnings;
 
-use Moose;
-use Zonemaster::Engine;
+use Class::Accessor "antlers";
 
 our %object_cache;
 
-has 'data' => ( is => 'ro', isa => 'HashRef[Maybe[Zonemaster::Engine::Packet]]', default => sub { {} } );
-has 'address' => ( is => 'ro', isa => 'Net::IP::XS', required => 1 );
+has 'data' => ( is => 'ro' );
+has 'address' => ( is => 'ro' );
 
-around 'new' => sub {
-    my $orig = shift;
-    my $self = shift;
+sub get_cache_type {
+    my ( $class, $profile ) = @_;
+    my $cache_type = 'LocalCache';
 
-    my $obj = $self->$orig( @_ );
+    if ( $profile->get( 'cache' ) ) {
+        my %cache_config = %{ $profile->get( 'cache' ) };
 
-    if ( not exists $object_cache{ $obj->address->ip } ) {
-        Zonemaster::Engine->logger->add( CACHE_CREATED => { ip => $obj->address->ip } );
-        $object_cache{ $obj->address->ip } = $obj;
+        if ( exists $cache_config{'redis'} ) {
+            $cache_type = 'RedisCache';
+        }
     }
 
-    Zonemaster::Engine->logger->add( CACHE_FETCHED => { ip => $obj->address->ip } );
-    return $object_cache{ $obj->address->ip };
-};
+    return $cache_type;
+}
+
+sub get_cache_class {
+    my ( $class, $cache_type ) = @_;
+
+    my $cache_class = "Zonemaster::Engine::Nameserver::Cache::$cache_type";
+
+    require ( "$cache_class.pm" =~ s{::}{/}gr );
+    $cache_class->import();
+
+    return $cache_class;
+}
 
 sub empty_cache {
     %object_cache = ();
 
     return;
 }
 
-no Moose;
-__PACKAGE__->meta->make_immutable( inline_constructor => 0 );
-
 1;
 
 =head1 NAME
@@ -65,6 +72,26 @@ A reference to a hash holding the cache of sent queries. Not meant for external
 
 =over
 
+=item get_cache_type()
+
+    my $cache_type = get_cache_type( Zonemaster::Engine::Profile->effective );
+
+Get the cache type value from the profile, i.e. the name of the cache module to use.
+
+Takes a L<Zonemaster::Engine::Profile> object.
+
+Returns a string.
+
+=item get_cache_class()
+
+    my $cache_class = get_cache_class( 'LocalCache' );
+
+Get the cache adapter class for the given database type.
+
+Takes a string (cache database type).
+
+Returns a string, or throws an exception if the cache adapter class cannot be loaded.
+
 =item empty_cache()
 
 Clear the cache.

lib/Zonemaster/Engine/Nameserver/Cache/LocalCache.pm

@@ -0,0 +1,100 @@
+package Zonemaster::Engine::Nameserver::Cache::LocalCache;
+
+use version; our $VERSION = version->declare("v1.0.4");
+
+use 5.014002;
+use warnings;
+
+use Carp qw( confess );
+use Scalar::Util qw( blessed );
+
+use Zonemaster::Engine;
+use Zonemaster::Engine::Nameserver::Cache;
+
+use base qw( Zonemaster::Engine::Nameserver::Cache );
+
+our $object_cache = \%Zonemaster::Engine::Nameserver::Cache::object_cache;
+
+sub new {
+    my $proto = shift;
+    my $class = ref $proto || $proto;
+    my $attrs = shift;
+
+    confess "Attribute \(address\) is required"
+        if !exists $attrs->{address};
+
+    # Type coercions
+    $attrs->{address} = Net::IP::XS->new( $attrs->{address} )
+        if !blessed $attrs->{address} || !$attrs->{address}->isa( 'Net::IP::XS' );
+
+    # Type constraint
+    confess "Argument must be coercible into a Net::IP::XS: address"
+        if !$attrs->{address}->isa( 'Net::IP::XS' );
+    confess "Argument must be a HASHREF: data"
+        if exists $attrs->{data} && ref $attrs->{data} ne 'HASH';
+
+    # Default value
+    $attrs->{data} //= {};
+
+    my $ip = $attrs->{address}->ip;
+    if ( exists $object_cache->{ $ip } ) {
+        Zonemaster::Engine->logger->add( CACHE_FETCHED => { ip => $ip } );
+        return $object_cache->{ $ip };
+    }
+
+    my $obj = Class::Accessor::new( $class, $attrs );
+
+    Zonemaster::Engine->logger->add( CACHE_CREATED => { ip => $ip } );
+    $object_cache->{ $ip } = $obj;
+
+    return $obj;
+}
+
+sub set_key {
+     my ( $self, $idx, $packet ) = @_;
+     $self->data->{$idx} = $packet;
+}
+
+sub get_key {
+    my ( $self, $idx ) = @_;
+
+    if ( exists $self->data->{$idx} ) {
+        # cache hit
+        return ( 1, $self->data->{$idx} );
+    }
+    return ( 0, undef );
+}
+
+1;
+
+=head1 NAME
+
+Zonemaster::Engine::Nameserver::LocalCache - local shared caches for nameserver objects
+
+=head1 SYNOPSIS
+
+    This class should not be used directly.
+
+=head1 ATTRIBUTES
+
+Subclass of L<Zonemaster::Engine::Nameserver::Cache>.
+
+=head1 CLASS METHODS
+
+=over
+
+=item new
+
+Construct a new Cache object.
+
+=item set_key($idx, $packet)
+
+Store C<$packet> (data) with key C<$idx>.
+
+=item get_key($idx)
+
+Retrieve C<$packet> (data) at key C<$idx>.
+
+=back
+
+=cut