Support enforcing a naming policy for wallet objects via a Perl

function in the wallet server configuration file.

3 files changed, 88 insertions, 5 deletions

diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm
index 57cce9b..47a45df 100644
--- a/perl/Wallet/Config.pm
+++ b/perl/Wallet/Config.pm
@@ -2,7 +2,7 @@
 # $Id$
 #
 # Written by Russ Allbery <rra@stanford.edu>
-# Copyright 2007 Board of Trustees, Leland Stanford Jr. University
+# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University
 #
 # See LICENSE for licensing terms.
 
@@ -15,7 +15,7 @@ use vars qw($PATH $VERSION);
 # 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.01';
+$VERSION = '0.02';
 
 # Path to the config file to load.
 $PATH = '/etc/wallet/wallet.conf';
@@ -525,6 +525,41 @@ creation continues if the user is authorized by that ACL.  If they don't
 match, creation of the object is rejected, since the presence of an existing
 ACL may indicate that something different is being done with this object.
 
+=head1 NAMING ENFORCEMENT
+
+By default, wallet permits administrators to create objects of any name
+(unless the object backend rejects the name).  However, naming standards
+for objects can be enforced, even for administrators, by defining a Perl
+function in the configuration file named verify_name.  If such a function
+exists, it will be called for any object creation and given the type of
+object, the object name, and the identity of the person doing the
+creation.  If it returns undef or the empty string, object creation will
+be allowed.  If it returns anything else, object creation is rejected and
+the return value is used as the error message.
+
+Please note that this return status is backwards from what one would
+normally expect.  A false value is success; a true value is failure with
+an error message.
+
+For example, the following verify_name function would ensure that any
+keytab objects for particular principals have fully-qualified hostnames:
+
+    sub verify_name {
+        my ($type, $name, $user) = @_;
+        my %host_based = map { $_ => 1 }
+            qw(HTTP cifs host imap ldap nfs pop sieve smtp webauth);
+        return unless $type eq 'keytab';
+        return unless $name =~ m%/%;
+        my ($service, $instance) = split ('/', $name, 2);
+        return unless $host_based{$service};
+        return "host name $instance must be fully qualified"
+            unless $instance =~ /\./;
+        return;
+    }
+
+Objects that aren't of type C<keytab> or which aren't for a host-based key
+have no naming requirements enforced.
+
 =cut
 
 # Now, load the configuration file so that it can override the defaults.
diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm
index 87a5bab..6be7e59 100644
--- a/perl/Wallet/Server.pm
+++ b/perl/Wallet/Server.pm
@@ -23,7 +23,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.04';
+$VERSION = '0.05';
 
 ##############################################################################
 # Utility methods
@@ -247,6 +247,13 @@ sub create {
     unless ($acl) {
         return unless $self->{admin}->check ($user);
     }
+    if (defined (&Wallet::Config::verify_name)) {
+        my $error = Wallet::Config::verify_name ($type, $name, $user);
+        if ($error) {
+            $self->error ("${type}:${name} rejected: $error");
+            return;
+        }
+    }
     my $object = eval { $class->create ($type, $name, $dbh, $user, $host) };
     if ($@) {
         $self->error ($@);
diff --git a/perl/t/server.t b/perl/t/server.t
index 13b08e9..893f23a 100755
--- a/perl/t/server.t
+++ b/perl/t/server.t
@@ -4,11 +4,11 @@
 # t/server.t -- Tests for the wallet server API.
 #
 # Written by Russ Allbery <rra@stanford.edu>
-# Copyright 2007 Board of Trustees, Leland Stanford Jr. University
+# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University
 #
 # See LICENSE for licensing terms.
 
-use Test::More tests => 325;
+use Test::More tests => 332;
 
 use POSIX qw(strftime);
 use Wallet::Config;
@@ -891,6 +891,47 @@ Members of ACL auto-admin (id: 8) are:
   krb5 $admin
 EOO
 is ($show, $expected, ' and the created object and ACL are correct');
+is ($server->destroy ('base', 'service/default-admin'), 1,
+    ' and we can destroy it');
+
+# Test naming enforcement.  Permit any base service/* name, but only permit
+# base host/* if the host is fully qualified and ends in .example.edu.
+package Wallet::Config;
+sub verify_name {
+    my ($type, $name) = @_;
+    if ($type eq 'base' and $name =~ m,^service/,) {
+        return;
+    } elsif ($type eq 'base' and $name =~ m,^host/(.*),) {
+        my $host = $1;
+        return "host $host must be fully qualified (add .example.edu)"
+            unless $host =~ /\./;
+        return "host $host not in .example.edu domain"
+            unless $host =~ /\.example\.edu$/;
+        return;
+    } else {
+        return;
+    }
+}
+package main;
+
+# Recreate service/default-admin, which should succeed, and then try the
+# various host/* principals.
+is ($server->create ('base', 'service/default-admin'), 1,
+    'Creating default/admin succeeds');
+if ($server->create ('base', 'host/default.example.edu')) {
+    ok (1, ' as does creating host/default.example.edu');
+} else {
+    is ($server->error, '', ' as does creating host/default.example.edu');
+}
+is ($server->create ('base', 'host/default'), undef,
+    ' but an unqualified host fails');
+is ($server->error, 'base:host/default rejected: host default must be fully'
+    . ' qualified (add .example.edu)', ' with the right error');
+is ($server->create ('base', 'host/default.stanford.edu'), undef,
+    ' and a host in the wrong domain fails');
+is ($server->error, 'base:host/default.stanford.edu rejected: host'
+    . ' default.stanford.edu not in .example.edu domain',
+    ' with the right error');
 
 # Clean up.
 $schema = Wallet::Schema->new;