summaryrefslogtreecommitdiff
path: root/perl/Wallet
diff options
context:
space:
mode:
Diffstat (limited to 'perl/Wallet')
-rw-r--r--perl/Wallet/ACL.pm35
-rw-r--r--perl/Wallet/Schema.pm62
-rw-r--r--perl/Wallet/Server.pm35
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 ($@);
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 03:24:54 +0000