Determine the class for object and ACL schema implementations from the

database rather than a hard-coded list and provide Wallet::Schema
methods for adding new class mappings.

Add a missing class mapping for the netdb ACL schema verifier.

3 files changed, 108 insertions, 24 deletions

diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm
index 12b3f7c..d654e68 100644
--- a/perl/Wallet/ACL.pm
+++ b/perl/Wallet/ACL.pm
@@ -14,7 +14,7 @@ package Wallet::ACL;
 require 5.006;
 
 use strict;
-use vars qw(%MAPPING $VERSION);
+use vars qw($VERSION);
 
 use DBI;
 use POSIX qw(strftime);
@@ -23,13 +23,7 @@ use Wallet::ACL::Krb5;
 # This version should be increased on any code change to this module.  Always
 # use two digits for the minor version with a leading zero if necessary so
 # that it will sort properly.
-$VERSION = '0.02';
-
-# This is a mapping of schemes to class names, used to determine which ACL
-# verifier should be instantiated for a given ACL scheme.  Currently, there's
-# no dynamic way to recognize new ACL verifiers, so if you extend the wallet
-# system to add new verifiers, you need to modify this list.
-%MAPPING = (krb5 => 'Wallet::ACL::Krb5');
+$VERSION = '0.03';
 
 ##############################################################################
 # Constructors
@@ -134,6 +128,24 @@ sub name {
     return $self->{name};
 }
 
+# Given an ACL scheme, return the mapping to a class by querying the
+# database, or undef if no mapping exists.
+sub scheme_mapping {
+    my ($self, $scheme) = @_;
+    my $class;
+    eval {
+        my $sql = 'select as_class from acl_schemes where as_name = ?';
+        ($class) = $self->{dbh}->selectrow_array ($sql, undef, $scheme);
+        $self->{dbh}->commit;
+    };
+    if ($@) {
+        $self->error ($@);
+        $self->{dbh}->rollback;
+        return;
+    }
+    return $class;
+}
+
 # Record a change to an ACL.  Takes the type of change, the scheme and
 # identifier of the entry, and the trace information (user, host, and time).
 # This function does not commit and does not catch exceptions.  It should
@@ -209,7 +221,7 @@ sub destroy {
 sub add {
     my ($self, $scheme, $identifier, $user, $host, $time) = @_;
     $time ||= time;
-    unless ($MAPPING{$scheme}) {
+    unless ($self->scheme_mapping ($scheme)) {
         $self->error ("unknown ACL scheme $scheme");
         return undef;
     }
@@ -359,11 +371,12 @@ sub check {
     for my $entry (@entries) {
         my ($scheme, $identifier) = @$entry;
         unless ($verifier{$scheme}) {
-            unless ($MAPPING{$scheme}) {
+            my $class = $self->scheme_mapping ($scheme);
+            unless ($class) {
                 push (@{ $self->{check_errors} }, "unknown scheme $scheme");
                 next;
             }
-            $verifier{$scheme} = ($MAPPING{$scheme})->new;
+            $verifier{$scheme} = $class->new;
             unless (defined $verifier{$scheme}) {
                 push (@{ $self->{check_errors} }, "cannot verify $scheme");
                 next;
diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm
index 532c61e..2aac445 100644
--- a/perl/Wallet/Schema.pm
+++ b/perl/Wallet/Schema.pm
@@ -24,7 +24,7 @@ use DBI;
 $VERSION = '0.02';
 
 ##############################################################################
-# Implementation
+# Data manipulation
 ##############################################################################
 
 # Create a new Wallet::Schema object, parse the SQL out of the documentation,
@@ -63,6 +63,10 @@ sub sql {
     return @{ $self->{sql} };
 }
 
+##############################################################################
+# Initialization and cleanup
+##############################################################################
+
 # Given a database handle, try to create our database by running the SQL.  Do
 # this in a transaction regardless of the database settings and throw an
 # exception if this fails.  We have to do a bit of fiddling to get syntax that
@@ -116,6 +120,44 @@ sub drop {
 }
 
 ##############################################################################
+# Administrative actions
+##############################################################################
+
+# Given a database handle, object type, and class name, add a new class
+# mapping to that database for the given object type.  This is used to
+# register new object types.  Throws an exception on failure.
+sub register_object {
+    my ($self, $dbh, $type, $class) = @_;
+    eval {
+        $dbh->begin_work if $dbh->{AutoCommit};
+        my $sql = 'insert into types (ty_name, ty_class) values (?, ?)';
+        $dbh->do ($sql, undef, $type, $class);
+        $dbh->commit;
+    };
+    if ($@) {
+        $dbh->rollback;
+        die "$@\n";
+    }
+}
+
+# Given a database handle, ACL verifier scheme, and class name, add a new
+# class mapping to that database for the given ACL verifier scheme.  This is
+# used to register new ACL schemes.  Throws an exception on failure.
+sub register_verifier {
+    my ($self, $dbh, $scheme, $class) = @_;
+    eval {
+        $dbh->begin_work if $dbh->{AutoCommit};
+        my $sql = 'insert into acl_schemes (as_name, as_class) values (?, ?)';
+        $dbh->do ($sql, undef, $scheme, $class);
+        $dbh->commit;
+    };
+    if ($@) {
+        $dbh->rollback;
+        die "$@\n";
+    }
+}
+
+##############################################################################
 # Schema
 ##############################################################################
 
@@ -173,6 +215,24 @@ that are part of the current schema or one of the previous known schema and
 won't remove other tables.  On any error, this method will throw a database
 exception.
 
+=item register_object (DBH, TYPE, CLASS)
+
+Given a connected database handle, register in that database a mapping from
+the object type TYPE to the class CLASS.  On any error, including attempting
+to add a mapping for a type that already exists, this method will throw a
+database exception.
+
+This method will eventually move to another class.
+
+=item register_verifier (DBH, SCHEME, CLASS)
+
+Given a connected database handle, register in that database a mapping from
+the ACL scheme SCHEME to the class CLASS.  On any error, including
+attempting to add a mapping for a scheme that already exists, this method
+will throw a database exception.
+
+This method will eventually move to another class.
+
 =item sql()
 
 Returns the schema and the population of the normalization tables as a list
diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm
index e1655ff..1e86057 100644
--- a/perl/Wallet/Server.pm
+++ b/perl/Wallet/Server.pm
@@ -24,14 +24,7 @@ use Wallet::Schema;
 # This version should be increased on any code change to this module.  Always
 # use two digits for the minor version with a leading zero if necessary so
 # that it will sort properly.
-$VERSION = '0.02';
-
-# This is a mapping of object types to class names, used to determine which
-# object implementation should be instantiated for a given object type.
-# Currently, there's no dynamic way to recognize new object types, so if you
-# extend the wallet system to add new object types, you need to modify this
-# list.
-%MAPPING = (keytab => 'Wallet::Object::Keytab');
+$VERSION = '0.03';
 
 ##############################################################################
 # Utility methods
@@ -145,6 +138,24 @@ sub DESTROY {
 # Object methods
 ##############################################################################
 
+# Given an object type, return the mapping to a class by querying the
+# database, or undef if no mapping exists.
+sub type_mapping {
+    my ($self, $type) = @_;
+    my $class;
+    eval {
+        my $sql = 'select ty_class from types where ty_name = ?';
+        ($class) = $self->{dbh}->selectrow_array ($sql, undef, $type);
+        $self->{dbh}->commit;
+    };
+    if ($@) {
+        $self->error ($@);
+        $self->{dbh}->rollback;
+        return;
+    }
+    return $class;
+}
+
 # Given an object which doesn't currently exist, check whether a default_owner
 # function is defined and, if so, if it returns an ACL for that object.  If
 # so, create the ACL and check if the current user is authorized by that ACL.
@@ -214,11 +225,11 @@ sub create_check {
 # sets the internal error.
 sub create {
     my ($self, $type, $name) = @_;
-    unless ($MAPPING{$type}) {
+    my $class = $self->type_mapping ($type);
+    unless ($class) {
         $self->error ("unknown object type $type");
         return undef;
     }
-    my $class = $MAPPING{$type};
     my $dbh = $self->{dbh};
     my $user = $self->{user};
     my $host = $self->{host};
@@ -244,11 +255,11 @@ sub create {
 # or returns undef and sets the internal error.
 sub retrieve {
     my ($self, $type, $name) = @_;
-    unless ($MAPPING{$type}) {
+    my $class = $self->type_mapping ($type);
+    unless ($class) {
         $self->error ("unknown object type $type");
         return undef;
     }
-    my $class = $MAPPING{$type};
     my $object = eval { $class->new ($type, $name, $self->{dbh}) };
     if ($@) {
         $self->error ($@);