aboutsummaryrefslogtreecommitdiff
path: root/perl/lib
diff options
context:
space:
mode:
authorRuss Allbery <eagle@eyrie.org>2014-07-11 21:39:23 -0700
committerRuss Allbery <rra@stanford.edu>2014-07-11 22:39:05 -0700
commit1575d5c34a2c6235bbf6a5010f8a8c142fe47079 (patch)
tree29e51ed64f28a37530ec0b21fc24b6d20de1d6ca /perl/lib
parentda0aba21779529d98436e42323fc12f702390969 (diff)
Switch to Module::Build for the Perl module
The wallet server now requires Perl 5.8 or later (instead of 5.006 in previous versions) and is now built with Module::Build instead of ExtUtils::MakeMaker. This should be transparent to anyone not working with the source code, since Perl 5.8 was released in 2002, but Module::Build is now required to build the wallet server. It is included in some versions of Perl, or can be installed separately from CPAN, distribution packages, or other sources. Also reorganize the test suite to use subdirectories. Change-Id: Id06120ba2bad1ebbfee3d8a48ca2f25869463165 Reviewed-on: https://gerrit.stanford.edu/1530 Reviewed-by: Russ Allbery <rra@stanford.edu> Tested-by: Russ Allbery <rra@stanford.edu>
Diffstat (limited to 'perl/lib')
-rw-r--r--perl/lib/Wallet/ACL.pm657
-rw-r--r--perl/lib/Wallet/ACL/Base.pm125
-rw-r--r--perl/lib/Wallet/ACL/Krb5.pm125
-rw-r--r--perl/lib/Wallet/ACL/Krb5/Regex.pm133
-rw-r--r--perl/lib/Wallet/ACL/LDAP/Attribute.pm263
-rw-r--r--perl/lib/Wallet/ACL/NetDB.pm267
-rw-r--r--perl/lib/Wallet/ACL/NetDB/Root.pm128
-rw-r--r--perl/lib/Wallet/Admin.pm379
-rw-r--r--perl/lib/Wallet/Config.pm826
-rw-r--r--perl/lib/Wallet/Database.pm123
-rw-r--r--perl/lib/Wallet/Kadmin.pm240
-rw-r--r--perl/lib/Wallet/Kadmin/Heimdal.pm314
-rw-r--r--perl/lib/Wallet/Kadmin/MIT.pm323
-rw-r--r--perl/lib/Wallet/Object/Base.pm1015
-rw-r--r--perl/lib/Wallet/Object/Duo.pm331
-rw-r--r--perl/lib/Wallet/Object/File.pm242
-rw-r--r--perl/lib/Wallet/Object/Keytab.pm513
-rw-r--r--perl/lib/Wallet/Object/WAKeyring.pm370
-rw-r--r--perl/lib/Wallet/Policy/Stanford.pm422
-rw-r--r--perl/lib/Wallet/Report.pm680
-rw-r--r--perl/lib/Wallet/Schema.pm354
-rw-r--r--perl/lib/Wallet/Schema/Result/Acl.pm110
-rw-r--r--perl/lib/Wallet/Schema/Result/AclEntry.pm74
-rw-r--r--perl/lib/Wallet/Schema/Result/AclHistory.pm113
-rw-r--r--perl/lib/Wallet/Schema/Result/AclScheme.pm84
-rw-r--r--perl/lib/Wallet/Schema/Result/Duo.pm53
-rw-r--r--perl/lib/Wallet/Schema/Result/Enctype.pm45
-rw-r--r--perl/lib/Wallet/Schema/Result/Flag.pm62
-rw-r--r--perl/lib/Wallet/Schema/Result/KeytabEnctype.pm53
-rw-r--r--perl/lib/Wallet/Schema/Result/KeytabSync.pm53
-rw-r--r--perl/lib/Wallet/Schema/Result/Object.pm266
-rw-r--r--perl/lib/Wallet/Schema/Result/ObjectHistory.pm135
-rw-r--r--perl/lib/Wallet/Schema/Result/SyncTarget.pm48
-rw-r--r--perl/lib/Wallet/Schema/Result/Type.pm75
-rw-r--r--perl/lib/Wallet/Server.pm1095
35 files changed, 10096 insertions, 0 deletions
diff --git a/perl/lib/Wallet/ACL.pm b/perl/lib/Wallet/ACL.pm
new file mode 100644
index 0000000..808be3c
--- /dev/null
+++ b/perl/lib/Wallet/ACL.pm
@@ -0,0 +1,657 @@
+# Wallet::ACL -- Implementation of ACLs in the wallet system.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2008, 2010, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL;
+require 5.006;
+
+use strict;
+use vars qw($VERSION);
+
+use DBI;
+use POSIX qw(strftime);
+
+# 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.07';
+
+##############################################################################
+# Constructors
+##############################################################################
+
+# Initialize a new ACL from the database. Verify that the ACL already exists
+# in the database and, if so, return a new blessed object. Stores the ACL ID
+# and the database handle to use for future operations. If the object
+# doesn't exist, throws an exception.
+sub new {
+ my ($class, $id, $schema) = @_;
+ my (%search, $data, $name);
+ if ($id =~ /^\d+\z/) {
+ $search{ac_id} = $id;
+ } else {
+ $search{ac_name} = $id;
+ }
+ eval {
+ $data = $schema->resultset('Acl')->find (\%search);
+ };
+ if ($@) {
+ die "cannot search for ACL $id: $@\n";
+ } elsif (not defined $data) {
+ die "ACL $id not found\n";
+ }
+ my $self = {
+ schema => $schema,
+ id => $data->ac_id,
+ name => $data->ac_name,
+ };
+ bless ($self, $class);
+ return $self;
+}
+
+# Create a new ACL in the database with the given name and return a new
+# blessed ACL object for it. Stores the database handle to use and the ID of
+# the newly created ACL in the object. On failure, throws an exception.
+sub create {
+ my ($class, $name, $schema, $user, $host, $time) = @_;
+ if ($name =~ /^\d+\z/) {
+ die "ACL name may not be all numbers\n";
+ }
+ $time ||= time;
+ my $id;
+ eval {
+ my $guard = $schema->txn_scope_guard;
+
+ # Create the new record.
+ my %record = (ac_name => $name);
+ my $acl = $schema->resultset('Acl')->create (\%record);
+ $id = $acl->ac_id;
+ die "unable to retrieve new ACL ID" unless defined $id;
+
+ # Add to the history table.
+ my $date = strftime ('%Y-%m-%d %T', localtime $time);
+ %record = (ah_acl => $id,
+ ah_action => 'create',
+ ah_by => $user,
+ ah_from => $host,
+ ah_on => $date);
+ my $history = $schema->resultset('AclHistory')->create (\%record);
+ die "unable to create new history entry" unless defined $history;
+
+ $guard->commit;
+ };
+ if ($@) {
+ die "cannot create ACL $name: $@\n";
+ }
+ my $self = {
+ schema => $schema,
+ id => $id,
+ name => $name,
+ };
+ bless ($self, $class);
+ return $self;
+}
+
+##############################################################################
+# Utility functions
+##############################################################################
+
+# Set or return the error stashed in the object.
+sub error {
+ my ($self, @error) = @_;
+ if (@error) {
+ my $error = join ('', @error);
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ $self->{error} = $error;
+ }
+ return $self->{error};
+}
+
+# Returns the ID of an ACL.
+sub id {
+ my ($self) = @_;
+ return $self->{id};
+}
+
+# Returns the name of the ACL.
+sub name {
+ my ($self)= @_;
+ return $self->{name};
+}
+
+# Given an ACL scheme, return the mapping to a class by querying the
+# database, or undef if no mapping exists. Also load the relevant module.
+sub scheme_mapping {
+ my ($self, $scheme) = @_;
+ my $class;
+ eval {
+ my %search = (as_name => $scheme);
+ my $scheme_rec = $self->{schema}->resultset('AclScheme')
+ ->find (\%search);
+ $class = $scheme_rec->as_class;
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ if (defined $class) {
+ eval "require $class";
+ if ($@) {
+ $self->error ($@);
+ 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
+# normally be called as part of a larger transaction that implements the
+# change and should be committed with that change.
+sub log_acl {
+ my ($self, $action, $scheme, $identifier, $user, $host, $time) = @_;
+ unless ($action =~ /^(add|remove)\z/) {
+ die "invalid history action $action";
+ }
+ my %record = (ah_acl => $self->{id},
+ ah_action => $action,
+ ah_scheme => $scheme,
+ ah_identifier => $identifier,
+ ah_by => $user,
+ ah_from => $host,
+ ah_on => strftime ('%Y-%m-%d %T', localtime $time));
+ $self->{schema}->resultset('AclHistory')->create (\%record);
+}
+
+##############################################################################
+# ACL manipulation
+##############################################################################
+
+# Changes the human-readable name of the ACL. Note that this operation is not
+# logged since it isn't a change to any of the data stored in the wallet.
+# Returns true on success, false on failure.
+sub rename {
+ my ($self, $name) = @_;
+ if ($name =~ /^\d+\z/) {
+ $self->error ("ACL name may not be all numbers");
+ return;
+ }
+ eval {
+ my $guard = $self->{schema}->txn_scope_guard;
+ my %search = (ac_id => $self->{id});
+ my $acls = $self->{schema}->resultset('Acl')->find (\%search);
+ $acls->ac_name ($name);
+ $acls->update;
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ("cannot rename ACL $self->{id} to $name: $@");
+ return;
+ }
+ $self->{name} = $name;
+ return 1;
+}
+
+# Destroy the ACL, deleting it out of the database. Returns true on success,
+# false on failure.
+#
+# Checks to ensure that the ACL is not referenced anywhere in the database,
+# since we may not have referential integrity enforcement. It's not clear
+# that this is the right place to do this; it's a bit of an abstraction
+# violation, since it's a query against the object table.
+sub destroy {
+ my ($self, $user, $host, $time) = @_;
+ $time ||= time;
+ eval {
+ my $guard = $self->{schema}->txn_scope_guard;
+
+ # Make certain no one is using the ACL.
+ my @search = ({ ob_owner => $self->{id} },
+ { ob_acl_get => $self->{id} },
+ { ob_acl_store => $self->{id} },
+ { ob_acl_show => $self->{id} },
+ { ob_acl_destroy => $self->{id} },
+ { ob_acl_flags => $self->{id} });
+ my @entries = $self->{schema}->resultset('Object')->search (\@search);
+ if (@entries) {
+ my ($entry) = @entries;
+ die "ACL in use by ".$entry->ob_type.":".$entry->ob_name;
+ }
+
+ # Delete any entries (there may or may not be any).
+ my %search = (ae_id => $self->{id});
+ @entries = $self->{schema}->resultset('AclEntry')->search(\%search);
+ for my $entry (@entries) {
+ $entry->delete;
+ }
+
+ # There should definitely be an ACL record to delete.
+ %search = (ac_id => $self->{id});
+ my $entry = $self->{schema}->resultset('Acl')->find(\%search);
+ $entry->delete if defined $entry;
+
+ # Create new history line for the deletion.
+ my %record = (ah_acl => $self->{id},
+ ah_action => 'destroy',
+ ah_by => $user,
+ ah_from => $host,
+ ah_on => strftime ('%Y-%m-%d %T', localtime $time));
+ $self->{schema}->resultset('AclHistory')->create (\%record);
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ("cannot destroy ACL $self->{id}: $@");
+ return;
+ }
+ return 1;
+}
+
+##############################################################################
+# ACL entry manipulation
+##############################################################################
+
+# Add an ACL entry to this ACL. Returns true on success and false on failure.
+sub add {
+ my ($self, $scheme, $identifier, $user, $host, $time) = @_;
+ $time ||= time;
+ unless ($self->scheme_mapping ($scheme)) {
+ $self->error ("unknown ACL scheme $scheme");
+ return;
+ }
+ eval {
+ my $guard = $self->{schema}->txn_scope_guard;
+ my %record = (ae_id => $self->{id},
+ ae_scheme => $scheme,
+ ae_identifier => $identifier);
+ my $entry = $self->{schema}->resultset('AclEntry')->create (\%record);
+ $self->log_acl ('add', $scheme, $identifier, $user, $host, $time);
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ("cannot add $scheme:$identifier to $self->{id}: $@");
+ return;
+ }
+ return 1;
+}
+
+# Remove an ACL entry to this ACL. Returns true on success and false on
+# failure. Detect the case where no such row exists before doing the delete
+# so that we can provide a good error message.
+sub remove {
+ my ($self, $scheme, $identifier, $user, $host, $time) = @_;
+ $time ||= time;
+ eval {
+ my $guard = $self->{schema}->txn_scope_guard;
+ my %search = (ae_id => $self->{id},
+ ae_scheme => $scheme,
+ ae_identifier => $identifier);
+ my $entry = $self->{schema}->resultset('AclEntry')->find (\%search);
+ unless (defined $entry) {
+ die "entry not found in ACL\n";
+ }
+ $entry->delete;
+ $self->log_acl ('remove', $scheme, $identifier, $user, $host, $time);
+ $guard->commit;
+ };
+ if ($@) {
+ my $entry = "$scheme:$identifier";
+ $self->error ("cannot remove $entry from $self->{id}: $@");
+ return;
+ }
+ return 1;
+}
+
+##############################################################################
+# ACL checking
+##############################################################################
+
+# List all of the entries in an ACL. Returns an array of tuples, each of
+# which contains a scheme and identifier, or an array containing undef on
+# error. Sets the internal error string on error.
+sub list {
+ my ($self) = @_;
+ undef $self->{error};
+ my @entries;
+ eval {
+ my $guard = $self->{schema}->txn_scope_guard;
+ my %search = (ae_id => $self->{id});
+ my @entry_recs = $self->{schema}->resultset('AclEntry')
+ ->search (\%search);
+ for my $entry (@entry_recs) {
+ push (@entries, [ $entry->ae_scheme, $entry->ae_identifier ]);
+ }
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ("cannot retrieve ACL $self->{id}: $@");
+ return;
+ } else {
+ return @entries;
+ }
+}
+
+# Return as a string a human-readable description of an ACL, including its
+# membership. This method is only for human-readable output; use the list()
+# method if you are using the results in other code. Returns undef on
+# failure.
+sub show {
+ my ($self) = @_;
+ my @entries = $self->list;
+ if (not @entries and $self->error) {
+ return;
+ }
+ my $name = $self->name;
+ my $id = $self->id;
+ my $output = "Members of ACL $name (id: $id) are:\n";
+ for my $entry (sort { $$a[0] cmp $$b[0] or $$a[1] cmp $$b[1] } @entries) {
+ my ($scheme, $identifier) = @$entry;
+ $output .= " $scheme $identifier\n";
+ }
+ return $output;
+}
+
+# Return as a string the history of an ACL. Returns undef on failure.
+sub history {
+ my ($self) = @_;
+ my $output = '';
+ eval {
+ my $guard = $self->{schema}->txn_scope_guard;
+ my %search = (ah_acl => $self->{id});
+ my %options = (order_by => 'ah_on');
+ my @data = $self->{schema}->resultset('AclHistory')
+ ->search (\%search, \%options);
+ for my $data (@data) {
+ $output .= sprintf ("%s %s ", $data->ah_on->ymd,
+ $data->ah_on->hms);
+ if ($data->ah_action eq 'add' || $data->ah_action eq 'remove') {
+ $output .= sprintf ("%s %s %s", $data->ah_action,
+ $data->ah_scheme, $data->ah_identifier);
+ } else {
+ $output .= $data->ah_action;
+ }
+ $output .= sprintf ("\n by %s from %s\n", $data->ah_by,
+ $data->ah_from);
+ }
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ("cannot read history for $self->{id}: $@");
+ return;
+ }
+ return $output;
+}
+
+# Given a principal, a scheme, and an identifier, check whether that ACL
+# scheme and identifier grant access to that principal. Return 1 if access
+# was granted, 0 if access was deined, and undef on some error. On error, the
+# error message is also added to the check_errors variable. This method is
+# internal to the class.
+#
+# Maintain ACL verifiers for all schemes we've seen in the local %verifier
+# hash so that we can optimize repeated ACL checks.
+{
+ my %verifier;
+ sub check_line {
+ my ($self, $principal, $scheme, $identifier) = @_;
+ unless ($verifier{$scheme}) {
+ my $class = $self->scheme_mapping ($scheme);
+ unless ($class) {
+ push (@{ $self->{check_errors} }, "unknown scheme $scheme");
+ return;
+ }
+ $verifier{$scheme} = $class->new;
+ unless (defined $verifier{$scheme}) {
+ push (@{ $self->{check_errors} }, "cannot verify $scheme");
+ return;
+ }
+ }
+ my $result = ($verifier{$scheme})->check ($principal, $identifier);
+ if (not defined $result) {
+ push (@{ $self->{check_errors} }, ($verifier{$scheme})->error);
+ return;
+ } else {
+ return $result;
+ }
+ }
+}
+
+# Given a principal, check whether it should be granted access according to
+# this ACL. Returns 1 if access was granted, 0 if access was denied, and
+# undef on some error. Errors from ACL verifiers do not cause an error
+# return, but are instead accumulated in the check_errors variable returned by
+# the check_errors() method.
+sub check {
+ my ($self, $principal) = @_;
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ my @entries = $self->list;
+ return if (not @entries and $self->error);
+ my %verifier;
+ $self->{check_errors} = [];
+ for my $entry (@entries) {
+ my ($scheme, $identifier) = @$entry;
+ my $result = $self->check_line ($principal, $scheme, $identifier);
+ return 1 if $result;
+ }
+ return 0;
+}
+
+# Returns the errors from the last ACL verification as an array in array
+# context or as a string with newlines after each error in a scalar context.
+sub check_errors {
+ my ($self) = @_;
+ my @errors;
+ if ($self->{check_errors}) {
+ @errors = @{ $self->{check_errors} };
+ }
+ return wantarray ? @errors : join ("\n", @errors, '');
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=head1 NAME
+
+Wallet::ACL - Implementation of ACLs in the wallet system
+
+=for stopwords
+ACL DBH metadata HOSTNAME DATETIME timestamp Allbery verifier verifiers
+
+=head1 SYNOPSIS
+
+ my $acl = Wallet::ACL->create ('group:sysadmin');
+ $acl->rename ('group:unix');
+ $acl->add ('krb5', 'alice@EXAMPLE.COM', $admin, $host);
+ $acl->add ('krb5', 'bob@EXAMPLE.COM', $admin, $host);
+ if ($acl->check ($user)) {
+ print "Permission granted\n";
+ warn scalar ($acl->check_errors) if $acl->check_errors;
+ }
+ $acl->remove ('krb5', 'bob@EXAMPLE.COM', $admin, $host);
+ my @entries = $acl->list;
+ my $summary = $acl->show;
+ my $history = $acl->history;
+ $acl->destroy ($admin, $host);
+
+=head1 DESCRIPTION
+
+Wallet::ACL implements the ACL system for the wallet: the methods to
+create, find, rename, and destroy ACLs; the methods to add and remove
+entries from an ACL; and the methods to list the contents of an ACL and
+check a principal against it.
+
+An ACL is a list of zero or more ACL entries, each of which consists of a
+scheme and an identifier. Each scheme is associated with a verifier
+module that checks Kerberos principals against identifiers for that scheme
+and returns whether the principal should be permitted access by that
+identifier. The interpretation of the identifier is entirely left to the
+scheme. This module maintains the ACLs and dispatches check operations to
+the appropriate verifier module.
+
+Each ACL is identified by a human-readable name and a persistent unique
+numeric identifier. The numeric identifier (ID) should be used to refer
+to the ACL so that it can be renamed as needed without breaking external
+references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new(ACL, SCHEMA)
+
+Instantiate a new ACL object with the given ACL ID or name. Takes the
+Wallet::Schema object to use for retrieving metadata from the wallet
+database. Returns a new ACL object if the ACL was found and throws an
+exception if it wasn't or on any other error.
+
+=item create(NAME, SCHEMA, PRINCIPAL, HOSTNAME [, DATETIME])
+
+Similar to new() in that it instantiates a new ACL object, but instead of
+finding an existing one, creates a new ACL record in the database with the
+given NAME. NAME must not be all-numeric, since that would conflict with
+the automatically assigned IDs. Returns the new object on success and
+throws an exception on failure. PRINCIPAL, HOSTNAME, and DATETIME are
+stored as history information. PRINCIPAL should be the user who is
+creating the ACL. If DATETIME isn't given, the current time is used.
+
+=back
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item add(SCHEME, INSTANCE, PRINCIPAL, HOSTNAME [, DATETIME])
+
+Add the given ACL entry (given by SCHEME and INSTANCE) to this ACL.
+Returns true on success and false on failure. On failure, the caller
+should call error() to get the error message. PRINCIPAL, HOSTNAME, and
+DATETIME are stored as history information. PRINCIPAL should be the user
+who is adding the ACL entry. If DATETIME isn't given, the current time is
+used.
+
+=item check(PRINCIPAL)
+
+Checks whether the given PRINCIPAL should be allowed access given ACL.
+Returns 1 if access was granted, 0 if access is declined, and undef on
+error. On error, the caller should call error() to get the error text.
+Any errors found by the individual ACL verifiers can be retrieved by
+calling check_errors(). Errors from individual ACL verifiers will not
+result in an error return from check(); instead, the check will continue
+with the next entry in the ACL.
+
+check() returns success as soon as an entry in the ACL grants access to
+PRINCIPAL. There is no provision for negative ACLs or exceptions.
+
+=item check_errors()
+
+Return (as a list in array context and a string with newlines between
+errors and at the end of the last error in scalar context) the errors, if
+any, returned by ACL verifiers for the last check operation. If there
+were no errors from the last check() operation, returns the empty list in
+array context and undef in scalar context.
+
+=item destroy(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Destroys this ACL from the database. Note that this will fail if the ACL
+is still referenced by any object; the ACL must be removed from all
+objects first. Returns true on success and false on failure. On failure,
+the caller should call error() to get the error message. PRINCIPAL,
+HOSTNAME, and DATETIME are stored as history information. PRINCIPAL
+should be the user who is destroying the ACL. If DATETIME isn't given,
+the current time is used.
+
+=item error()
+
+Returns the error of the last failing operation or undef if no operations
+have failed. Callers should call this function to get the error message
+after an undef return from any other instance method.
+
+=item history()
+
+Returns the human-readable history of this ACL. Each action that changes
+the ACL (not including changes to the name of the ACL) will be represented
+by two lines. The first line will have a timestamp of the change followed
+by a description of the change, and the second line will give the user who
+made the change and the host from which the change was made. On failure,
+returns undef, and the caller should call error() to get the error
+message.
+
+=item id()
+
+Returns the numeric system-generated ID of this ACL.
+
+=item list()
+
+Returns all the entries of this ACL. The return value will be a list of
+references to pairs of scheme and identifier. For example, for an ACL
+containing two entries, both of scheme C<krb5> and with values
+C<alice@EXAMPLE.COM> and C<bob@EXAMPLE.COM>, list() would return:
+
+ ([ 'krb5', 'alice@EXAMPLE.COM' ], [ 'krb5', 'bob@EXAMPLE.COM' ])
+
+Returns the empty list on failure. To distinguish between this and the
+ACL containing no entries, the caller should call error(). error() is
+guaranteed to return the error message if there was an error and undef if
+there was no error.
+
+=item name()
+
+Returns the human-readable name of this ACL.
+
+=item remove(SCHEME, INSTANCE, PRINCIPAL, HOSTNAME [, DATETIME])
+
+Remove the given ACL line (given by SCHEME and INSTANCE) from this ACL.
+Returns true on success and false on failure. On failure, the caller
+should call error() to get the error message. PRINCIPAL, HOSTNAME, and
+DATETIME are stored as history information. PRINCIPAL should be the user
+who is removing the ACL entry. If DATETIME isn't given, the current time
+is used.
+
+=item rename(NAME)
+
+Rename this ACL. This changes the name used for human convenience but not
+the system-generated ACL ID that is used to reference this ACL. The new
+NAME must not be all-numeric, since that would conflict with
+system-generated ACL IDs. Returns true on success and false on failure.
+On failure, the caller should call error() to get the error message.
+
+Note that rename() operations are not logged in the ACL history.
+
+=item show()
+
+Returns a human-readable description of this ACL, including its
+membership. This method should only be used for display of the ACL to
+humans. Use the list(), name(), and id() methods instead to get ACL
+information for use in other code. On failure, returns undef, and the
+caller should call error() to get the error message.
+
+=back
+
+=head1 SEE ALSO
+
+Wallet::ACL::Base(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/ACL/Base.pm b/perl/lib/Wallet/ACL/Base.pm
new file mode 100644
index 0000000..b6e4ce3
--- /dev/null
+++ b/perl/lib/Wallet/ACL/Base.pm
@@ -0,0 +1,125 @@
+# Wallet::ACL::Base -- Parent class for wallet ACL verifiers.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2010
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::Base;
+require 5.006;
+
+use strict;
+use vars qw($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.02';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# Creates a new persistant verifier, taking a database handle. This parent
+# class just creates an empty object and ignores the handle. Child classes
+# should override if there are necessary initialization tasks or if the handle
+# will be used by the verifier.
+sub new {
+ my $type = shift;
+ my $self = {};
+ bless ($self, $type);
+ return $self;
+}
+
+# The default check method denies all access.
+sub check {
+ return 0;
+}
+
+# Set or return the error stashed in the object.
+sub error {
+ my ($self, @error) = @_;
+ if (@error) {
+ my $error = join ('', @error);
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ $self->{error} = $error;
+ }
+ return $self->{error};
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL Allbery verifier verifiers
+
+=head1 NAME
+
+Wallet::ACL::Base - Generic parent class for wallet ACL verifiers
+
+=head1 SYNOPSIS
+
+ package Wallet::ACL::Simple
+ @ISA = qw(Wallet::ACL::Base);
+ sub check {
+ my ($self, $principal, $acl) = @_;
+ return ($principal eq $acl) ? 1 : 0;
+ }
+
+=head1 DESCRIPTION
+
+Wallet::ACL::Base is the generic parent class for wallet ACL verifiers.
+It provides default functions and behavior and all ACL verifiers should
+inherit from it. It is not used directly.
+
+=head1 METHODS
+
+=over 4
+
+=item new()
+
+Creates a new ACL verifier. The generic function provided here just
+creates and blesses an object.
+
+=item check(PRINCIPAL, ACL)
+
+This method should always be overridden by child classes. The default
+implementation just declines all access.
+
+=item error([ERROR ...])
+
+Returns the error of the last failing operation or undef if no operations
+have failed. Callers should call this function to get the error message
+after an undef return from any other instance method.
+
+For the convenience of child classes, this method can also be called with
+one or more error strings. If so, those strings are concatenated
+together, trailing newlines are removed, any text of the form S<C< at \S+
+line \d+\.?>> at the end of the message is stripped off, and the result is
+stored as the error. Only child classes should call this method with an
+error string.
+
+=back
+
+=head1 SEE ALSO
+
+Wallet::ACL(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/ACL/Krb5.pm b/perl/lib/Wallet/ACL/Krb5.pm
new file mode 100644
index 0000000..ed0b7df
--- /dev/null
+++ b/perl/lib/Wallet/ACL/Krb5.pm
@@ -0,0 +1,125 @@
+# Wallet::ACL::Krb5 -- Wallet Kerberos v5 principal ACL verifier.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2010
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::Krb5;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Wallet::ACL::Base;
+
+@ISA = qw(Wallet::ACL::Base);
+
+# 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';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# The most trivial ACL verifier. Returns true if the provided principal
+# matches the ACL.
+sub check {
+ my ($self, $principal, $acl) = @_;
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ unless ($acl) {
+ $self->error ('malformed krb5 ACL');
+ return;
+ }
+ return ($principal eq $acl) ? 1 : 0;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL krb5 Allbery verifier
+
+=head1 NAME
+
+Wallet::ACL::Krb5 - Simple wallet ACL verifier for Kerberos principals
+
+=head1 SYNOPSIS
+
+ my $verifier = Wallet::ACL::Krb5->new;
+ my $status = $verifier->check ($principal, $acl);
+ if (not defined $status) {
+ die "Something failed: ", $verifier->error, "\n";
+ } elsif ($status) {
+ print "Access granted\n";
+ } else {
+ print "Access denied\n";
+ }
+
+=head1 DESCRIPTION
+
+Wallet::ACL::Krb5 is the simplest wallet ACL verifier, used to verify ACL
+lines of type C<krb5>. The value of such an ACL is a simple Kerberos
+principal in its text display form, and the ACL grants access to a given
+principal if and only if the principal exactly matches the ACL.
+
+=head1 METHODS
+
+=over 4
+
+=item new()
+
+Creates a new ACL verifier. For this verifier, there is no setup work.
+
+=item check(PRINCIPAL, ACL)
+
+Returns true if PRINCIPAL matches ACL, false if not, and undef on an error
+(see L<"DIAGNOSTICS"> below).
+
+=item error()
+
+Returns the error if check() returned undef.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item malformed krb5 ACL
+
+The ACL parameter to check() was malformed. Currently, this error is only
+given if ACL is undefined or the empty string.
+
+=item no principal specified
+
+The PRINCIPAL parameter to check() was undefined or the empty string.
+
+=back
+
+=head1 SEE ALSO
+
+Wallet::ACL(3), Wallet::ACL::Base(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/ACL/Krb5/Regex.pm b/perl/lib/Wallet/ACL/Krb5/Regex.pm
new file mode 100644
index 0000000..30f5527
--- /dev/null
+++ b/perl/lib/Wallet/ACL/Krb5/Regex.pm
@@ -0,0 +1,133 @@
+# Wallet::ACL::Krb5::Regex -- Wallet Kerberos v5 principal regex ACL verifier
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2010
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::Krb5::Regex;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Wallet::ACL::Krb5;
+
+@ISA = qw(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.01';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# Returns true if the Perl regular expression specified by the ACL matches
+# the provided Kerberos principal.
+sub check {
+ my ($self, $principal, $acl) = @_;
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ unless ($acl) {
+ $self->error ('no ACL specified');
+ return;
+ }
+ my $regex = eval { qr/$acl/ };
+ if ($@) {
+ $self->error ('malformed krb5-regex ACL');
+ return;
+ }
+ return ($principal =~ m/$regex/) ? 1 : 0;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL krb5-regex Durkacz Allbery verifier
+
+=head1 NAME
+
+Wallet::ACL::Krb5::Regex - Regex wallet ACL verifier for Kerberos principals
+
+=head1 SYNOPSIS
+
+ my $verifier = Wallet::ACL::Krb5::Regex->new;
+ my $status = $verifier->check ($principal, $acl);
+ if (not defined $status) {
+ die "Something failed: ", $verifier->error, "\n";
+ } elsif ($status) {
+ print "Access granted\n";
+ } else {
+ print "Access denied\n";
+ }
+
+=head1 DESCRIPTION
+
+Wallet::ACL::Krb5::Regex is the wallet ACL verifier used to verify ACL
+lines of type C<krb5-regex>. The value of such an ACL is a Perl regular
+expression, and the ACL grants access to a given Kerberos principal if and
+only if the regular expression matches that principal.
+
+=head1 METHODS
+
+=over 4
+
+=item new()
+
+Creates a new ACL verifier. For this verifier, there is no setup work.
+
+=item check(PRINCIPAL, ACL)
+
+Returns true if the Perl regular expression specified by the ACL matches the
+PRINCIPAL, false if not, and undef on an error (see L<"DIAGNOSTICS"> below).
+
+=item error()
+
+Returns the error if check() returned undef.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item malformed krb5-regex ACL
+
+The ACL parameter to check() was a malformed Perl regular expression.
+
+=item no principal specified
+
+The PRINCIPAL parameter to check() was undefined or the empty string.
+
+=item no ACL specified
+
+The ACL parameter to check() was undefined or the empty string.
+
+=back
+
+=head1 SEE ALSO
+
+Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::ACL::Krb5(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Ian Durkacz
+
+=cut
diff --git a/perl/lib/Wallet/ACL/LDAP/Attribute.pm b/perl/lib/Wallet/ACL/LDAP/Attribute.pm
new file mode 100644
index 0000000..aea8a72
--- /dev/null
+++ b/perl/lib/Wallet/ACL/LDAP/Attribute.pm
@@ -0,0 +1,263 @@
+# Wallet::ACL::LDAP::Attribute -- Wallet LDAP attribute ACL verifier.
+#
+# Written by Russ Allbery
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::LDAP::Attribute;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Authen::SASL ();
+use Net::LDAP qw(LDAP_COMPARE_TRUE);
+use Wallet::ACL::Base;
+use Wallet::Config;
+
+@ISA = qw(Wallet::ACL::Base);
+
+# 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';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# Create a new persistant verifier. Load the Net::LDAP module and open a
+# persistant LDAP server connection that we'll use for later calls.
+sub new {
+ my $type = shift;
+ my $host = $Wallet::Config::LDAP_HOST;
+ my $base = $Wallet::Config::LDAP_BASE;
+ unless ($host and defined ($base) and $Wallet::Config::LDAP_CACHE) {
+ die "LDAP attribute ACL support not configured\n";
+ }
+
+ # Ensure the required Perl modules are available and bind to the directory
+ # server. Catch any errors with a try/catch block.
+ my $ldap;
+ eval {
+ local $ENV{KRB5CCNAME} = $Wallet::Config::LDAP_CACHE;
+ my $sasl = Authen::SASL->new (mechanism => 'GSSAPI');
+ $ldap = Net::LDAP->new ($host, onerror => 'die');
+ my $mesg = eval { $ldap->bind (undef, sasl => $sasl) };
+ };
+ if ($@) {
+ my $error = $@;
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ die "LDAP attribute ACL support not available: $error\n";
+ }
+
+ # We successfully bound, so create our object and return it.
+ my $self = { ldap => $ldap };
+ bless ($self, $type);
+ return $self;
+}
+
+# Check whether a given principal has the required LDAP attribute. We first
+# map the principal to a DN by doing a search for that principal (and bailing
+# if we get more than one entry). Then, we do a compare to see if that DN has
+# the desired attribute and value.
+#
+# If the ldap_map_principal sub is defined in Wallet::Config, call it on the
+# principal first to map it to the value for which we'll search.
+#
+# The connection is configured to die on any error, so we do all the work in a
+# try/catch block to report errors.
+sub check {
+ my ($self, $principal, $acl) = @_;
+ undef $self->{error};
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ my ($attr, $value);
+ if ($acl) {
+ ($attr, $value) = split ('=', $acl, 2);
+ }
+ unless (defined ($attr) and defined ($value)) {
+ $self->error ('malformed ldap-attr ACL');
+ return;
+ }
+ my $ldap = $self->{ldap};
+
+ # Map the principal name to an attribute value for our search if we're
+ # doing a custom mapping.
+ if (defined &Wallet::Config::ldap_map_principal) {
+ eval { $principal = Wallet::Config::ldap_map_principal ($principal) };
+ if ($@) {
+ $self->error ("mapping principal to LDAP failed: $@");
+ return;
+ }
+ }
+
+ # Now, map the user to a DN by doing a search.
+ my $entry;
+ eval {
+ my $fattr = $Wallet::Config::LDAP_FILTER_ATTR || 'krb5PrincipalName';
+ my $filter = "($fattr=$principal)";
+ my $base = $Wallet::Config::LDAP_BASE;
+ my @options = (base => $base, filter => $filter, attrs => [ 'dn' ]);
+ my $search = $ldap->search (@options);
+ if ($search->count == 1) {
+ $entry = $search->pop_entry;
+ } elsif ($search->count > 1) {
+ die $search->count . " LDAP entries found for $principal";
+ }
+ };
+ if ($@) {
+ $self->error ("cannot search for $principal in LDAP: $@");
+ return;
+ }
+ return 0 unless $entry;
+
+ # We have a user entry. We can now check whether that user has the
+ # desired attribute and value.
+ my $result;
+ eval {
+ my $mesg = $ldap->compare ($entry, attr => $attr, value => $value);
+ $result = $mesg->code;
+ };
+ if ($@) {
+ $self->error ("cannot check LDAP attribute $attr for $principal: $@");
+ return;
+ }
+ return ($result == LDAP_COMPARE_TRUE) ? 1 : 0;
+}
+
+1;
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL Allbery verifier LDAP PRINCIPAL's DN ldap-attr
+
+=head1 NAME
+
+Wallet::ACL::LDAP::Attribute - Wallet ACL verifier for LDAP attribute compares
+
+=head1 SYNOPSIS
+
+ my $verifier = Wallet::ACL::LDAP::Attribute->new;
+ my $status = $verifier->check ($principal, "$attr=$value");
+ if (not defined $status) {
+ die "Something failed: ", $verifier->error, "\n";
+ } elsif ($status) {
+ print "Access granted\n";
+ } else {
+ print "Access denied\n";
+ }
+
+=head1 DESCRIPTION
+
+Wallet::ACL::LDAP::Attribute checks whether the LDAP record for the entry
+corresponding to a principal contains an attribute with a particular
+value. It is used to verify ACL lines of type C<ldap-attr>. The value of
+such an ACL is an attribute followed by an equal sign and a value, and the
+ACL grants access to a given principal if and only if the LDAP entry for
+that principal has that attribute set to that value.
+
+To use this object, several configuration parameters must be set. See
+L<Wallet::Config> for details on those configuration parameters and
+information about how to set wallet configuration.
+
+=head1 METHODS
+
+=over 4
+
+=item new()
+
+Creates a new ACL verifier. Opens and binds the connection to the LDAP
+server.
+
+=item check(PRINCIPAL, ACL)
+
+Returns true if PRINCIPAL is granted access according to ACL, false if
+not, and undef on an error (see L<"DIAGNOSTICS"> below). ACL must be an
+attribute name and a value, separated by an equal sign (with no
+whitespace). PRINCIPAL will be granted access if its LDAP entry contains
+that attribute with that value.
+
+=item error()
+
+Returns the error if check() returned undef.
+
+=back
+
+=head1 DIAGNOSTICS
+
+The new() method may fail with one of the following exceptions:
+
+=over 4
+
+=item LDAP attribute ACL support not available: %s
+
+Attempting to connect or bind to the LDAP server failed.
+
+=item LDAP attribute ACL support not configured
+
+The required configuration parameters were not set. See Wallet::Config(3)
+for the required configuration parameters and how to set them.
+
+=back
+
+Verifying an LDAP attribute ACL may fail with the following errors
+(returned by the error() method):
+
+=over 4
+
+=item cannot check LDAP attribute %s for %s: %s
+
+The LDAP compare to check for the required attribute failed. The
+attribute may have been misspelled, or there may be LDAP directory
+permission issues. This error indicates that PRINCIPAL's entry was
+located in LDAP, but the check failed during the compare to verify the
+attribute value.
+
+=item cannot search for %s in LDAP: %s
+
+Searching for PRINCIPAL (possibly after ldap_map_principal() mapping)
+failed. This is often due to LDAP directory permissions issues. This
+indicates a failure during the mapping of PRINCIPAL to an LDAP DN.
+
+=item malformed ldap-attr ACL
+
+The ACL parameter to check() was malformed. Usually this means that
+either the attribute or the value were empty or the required C<=> sign
+separating them was missing.
+
+=item mapping principal to LDAP failed: %s
+
+There was an ldap_map_principal() function defined in the wallet
+configuration, but calling it for the PRINCIPAL argument failed.
+
+=item no principal specified
+
+The PRINCIPAL parameter to check() was undefined or the empty string.
+
+=back
+
+=head1 SEE ALSO
+
+Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::Config(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/ACL/NetDB.pm b/perl/lib/Wallet/ACL/NetDB.pm
new file mode 100644
index 0000000..b76d4ed
--- /dev/null
+++ b/perl/lib/Wallet/ACL/NetDB.pm
@@ -0,0 +1,267 @@
+# Wallet::ACL::NetDB -- Wallet NetDB role ACL verifier.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2010
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::NetDB;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Wallet::ACL::Base;
+use Wallet::Config;
+
+@ISA = qw(Wallet::ACL::Base);
+
+# 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.05';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# Creates a new persistant verifier. Load the Net::Remctl module and open a
+# persistant remctl connection that we'll use for later calls.
+sub new {
+ my $type = shift;
+ my $host = $Wallet::Config::NETDB_REMCTL_HOST;
+ unless ($host and $Wallet::Config::NETDB_REMCTL_CACHE) {
+ die "NetDB ACL support not configured\n";
+ }
+ eval { require Net::Remctl };
+ if ($@) {
+ my $error = $@;
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ die "NetDB ACL support not available: $error\n";
+ }
+ local $ENV{KRB5CCNAME} = $Wallet::Config::NETDB_REMCTL_CACHE;
+ my $remctl = Net::Remctl->new;
+
+ # Net::Remctl 2.12 and later will support passing in an empty string for
+ # the principal. Until then, be careful not to pass principal unless it
+ # was specified.
+ my $port = $Wallet::Config::NETDB_REMCTL_PORT || 0;
+ my $principal = $Wallet::Config::NETDB_REMCTL_PRINCIPAL;
+ my $status;
+ if (defined $principal) {
+ $status = $remctl->open ($host, $port, $principal);
+ } else {
+ $status = $remctl->open ($host, $port);
+ }
+ unless ($status) {
+ die "cannot connect to NetDB remctl interface: ", $remctl->error, "\n";
+ }
+ my $self = { remctl => $remctl };
+ bless ($self, $type);
+ return $self;
+}
+
+# Check whether the given principal has one of the user, administrator, or
+# admin team roles in NetDB for the given host. Returns 1 if it does, 0 if it
+# doesn't, and undef, setting the error, if there's some failure in making the
+# remctl call.
+sub check {
+ my ($self, $principal, $acl) = @_;
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ unless ($acl) {
+ $self->error ('malformed netdb ACL');
+ return;
+ }
+ my $remctl = $self->{remctl};
+ if ($Wallet::Config::NETDB_REALM) {
+ $principal =~ s/\@\Q$Wallet::Config::NETDB_REALM\E\z//;
+ }
+ unless ($remctl->command ('netdb', 'node-roles', $principal, $acl)) {
+ $self->error ('cannot check NetDB ACL: ' . $remctl->error);
+ return;
+ }
+ my ($roles, $output, $status, $error);
+ do {
+ $output = $remctl->output;
+ if ($output->type eq 'output') {
+ if ($output->stream == 1) {
+ $roles .= $output->data;
+ } else {
+ $error .= $output->data;
+ }
+ } elsif ($output->type eq 'error') {
+ $self->error ('cannot check NetDB ACL: ' . $output->data);
+ return;
+ } elsif ($output->type eq 'status') {
+ $status = $output->status;
+ } else {
+ $self->error ('malformed NetDB remctl token: ' . $output->type);
+ return;
+ }
+ } while ($output->type eq 'output');
+ if ($status == 0) {
+ $roles ||= '';
+ my @roles = split (' ', $roles);
+ for my $role (@roles) {
+ return 1 if $role eq 'admin';
+ return 1 if $role eq 'team';
+ return 1 if $role eq 'user';
+ }
+ return 0;
+ } else {
+ if ($error) {
+ chomp $error;
+ $error =~ s/\n/ /g;
+ $self->error ("error checking NetDB ACL: $error");
+ } else {
+ $self->error ("error checking NetDB ACL");
+ }
+ return;
+ }
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL NetDB remctl DNS DHCP Allbery netdb verifier
+
+=head1 NAME
+
+Wallet::ACL::NetDB - Wallet ACL verifier for NetDB roles
+
+=head1 SYNOPSIS
+
+ my $verifier = Wallet::ACL::NetDB->new;
+ my $status = $verifier->check ($principal, $node);
+ if (not defined $status) {
+ die "Something failed: ", $verifier->error, "\n";
+ } elsif ($status) {
+ print "Access granted\n";
+ } else {
+ print "Access denied\n";
+ }
+
+=head1 DESCRIPTION
+
+Wallet::ACL::NetDB checks a principal against the NetDB roles for a given
+host. It is used to verify ACL lines of type C<netdb>. The value of such
+an ACL is a node, and the ACL grants access to a given principal if and
+only if that principal has one of the roles user, admin, or team for that
+node.
+
+To use this object, several configuration parameters must be set. See
+L<Wallet::Config> for details on those configuration parameters and
+information about how to set wallet configuration.
+
+=head1 METHODS
+
+=over 4
+
+=item new()
+
+Creates a new ACL verifier. Opens the remctl connection to the NetDB
+server and authenticates.
+
+=item check(PRINCIPAL, ACL)
+
+Returns true if PRINCIPAL is granted access according to ACL, false if
+not, and undef on an error (see L<"DIAGNOSTICS"> below). ACL is a node,
+and PRINCIPAL will be granted access if it (with the realm stripped off if
+configured) has the user, admin, or team role for that node.
+
+=item error()
+
+Returns the error if check() returned undef.
+
+=back
+
+=head1 DIAGNOSTICS
+
+The new() method may fail with one of the following exceptions:
+
+=over 4
+
+=item NetDB ACL support not available: %s
+
+The Net::Remctl Perl module, required for NetDB ACL support, could not be
+loaded.
+
+=item NetDB ACL support not configured
+
+The required configuration parameters were not set. See Wallet::Config(3)
+for the required configuration parameters and how to set them.
+
+=item cannot connect to NetDB remctl interface: %s
+
+Connecting to the NetDB remctl interface failed with the given error
+message.
+
+=back
+
+Verifying a NetDB ACL may fail with the following errors (returned by the
+error() method):
+
+=over 4
+
+=item cannot check NetDB ACL: %s
+
+Issuing the remctl command to get the roles for the given principal failed
+or returned an error.
+
+=item error checking NetDB ACL: %s
+
+The NetDB remctl interface that returns the roles for a user returned an
+error message or otherwise returned failure.
+
+=item malformed netdb ACL
+
+The ACL parameter to check() was malformed. Currently, this error is only
+given if ACL is undefined or the empty string.
+
+=item malformed NetDB remctl token: %s
+
+The Net::Remctl Perl library returned a malformed token. This should
+never happen and indicates a bug in Net::Remctl.
+
+=item no principal specified
+
+The PRINCIPAL parameter to check() was undefined or the empty string.
+
+=back
+
+=head1 CAVEATS
+
+The list of possible NetDB roles that should be considered sufficient to
+grant access is not currently configurable.
+
+=head1 SEE ALSO
+
+Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::Config(3),
+wallet-backend(8)
+
+NetDB is a free software system for managing DNS, DHCP, and related
+machine information for large organizations. For more information on
+NetDB, see L<http://www.stanford.edu/group/networking/netdb/>.
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/ACL/NetDB/Root.pm b/perl/lib/Wallet/ACL/NetDB/Root.pm
new file mode 100644
index 0000000..6c95c6e
--- /dev/null
+++ b/perl/lib/Wallet/ACL/NetDB/Root.pm
@@ -0,0 +1,128 @@
+# Wallet::ACL::NetDB::Root -- Wallet NetDB role ACL verifier (root instances).
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2010
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::NetDB::Root;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Wallet::ACL::NetDB;
+use Wallet::Config;
+
+@ISA = qw(Wallet::ACL::NetDB);
+
+# 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';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# Override the check method of Wallet::ACL::NetDB to require that the
+# principal be a root instance and to strip /root out of the principal name
+# before checking roles.
+sub check {
+ my ($self, $principal, $acl) = @_;
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ unless ($principal =~ s%^([^/\@]+)/root(\@|\z)%$1$2%) {
+ return 0;
+ }
+ return $self->SUPER::check ($principal, $acl);
+}
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL NetDB DNS DHCP Allbery verifier
+
+=head1 NAME
+
+Wallet::ACL::NetDB::Root - Wallet ACL verifier for NetDB roles (root instances)
+
+=head1 SYNOPSIS
+
+ my $verifier = Wallet::ACL::NetDB::Root->new;
+ my $status = $verifier->check ($principal, $node);
+ if (not defined $status) {
+ die "Something failed: ", $verifier->error, "\n";
+ } elsif ($status) {
+ print "Access granted\n";
+ } else {
+ print "Access denied\n";
+ }
+
+=head1 DESCRIPTION
+
+Wallet::ACL::NetDB::Root works identically to Wallet::ACL::NetDB except
+that it requires the principal to be a root instance (in other words, to
+be in the form <principal>/root@<realm>) and strips the C</root> portion
+from the principal before checking against NetDB roles. As with the base
+NetDB ACL verifier, the value of a C<netdb-root> ACL is a node, and the
+ACL grants access to a given principal if and only if the that principal
+(with C</root> stripped) has one of the roles user, admin, or team for
+that node.
+
+To use this object, the same configuration parameters must be set as for
+Wallet::ACL::NetDB. See Wallet::Config(3) for details on those
+configuration parameters and information about how to set wallet
+configuration.
+
+=head1 METHODS
+
+=over 4
+
+=item check(PRINCIPAL, ACL)
+
+Returns true if PRINCIPAL is granted access according to ACL, false if
+not, and undef on an error (see L<"DIAGNOSTICS"> below). ACL is a node,
+and PRINCIPAL will be granted access if it has an instance of C<root> and
+if (with C</root> stripped off and the realm stripped off if configured)
+has the user, admin, or team role for that node.
+
+=back
+
+=head1 DIAGNOSTICS
+
+Same as for Wallet::ACL::NetDB.
+
+=head1 CAVEATS
+
+The instance to strip is not currently configurable.
+
+The list of possible NetDB roles that should be considered sufficient to
+grant access is not currently configurable.
+
+=head1 SEE ALSO
+
+Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3),
+Wallet::ACL::NetDB(3), Wallet::Config(3), wallet-backend(8)
+
+NetDB is a free software system for managing DNS, DHCP, and related
+machine information for large organizations. For more information on
+NetDB, see L<http://www.stanford.edu/group/networking/netdb/>.
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Admin.pm b/perl/lib/Wallet/Admin.pm
new file mode 100644
index 0000000..3a05284
--- /dev/null
+++ b/perl/lib/Wallet/Admin.pm
@@ -0,0 +1,379 @@
+# Wallet::Admin -- Wallet system administrative interface.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2008, 2009, 2010, 2011, 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Admin;
+require 5.006;
+
+use strict;
+use vars qw($VERSION);
+
+use Wallet::ACL;
+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.07';
+
+# The last non-DBIx::Class version of Wallet::Schema. If a database has no
+# DBIx::Class versioning, we artificially install this version number before
+# starting the upgrade process so that the automated DBIx::Class upgrade will
+# work properly.
+our $BASE_VERSION = '0.07';
+
+##############################################################################
+# Constructor, destructor, and accessors
+##############################################################################
+
+# Create a new wallet administrator object. Opens a connection to the
+# database that will be used for all of the wallet configuration information.
+# Throw an exception if anything goes wrong.
+sub new {
+ my ($class) = @_;
+ my $schema = Wallet::Schema->connect;
+ my $self = { schema => $schema };
+ bless ($self, $class);
+ return $self;
+}
+
+# Returns the database handle (used mostly for testing).
+sub dbh {
+ my ($self) = @_;
+ return $self->{schema}->storage->dbh;
+}
+
+# Returns the DBIx::Class-based database schema object.
+sub schema {
+ my ($self) = @_;
+ return $self->{schema};
+}
+
+# Set or return the error stashed in the object.
+sub error {
+ my ($self, @error) = @_;
+ if (@error) {
+ my $error = join ('', @error);
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ $self->{error} = $error;
+ }
+ return $self->{error};
+}
+
+# Disconnect the database handle on object destruction to avoid warnings.
+sub DESTROY {
+ my ($self) = @_;
+ $self->{schema}->storage->dbh->disconnect;
+}
+
+##############################################################################
+# Database initialization
+##############################################################################
+
+# Initializes the database by populating it with our schema and then creates
+# and returns a new wallet server object. This is used only for initial
+# database creation. Takes the Kerberos principal who will be the default
+# administrator so that we can create an initial administrator ACL. Returns
+# true on success and false on failure, setting the object error.
+sub initialize {
+ my ($self, $user) = @_;
+
+ # Deploy the database schema from DDL files, if they exist. If not then
+ # we automatically get the database from the Schema modules.
+ $self->{schema}->deploy ({}, $Wallet::Config::DB_DDL_DIRECTORY);
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ $self->default_data;
+
+ # Create a default admin ACL.
+ my $acl = Wallet::ACL->create ('ADMIN', $self->{schema}, $user,
+ 'localhost');
+ unless ($acl->add ('krb5', $user, $user, 'localhost')) {
+ $self->error ($acl->error);
+ return;
+ }
+
+ return 1;
+}
+
+# Load default data into various tables. We'd like to do this more directly
+# in the schema definitions, but not yet seeing a good way to do that.
+sub default_data {
+ my ($self) = @_;
+
+ # acl_schemes default rows.
+ my ($r1) = $self->{schema}->resultset('AclScheme')->populate ([
+ [ qw/as_name as_class/ ],
+ [ 'krb5', 'Wallet::ACL::Krb5' ],
+ [ 'krb5-regex', 'Wallet::ACL::Krb5::Regex' ],
+ [ 'ldap-attr', 'Wallet::ACL::LDAP::Attribute' ],
+ [ 'netdb', 'Wallet::ACL::NetDB' ],
+ [ 'netdb-root', 'Wallet::ACL::NetDB::Root' ],
+ ]);
+ warn "default AclScheme not installed" unless defined $r1;
+
+ # types default rows.
+ my @record = ([ qw/ty_name ty_class/ ],
+ [ 'file', 'Wallet::Object::File' ],
+ [ 'keytab', 'Wallet::Object::Keytab' ],
+ [ 'wa-keyring', 'Wallet::Object::WAKeyring' ]);
+ ($r1) = $self->{schema}->resultset('Type')->populate (\@record);
+ warn "default Type not installed" unless defined $r1;
+
+ # enctypes default rows.
+ @record = ([ qw/en_name/ ],
+ [ 'aes128-cts-hmac-sha1-96' ],
+ [ 'aes256-cts-hmac-sha1-96' ],
+ [ 'arcfour-hmac-md5' ],
+ [ 'des-cbc-crc' ],
+ [ 'des3-cbc-sha1' ]);
+ ($r1) = $self->{schema}->resultset('Enctype')->populate (\@record);
+ warn "default Enctype not installed" unless defined $r1;
+
+ return 1;
+}
+
+# The same as initialize, but also drops any existing tables first before
+# creating the schema. Takes the same arguments. Returns true on success and
+# false on failure.
+sub reinitialize {
+ my ($self, $user) = @_;
+ return unless $self->destroy;
+ return $self->initialize ($user);
+}
+
+# Drop the database, including all of its data. Returns true on success and
+# false on failure.
+sub destroy {
+ my ($self) = @_;
+
+ # Get an actual DBI handle and use it to delete all tables.
+ my $dbh = $self->dbh;
+ my @tables = qw/acls acl_entries acl_history acl_schemes enctypes
+ flags keytab_enctypes keytab_sync objects object_history
+ sync_targets types dbix_class_schema_versions/;
+ for my $table (@tables) {
+ my $sql = "DROP TABLE IF EXISTS $table";
+ $dbh->do ($sql);
+ }
+
+ return 1;
+}
+
+# Save a DDL of the database in every supported database server. Returns
+# true on success and false on failure.
+sub backup {
+ my ($self, $oldversion) = @_;
+
+ my @dbs = qw/MySQL SQLite PostgreSQL/;
+ my $version = $Wallet::Schema::VERSION;
+ $self->{schema}->create_ddl_dir (\@dbs, $version,
+ $Wallet::Config::DB_DDL_DIRECTORY,
+ $oldversion);
+
+ return 1;
+}
+
+# Upgrade the database to the latest schema version. Returns true on success
+# and false on failure.
+sub upgrade {
+ my ($self) = @_;
+
+ # Check to see if the database is versioned. If not, install the
+ # versioning table and default version.
+ if (!$self->{schema}->get_db_version) {
+ $self->{schema}->install ($BASE_VERSION);
+ }
+
+ # Suppress warnings that actually are just informational messages.
+ local $SIG{__WARN__} = sub {
+ my ($warn) = @_;
+ return if $warn =~ m{Upgrade not necessary};
+ return if $warn =~ m{Attempting upgrade};
+ warn $warn;
+ };
+
+ # Perform the actual upgrade.
+ if ($self->{schema}->get_db_version) {
+ $self->{schema}->upgrade_directory ($Wallet::Config::DB_DDL_DIRECTORY);
+ eval { $self->{schema}->upgrade; };
+ }
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+
+ return 1;
+}
+
+##############################################################################
+# Object registration
+##############################################################################
+
+# Given an 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. Returns true on success, false on failure, and sets the internal
+# error on failure.
+sub register_object {
+ my ($self, $type, $class) = @_;
+ eval {
+ my $guard = $self->{schema}->txn_scope_guard;
+ my %record = (ty_name => $type,
+ ty_class => $class);
+ $self->{schema}->resultset('Type')->create (\%record);
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ("cannot register $class for $type: $@");
+ return;
+ }
+ return 1;
+}
+
+# Given an 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. Returns true on success, false on failure, and sets the
+# internal error on failure.
+sub register_verifier {
+ my ($self, $scheme, $class) = @_;
+ eval {
+ my $guard = $self->{schema}->txn_scope_guard;
+ my %record = (as_name => $scheme,
+ as_class => $class);
+ $self->{schema}->resultset('AclScheme')->create (\%record);
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ("cannot register $class for $scheme: $@");
+ return;
+ }
+ return 1;
+}
+
+1;
+__DATA__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=head1 NAME
+
+Wallet::Admin - Wallet system administrative interface
+
+=for stopwords
+ACL hostname Allbery verifier
+
+=head1 SYNOPSIS
+
+ use Wallet::Admin;
+ my $admin = Wallet::Admin->new;
+ unless ($admin->initialize ('user/admin@EXAMPLE.COM')) {
+ die $admin->error;
+ }
+
+=head1 DESCRIPTION
+
+Wallet::Admin implements the administrative interface to the wallet server
+and database. It is normally instantiated and used by B<wallet-admin>, a
+thin wrapper around this object that provides a command-line interface to
+its actions.
+
+To use this object, several configuration variables must be set (at least
+the database configuration). For information on those variables and how
+to set them, see L<Wallet::Config>. For more information on the normal
+user interface to the wallet server, see L<Wallet::Server>.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new()
+
+Creates a new wallet administrative object and connects to the database.
+On any error, this method throws an exception.
+
+=back
+
+=head1 INSTANCE METHODS
+
+For all methods that can fail, the caller should call error() after a
+failure to get the error message.
+
+=over 4
+
+=item destroy ()
+
+Destroys the database, deleting all of its data and all of the tables used
+by the wallet server. Returns true on success and false on failure.
+
+=item error ()
+
+Returns the error of the last failing operation or undef if no operations
+have failed. Callers should call this function to get the error message
+after an undef return from any other instance method.
+
+=item initialize(PRINCIPAL)
+
+Initializes the database as configured in Wallet::Config and loads the
+wallet database schema. Then, creates an ACL with the name ADMIN and adds
+an ACL entry of scheme C<krb5> and instance PRINCIPAL to that ACL. This
+bootstraps the authorization system and lets that Kerberos identity make
+further changes to the ADMIN ACL and the rest of the wallet database.
+Returns true on success and false on failure.
+
+initialize() uses C<localhost> as the hostname and PRINCIPAL as the user
+when logging the history of the ADMIN ACL creation and for any subsequent
+actions on the object it returns.
+
+=item register_object (TYPE, CLASS)
+
+Register in the database a mapping from the object type TYPE to the class
+CLASS. Returns true on success and false on failure (including when the
+verifier is already registered).
+
+=item register_verifier (SCHEME, CLASS)
+
+Register in the database a mapping from the ACL scheme SCHEME to the class
+CLASS. Returns true on success and false on failure (including when the
+verifier is already registered).
+
+=item reinitialize (PRINCIPAL)
+
+Performs the same actions as initialize(), but first drops any existing
+wallet database tables from the database, allowing this function to be
+called on a prior wallet database. All data stored in the database will
+be deleted and a fresh set of wallet database tables will be created.
+This method is equivalent to calling destroy() followed by initialize().
+Returns true on success and false on failure.
+
+=item upgrade ()
+
+Upgrades the database to the latest schema version, preserving data as
+much as possible. Returns true on success and false on failure.
+
+=back
+
+=head1 SEE ALSO
+
+wallet-admin(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Config.pm b/perl/lib/Wallet/Config.pm
new file mode 100644
index 0000000..5b0ab1c
--- /dev/null
+++ b/perl/lib/Wallet/Config.pm
@@ -0,0 +1,826 @@
+# Wallet::Config -- Configuration handling for the wallet server.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2008, 2010, 2013, 2014
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Config;
+require 5.006;
+
+use strict;
+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.05';
+
+# Path to the config file to load.
+$PATH = $ENV{WALLET_CONFIG} || '/etc/wallet/wallet.conf';
+
+=head1 NAME
+
+Wallet::Config - Configuration handling for the wallet server
+
+=for stopwords
+DBI DSN SQLite subdirectories KEYTAB keytab kadmind KDC add-ons kadmin DNS
+SRV kadmin keytabs remctl backend lowercased NETDB ACL NetDB unscoped
+usernames rekey hostnames Allbery wallet-backend keytab-backend Heimdal
+rekeys WebAuth WEBAUTH keyring LDAP DN GSS-API integrations
+
+=head1 SYNOPSIS
+
+ use Wallet::Config;
+ my $driver = $Wallet::Config::DB_DRIVER;
+ my $info;
+ if (defined $Wallet::Config::DB_INFO) {
+ $info = $Wallet::Config::DB_INFO;
+ } else {
+ $info = "database=$Wallet::Config::DB_NAME";
+ $info .= ";host=$Wallet::Config::DB_HOST"
+ if $Wallet::Config::DB_HOST;
+ $info .= ";port=$Wallet::Config::DB_PORT"
+ if $Wallet::Config::DB_PORT;
+ }
+ my $dsn = "dbi:$driver:$info";
+ my $user = $Wallet::Config::DB_USER;
+ my $password = $Wallet::Config::DB_PASSWORD;
+ my $dbh = DBI->connect ($dsn, $user, $password);
+
+=head1 DESCRIPTION
+
+Wallet::Config encapsulates all of the site-specific configuration for the
+wallet server. It is implemented as a Perl class that declares and sets
+the defaults for various configuration variables and then, if it exists,
+loads the file specified by the WALLET_CONFIG environment variable or
+F</etc/wallet/wallet.conf> if that environment variable isn't set. That
+file should contain any site-specific overrides to the defaults, and at
+least some parameters must be set.
+
+This file must be valid Perl. To set a variable, use the syntax:
+
+ $VARIABLE = <value>;
+
+where VARIABLE is the variable name (always in all-capital letters) and
+<value> is the value. If setting a variable to a string and not a number,
+you should normally enclose <value> in C<''>. For example, to set the
+variable DB_DRIVER to C<MySQL>, use:
+
+ $DB_DRIVER = 'MySQL';
+
+Always remember the initial dollar sign (C<$>) and ending semicolon
+(C<;>). Those familiar with Perl syntax can of course use the full range
+of Perl expressions.
+
+This configuration file should end with the line:
+
+ 1;
+
+This ensures that Perl doesn't think there is an error when loading the
+file.
+
+=head1 DATABASE CONFIGURATION
+
+=over 4
+
+=item DB_DDL_DIRECTORY
+
+Specifies the directory used to dump the database schema in formats for
+each possible database server. This also includes diffs between schema
+versions, for upgrades. The default value is F</usr/local/share/wallet>,
+which matches the default installation location.
+
+=cut
+
+our $DB_DDL_DIRECTORY = '/usr/local/share/wallet';
+
+=item DB_DRIVER
+
+Sets the Perl database driver to use for the wallet database. Common
+values would be C<SQLite> or C<MySQL>. Less common values would be
+C<Oracle>, C<Sybase>, or C<ODBC>. The appropriate DBD::* Perl module for
+the chosen driver must be installed and will be dynamically loaded by the
+wallet. For more information, see L<DBI>.
+
+This variable must be set.
+
+=cut
+
+our $DB_DRIVER;
+
+=item DB_INFO
+
+Sets the remaining contents for the DBI DSN (everything after the driver).
+Using this variable provides full control over the connect string passed
+to DBI. When using SQLite, set this variable to the path to the SQLite
+database. If this variable is set, DB_NAME, DB_HOST, and DB_PORT are
+ignored. For more information, see L<DBI> and the documentation for the
+database driver you're using.
+
+Either DB_INFO or DB_NAME must be set. If you don't need to pass any
+additional information to DBI, set DB_INFO to the empty string (C<''>).
+
+=cut
+
+our $DB_INFO;
+
+=item DB_NAME
+
+If DB_INFO is not set, specifies the database name. The third part of the
+DBI connect string will be set to C<database=DB_NAME>, possibly with a
+host and port appended if DB_HOST and DB_PORT are set. For more
+information, see L<DBI> and the documentation for the database driver
+you're using.
+
+Either DB_INFO or DB_NAME must be set.
+
+=cut
+
+our $DB_NAME;
+
+=item DB_HOST
+
+If DB_INFO is not set, specifies the database host. C<;host=DB_HOST> will
+be appended to the DBI connect string. For more information, see L<DBI>
+and the documentation for the database driver you're using.
+
+=cut
+
+our $DB_HOST;
+
+=item DB_PORT
+
+If DB_PORT is not set, specifies the database port. C<;port=DB_PORT> will
+be appended to the DBI connect string. If this variable is set, DB_HOST
+should also be set. For more information, see L<DBI> and the
+documentation for the database driver you're using.
+
+=cut
+
+our $DB_PORT;
+
+=item DB_USER
+
+Specifies the user for database authentication. Some database backends,
+particularly SQLite, do not need this.
+
+=cut
+
+our $DB_USER;
+
+=item DB_PASSWORD
+
+Specifies the password for database authentication. Some database
+backends, particularly SQLite, do not need this.
+
+=cut
+
+our $DB_PASSWORD;
+
+=back
+
+=head1 DUO OBJECT CONFIGURATION
+
+These configuration variables only need to be set if you intend to use the
+C<duo> object type (the Wallet::Object::Duo class).
+
+=over 4
+
+=item DUO_AGENT
+
+If this configuration variable is set, its value should be an object that
+is call-compatible with LWP::UserAgent. This object will be used instead
+of LWP::UserAgent to make API calls to Duo. This is primarily useful for
+testing, allowing replacement of the user agent with a mock implementation
+so that a test can run without needing a Duo account.
+
+=cut
+
+our $DUO_AGENT;
+
+=item DUO_KEY_FILE
+
+The path to a file in JSON format that contains the key and hostname data
+for the Duo Admin API integration used to manage integrations via wallet.
+This file should be in the format expected by the C<key_file> parameter
+to the Net::Duo::Admin constructor. See L<Net::Duo::Admin> for more
+information.
+
+DUO_KEY_FILE must be set to use Duo objects.
+
+=cut
+
+our $DUO_KEY_FILE;
+
+=item DUO_TYPE
+
+The type of integration to create. Currently, only one type of integration
+can be created by one wallet configuration. This restriction may be relaxed
+in the future. The default value is C<unix> to create UNIX integrations.
+
+=cut
+
+our $DUO_TYPE = 'unix';
+
+=back
+
+=head1 FILE OBJECT CONFIGURATION
+
+These configuration variables only need to be set if you intend to use the
+C<file> object type (the Wallet::Object::File class).
+
+=over 4
+
+=item FILE_BUCKET
+
+The directory into which to store file objects. File objects will be
+stored in subdirectories of this directory. See L<Wallet::Object::File>
+for the full details of the naming scheme. This directory must be
+writable by the wallet server and the wallet server must be able to create
+subdirectories of it.
+
+FILE_BUCKET must be set to use file objects.
+
+=cut
+
+our $FILE_BUCKET;
+
+=item FILE_MAX_SIZE
+
+The maximum size of data that can be stored in a file object in bytes. If
+this configuration variable is set, an attempt to store data larger than
+this limit will be rejected.
+
+=cut
+
+our $FILE_MAX_SIZE;
+
+=back
+
+=head1 KEYTAB OBJECT CONFIGURATION
+
+These configuration variables only need to be set if you intend to use the
+C<keytab> object type (the Wallet::Object::Keytab class).
+
+=over 4
+
+=item KEYTAB_FILE
+
+Specifies the keytab to use to authenticate to B<kadmind>. The principal
+whose key is stored in this keytab must have the ability to create,
+modify, inspect, and delete any principals that should be managed by the
+wallet. (In MIT Kerberos F<kadm5.acl> parlance, this is C<admci>
+privileges.)
+
+KEYTAB_FILE must be set to use keytab objects.
+
+=cut
+
+our $KEYTAB_FILE;
+
+=item KEYTAB_FLAGS
+
+These flags, if any, are passed to the C<addprinc> command when creating a
+new principal in the Kerberos KDC. To not pass any flags, set
+KEYTAB_FLAGS to the empty string. The default value is C<-clearpolicy>,
+which clears any password strength policy from principals created by the
+wallet. (Since the wallet randomizes the keys, password strength checking
+is generally pointless and may interact poorly with the way C<addprinc
+-randkey> works when third-party add-ons for password strength checking
+are used.)
+
+=cut
+
+our $KEYTAB_FLAGS = '-clearpolicy';
+
+=item KEYTAB_HOST
+
+Specifies the host on which the kadmin service is running. This setting
+overrides the C<admin_server> setting in the [realms] section of
+F<krb5.conf> and any DNS SRV records and allows the wallet to run on a
+system that doesn't have a Kerberos configuration for the wallet's realm.
+
+=cut
+
+our $KEYTAB_HOST;
+
+=item KEYTAB_KADMIN
+
+The path to the B<kadmin> command-line client. The default value is
+C<kadmin>, which will cause the wallet to search for B<kadmin> on its
+default PATH.
+
+=cut
+
+our $KEYTAB_KADMIN = 'kadmin';
+
+=item KEYTAB_KRBTYPE
+
+The Kerberos KDC implementation type, either C<Heimdal> or C<MIT>
+(case-insensitive). KEYTAB_KRBTYPE must be set to use keytab objects.
+
+=cut
+
+our $KEYTAB_KRBTYPE;
+
+=item KEYTAB_PRINCIPAL
+
+The principal whose key is stored in KEYTAB_FILE. The wallet will
+authenticate as this principal to the kadmin service.
+
+KEYTAB_PRINCIPAL must be set to use keytab objects, at least until
+B<kadmin> is smart enough to use the first principal found in the keytab
+it's using for authentication.
+
+=cut
+
+our $KEYTAB_PRINCIPAL;
+
+=item KEYTAB_REALM
+
+Specifies the realm in which to create Kerberos principals. The keytab
+object implementation can only work in a single realm for a given wallet
+installation and the keytab object names are stored without realm.
+KEYTAB_REALM is added when talking to the KDC via B<kadmin>.
+
+KEYTAB_REALM must be set to use keytab objects. C<ktadd> doesn't always
+default to the local realm.
+
+=cut
+
+our $KEYTAB_REALM;
+
+=item KEYTAB_TMP
+
+A directory into which the wallet can write keytabs temporarily while
+processing C<get> commands from clients. The keytabs are written into
+this directory with predictable names, so this should not be a system
+temporary directory such as F</tmp> or F</var/tmp>. It's best to create a
+directory solely for this purpose that's owned by the user the wallet
+server will run as.
+
+KEYTAB_TMP must be set to use keytab objects.
+
+=cut
+
+our $KEYTAB_TMP;
+
+=back
+
+=head2 Retrieving Existing Keytabs
+
+Heimdal provides the choice, over the network protocol, of either
+downloading the existing keys for a principal or generating new random
+keys. MIT Kerberos does not; downloading a keytab over the kadmin
+protocol always rekeys the principal.
+
+For MIT Kerberos, the keytab object backend therefore optionally supports
+retrieving existing keys, and hence keytabs, for Kerberos principals by
+contacting the KDC via remctl and talking to B<keytab-backend>. This is
+enabled by setting the C<unchanging> flag on keytab objects. To configure
+that support, set the following variables.
+
+This is not required for Heimdal; for Heimdal, setting the C<unchanging>
+flag is all that's needed.
+
+=over 4
+
+=item KEYTAB_REMCTL_CACHE
+
+Specifies the ticket cache to use when retrieving existing keytabs from
+the KDC. This is only used to implement support for the C<unchanging>
+flag. The ticket cache must be for a principal with access to run
+C<keytab retrieve> via remctl on KEYTAB_REMCTL_HOST.
+
+=cut
+
+our $KEYTAB_REMCTL_CACHE;
+
+=item KEYTAB_REMCTL_HOST
+
+The host to which to connect with remctl to retrieve existing keytabs.
+This is only used to implement support for the C<unchanging> flag. This
+host must provide the C<keytab retrieve> command and KEYTAB_REMCTL_CACHE
+must also be set to a ticket cache for a principal with access to run that
+command.
+
+=cut
+
+our $KEYTAB_REMCTL_HOST;
+
+=item KEYTAB_REMCTL_PRINCIPAL
+
+The service principal to which to authenticate when retrieving existing
+keytabs. This is only used to implement support for the C<unchanging>
+flag. If this variable is not set, the default is formed by prepending
+C<host/> to KEYTAB_REMCTL_HOST. (Note that KEYTAB_REMCTL_HOST is not
+lowercased first.)
+
+=cut
+
+our $KEYTAB_REMCTL_PRINCIPAL;
+
+=item KEYTAB_REMCTL_PORT
+
+The port on KEYTAB_REMCTL_HOST to which to connect with remctl to retrieve
+existing keytabs. This is only used to implement support for the
+C<unchanging> flag. If this variable is not set, the default remctl port
+will be used.
+
+=cut
+
+our $KEYTAB_REMCTL_PORT;
+
+=back
+
+=head1 WEBAUTH KEYRING OBJECT CONFIGURATION
+
+These configuration variables only need to be set if you intend to use the
+C<wakeyring> object type (the Wallet::Object::WAKeyring class).
+
+=over 4
+
+=item WAKEYRING_BUCKET
+
+The directory into which to store WebAuth keyring objects. WebAuth
+keyring objects will be stored in subdirectories of this directory. See
+L<Wallet::Object::WAKeyring> for the full details of the naming scheme.
+This directory must be writable by the wallet server and the wallet server
+must be able to create subdirectories of it.
+
+WAKEYRING_BUCKET must be set to use WebAuth keyring objects.
+
+=cut
+
+our $WAKEYRING_BUCKET;
+
+=item WAKEYRING_REKEY_INTERVAL
+
+The interval, in seconds, at which new keys are generated in a keyring.
+The object implementation will try to arrange for there to be keys added
+to the keyring separated by this interval.
+
+It's useful to provide some interval to install the keyring everywhere
+that it's used before the key becomes inactive. Every keyring will
+therefore normally have at least three keys: one that's currently active,
+one that becomes valid in the future but less than
+WAKEYRING_REKEY_INTERVAL from now, and one that becomes valid between one
+and two of those intervals into the future. This means that one has twice
+this interval to distribute the keyring everywhere it is used.
+
+Internally, this is implemented by adding a new key that becomes valid in
+twice this interval from the current time if the newest key becomes valid
+at or less than this interval in the future.
+
+The default value is 60 * 60 * 24 (one day).
+
+=cut
+
+our $WAKEYRING_REKEY_INTERVAL = 60 * 60 * 24;
+
+=item WAKEYRING_PURGE_INTERVAL
+
+The interval, in seconds, from the key creation date after which keys are
+removed from the keyring. This is used to clean up old keys and finish
+key rotation. Keys won't be removed unless there are more than three keys
+in the keyring to try to keep a misconfiguration from removing all valid
+keys.
+
+The default value is 60 * 60 * 24 * 90 (90 days).
+
+=cut
+
+our $WAKEYRING_PURGE_INTERVAL = 60 * 60 * 24 * 90;
+
+=back
+
+=head1 LDAP ACL CONFIGURATION
+
+These configuration variables are only needed if you intend to use the
+C<ldap-attr> ACL type (the Wallet::ACL::LDAP::Attribute class). They
+specify the LDAP server and additional connection and data model
+information required for the wallet to check for the existence of
+attributes.
+
+=over 4
+
+=item LDAP_HOST
+
+The LDAP server name to use to verify LDAP ACLs. This variable must be
+set to use LDAP ACLs.
+
+=cut
+
+our $LDAP_HOST;
+
+=item LDAP_BASE
+
+The base DN under which to search for the entry corresponding to a
+principal. Currently, the wallet always does a full subtree search under
+this base DN. This variable must be set to use LDAP ACLs.
+
+=cut
+
+our $LDAP_BASE;
+
+=item LDAP_FILTER_ATTR
+
+The attribute used to find the entry corresponding to a principal. The
+LDAP entry containing this attribute with a value equal to the principal
+will be found and checked for the required attribute and value. If this
+variable is not set, the default is C<krb5PrincipalName>.
+
+=cut
+
+our $LDAP_FILTER_ATTR;
+
+=item LDAP_CACHE
+
+Specifies the Kerberos ticket cache to use when connecting to the LDAP
+server. GSS-API authentication is always used; there is currently no
+support for any other type of bind. The ticket cache must be for a
+principal with access to verify the values of attributes that will be used
+with this ACL type. This variable must be set to use LDAP ACLs.
+
+=cut
+
+our $LDAP_CACHE;
+
+=back
+
+Finally, depending on the structure of the LDAP directory being queried,
+there may not be any attribute in the directory whose value exactly
+matches the Kerberos principal. The attribute designated by
+LDAP_FILTER_ATTR may instead hold a transformation of the principal name
+(such as the principal with the local realm stripped off, or rewritten
+into an LDAP DN form). If this is the case, define a Perl function named
+ldap_map_principal. This function will be called whenever an LDAP
+attribute ACL is being verified. It will take one argument, the
+principal, and is expected to return the value to search for in the LDAP
+directory server.
+
+For example, if the principal name without the local realm is stored in
+the C<uid> attribute in the directory, set LDAP_FILTER_ATTR to C<uid> and
+then define ldap_map_attribute as follows:
+
+ sub ldap_map_principal {
+ my ($principal) = @_;
+ $principal =~ s/\@EXAMPLE\.COM$//;
+ return $principal;
+ }
+
+Note that this example only removes the local realm (here, EXAMPLE.COM).
+Any principal from some other realm will be left fully qualified, and then
+presumably will not be found in the directory.
+
+=head1 NETDB ACL CONFIGURATION
+
+These configuration variables are only needed if you intend to use the
+C<netdb> ACL type (the Wallet::ACL::NetDB class). They specify the remctl
+connection information for retrieving user roles from NetDB and the local
+realm to remove from principals (since NetDB normally expects unscoped
+local usernames).
+
+=over 4
+
+=item NETDB_REALM
+
+The wallet uses fully-qualified principal names (including the realm), but
+NetDB normally expects local usernames without the realm. If this
+variable is set, the given realm will be stripped from any principal names
+before passing them to NetDB. Principals in other realms will be passed
+to NetDB without modification.
+
+=cut
+
+our $NETDB_REALM;
+
+=item NETDB_REMCTL_CACHE
+
+Specifies the ticket cache to use when querying the NetDB remctl interface
+for user roles. The ticket cache must be for a principal with access to
+run C<netdb node-roles> via remctl on KEYTAB_REMCTL_HOST. This variable
+must be set to use NetDB ACLs.
+
+=cut
+
+our $NETDB_REMCTL_CACHE;
+
+=item NETDB_REMCTL_HOST
+
+The host to which to connect with remctl to query NetDB for user roles.
+This host must provide the C<netdb node-roles> command and
+NETDB_REMCTL_CACHE must also be set to a ticket cache for a principal with
+access to run that command. This variable must be set to use NetDB ACLs.
+
+=cut
+
+our $NETDB_REMCTL_HOST;
+
+=item NETDB_REMCTL_PRINCIPAL
+
+The service principal to which to authenticate when querying NetDB for
+user roles. If this variable is not set, the default is formed by
+prepending C<host/> to NETDB_REMCTL_HOST. (Note that NETDB_REMCTL_HOST is
+not lowercased first.)
+
+=cut
+
+our $NETDB_REMCTL_PRINCIPAL;
+
+=item NETDB_REMCTL_PORT
+
+The port on NETDB_REMCTL_HOST to which to connect with remctl to query
+NetDB for user roles. If this variable is not set, the default remctl
+port will be used.
+
+=cut
+
+our $NETDB_REMCTL_PORT;
+
+=back
+
+=head1 DEFAULT OWNERS
+
+By default, only users in the ADMIN ACL can create new objects in the
+wallet. To allow other users to create new objects, define a Perl
+function named default_owner. This function will be called whenever a
+non-ADMIN user tries to create a new object and will be passed the type
+and name of the object. It should return undef if there is no default
+owner for that object. If there is, it should return a list containing
+the name to use for the ACL and then zero or more anonymous arrays of two
+elements each giving the type and identifier for each ACL entry.
+
+For example, the following simple function says to use a default owner
+named C<default> with one entry of type C<krb5> and identifier
+C<rra@example.com> for the object with type C<keytab> and name
+C<host/example.com>:
+
+ sub default_owner {
+ my ($type, $name) = @_;
+ if ($type eq 'keytab' and $name eq 'host/example.com') {
+ return ('default', [ 'krb5', 'rra@example.com' ]);
+ } else {
+ return;
+ }
+ }
+
+Of course, normally this function is used for more complex mappings. Here
+is a more complete example. For objects of type keytab corresponding to
+various types of per-machine principals, return a default owner that sets
+as owner anyone with a NetDB role for that system and the system's host
+principal. This permits authorization management using NetDB while also
+allowing the system to bootstrap itself once the host principal has been
+downloaded and rekey itself using the old host principal.
+
+ sub default_owner {
+ my ($type, $name) = @_;
+ my %allowed = map { $_ => 1 }
+ qw(HTTP cifs host imap ldap nfs pop sieve smtp webauth);
+ my $realm = 'example.com';
+ return unless $type eq 'keytab';
+ return unless $name =~ m%/%;
+ my ($service, $instance) = split ('/', $name, 2);
+ return unless $allowed{$service};
+ my $acl_name = "host/$instance";
+ my @acl = ([ 'netdb', $instance ],
+ [ 'krb5', "host/$instance\@$realm" ]);
+ return ($acl_name, @acl);
+ }
+
+The auto-created ACL used for the owner of the new object will, in the
+above example, be named C<host/I<system>> where I<system> is the
+fully-qualified name of the system as derived from the keytab being
+requested.
+
+If the name of the ACL returned by the default_owner function matches an
+ACL that already exists in the wallet database, the existing ACL will be
+compared to the default ACL returned by the default_owner function. If
+the existing ACL has the same entries as the one returned by
+default_owner, 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 will be passed 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.
+
+This function is also called for naming audits done via Wallet::Report
+to find any existing objects that violate a (possibly updated) naming
+policy. In this case, the third argument (the identity of the person
+creating the object) will be undef. As a general rule, if the third
+argument is undef, the function should apply the most liberal accepted
+naming policy so that the audit returns only objects that violate all
+naming policies, but some sites may wish different results for their audit
+reports.
+
+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 by this example.
+
+=head1 ACL NAMING ENFORCEMENT
+
+Similar to object names, by default wallet permits administrators to
+create ACLs with any name. However, naming standards for ACLs can be
+enforced by defining a Perl function in the configuration file named
+verify_acl_name. If such a function exists, it will be called for any ACL
+creation or rename and will be passed given the new ACL 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.
+
+This function is also called for naming audits done via Wallet::Report to
+find any existing objects that violate a (possibly updated) naming policy.
+In this case, the second argument (the identity of the person creating the
+ACL) will be undef. As a general rule, if the second argument is undef,
+the function should apply the most liberal accepted naming policy so that
+the audit returns only ACLs that violate all naming policies, but some
+sites may wish different results for their audit reports.
+
+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_acl_name function would ensure that any
+ACLs created contain a slash and the part before the slash be one of
+C<host>, C<group>, C<user>, or C<service>.
+
+ sub verify_acl_name {
+ my ($name, $user) = @_;
+ return 'ACL names must contain a slash' unless $name =~ m,/,;
+ my ($first, $rest) = split ('/', $name, 2);
+ my %types = map { $_ => 1 } qw(host group user service);
+ unless ($types{$first}) {
+ return "unknown ACL type $first";
+ }
+ return;
+ }
+
+Obvious improvements could be made, such as checking that the part after
+the slash for a C<host/> ACL looked like a host name and the part after a
+slash for a C<user/> ACL look like a user name.
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item WALLET_CONFIG
+
+If this environment variable is set, it is taken to be the path to the
+wallet configuration file to load instead of F</etc/wallet/wallet.conf>.
+
+=back
+
+=cut
+
+# Now, load the configuration file so that it can override the defaults.
+if (-r $PATH) {
+ do $PATH or die (($@ || $!) . "\n");
+}
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+DBI(3), Wallet::Object::Keytab(3), Wallet::Server(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Database.pm b/perl/lib/Wallet/Database.pm
new file mode 100644
index 0000000..031be9e
--- /dev/null
+++ b/perl/lib/Wallet/Database.pm
@@ -0,0 +1,123 @@
+# Wallet::Database -- Wallet system database connection management.
+#
+# This module is a thin wrapper around DBIx::Class to handle determination
+# of the database configuration settings automatically on connect. The
+# intention is that Wallet::Database objects can be treated in all respects
+# like DBIx::Class objects in the rest of the code.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2008, 2009, 2010, 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Database;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Wallet::Schema;
+use Wallet::Config;
+
+@ISA = qw(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';
+
+##############################################################################
+# Core overrides
+##############################################################################
+
+# Override DBI::connect to supply our own connect string, username, and
+# password and to set some standard options. Takes no arguments other than
+# the implicit class argument.
+sub connect {
+ my ($class) = @_;
+ unless ($Wallet::Config::DB_DRIVER
+ and (defined ($Wallet::Config::DB_INFO)
+ or defined ($Wallet::Config::DB_NAME))) {
+ die "database connection information not configured\n";
+ }
+ my $dsn = "DBI:$Wallet::Config::DB_DRIVER:";
+ if (defined $Wallet::Config::DB_INFO) {
+ $dsn .= $Wallet::Config::DB_INFO;
+ } else {
+ $dsn .= "database=$Wallet::Config::DB_NAME";
+ $dsn .= ";host=$Wallet::Config::DB_HOST" if $Wallet::Config::DB_HOST;
+ $dsn .= ";port=$Wallet::Config::DB_PORT" if $Wallet::Config::DB_PORT;
+ }
+ my $user = $Wallet::Config::DB_USER;
+ my $pass = $Wallet::Config::DB_PASSWORD;
+ my %attrs = (PrintError => 0, RaiseError => 1);
+ my $dbh = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) };
+ if ($@) {
+ die "cannot connect to database: $@\n";
+ }
+ return $dbh;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=head1 NAME
+
+Wallet::Dabase - Wrapper module for wallet database connections
+
+=for stopwords
+DBI RaiseError PrintError AutoCommit Allbery
+
+=head1 SYNOPSIS
+
+ use Wallet::Database;
+ my $dbh = Wallet::Database->connect;
+
+=head1 DESCRIPTION
+
+Wallet::Database is a thin wrapper module around DBI that takes care of
+building a connect string and setting database options based on wallet
+configuration. The only overridden method is connect(). All other
+methods should work the same as in DBI and Wallet::Database objects should
+be usable exactly as if they were DBI objects.
+
+connect() will obtain the database connection information from the wallet
+configuration; see L<Wallet::Config> for more details. It will also
+automatically set the RaiseError attribute to true and the PrintError and
+AutoCommit attributes to false, matching the assumptions made by the
+wallet database code.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item connect()
+
+Opens a new database connection and returns the database object. On any
+failure, throws an exception. Unlike the DBI method, connect() takes no
+arguments; all database connection information is derived from the wallet
+configuration.
+
+=back
+
+=head1 SEE ALSO
+
+DBI(3), Wallet::Config(3)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Kadmin.pm b/perl/lib/Wallet/Kadmin.pm
new file mode 100644
index 0000000..4ea7920
--- /dev/null
+++ b/perl/lib/Wallet/Kadmin.pm
@@ -0,0 +1,240 @@
+# Wallet::Kadmin -- Kerberos administration API for wallet keytab backend.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2009, 2010
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Kadmin;
+require 5.006;
+
+use strict;
+use vars qw($VERSION);
+
+use Wallet::Config ();
+
+# 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.03';
+
+##############################################################################
+# Utility functions for child classes
+##############################################################################
+
+# Read the entirety of a possibly binary file and return the contents,
+# deleting the file after reading it. If reading the file fails, set the
+# error message and return undef.
+sub read_keytab {
+ my ($self, $file) = @_;
+ local *TMPFILE;
+ unless (open (TMPFILE, '<', $file)) {
+ $self->error ("cannot open temporary file $file: $!");
+ return;
+ }
+ local $/;
+ undef $!;
+ my $data = <TMPFILE>;
+ if ($!) {
+ $self->error ("cannot read temporary file $file: $!");
+ unlink $file;
+ return;
+ }
+ close TMPFILE;
+ unlink $file;
+ return $data;
+}
+
+##############################################################################
+# Public methods
+##############################################################################
+
+# Create a new kadmin object, by finding the type requested in the wallet
+# config and passing off to the proper module. Returns the object directly
+# from the specific Wallet::Kadmin::* module.
+sub new {
+ my ($class) = @_;
+ my $kadmin;
+ if (not $Wallet::Config::KEYTAB_KRBTYPE) {
+ die "keytab object implementation not configured\n";
+ } elsif (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'mit') {
+ require Wallet::Kadmin::MIT;
+ $kadmin = Wallet::Kadmin::MIT->new;
+ } elsif (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'heimdal') {
+ require Wallet::Kadmin::Heimdal;
+ $kadmin = Wallet::Kadmin::Heimdal->new;
+ } else {
+ my $type = $Wallet::Config::KEYTAB_KRBTYPE;
+ die "unknown KEYTAB_KRBTYPE setting: $type\n";
+ }
+
+ return $kadmin;
+}
+
+# Set or return the error stashed in the object.
+sub error {
+ my ($self, @error) = @_;
+ if (@error) {
+ my $error = join ('', @error);
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ $self->{error} = $error;
+ }
+ return $self->{error};
+}
+
+# Set a callback to be called for forked kadmin processes. This does nothing
+# by default but may be overridden by subclasses that need special behavior
+# (such as the current Wallet::Kadmin::MIT module).
+sub fork_callback { }
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+backend Kadmin keytabs keytab Heimdal API kadmind kadmin KDC ENCTYPE
+enctypes enctype Allbery
+
+=head1 NAME
+
+Wallet::Kadmin - Kerberos administration API for wallet keytab backend
+
+=head1 SYNOPSIS
+
+ my $kadmin = Wallet::Kadmin->new;
+ $kadmin->create ('host/foo.example.com');
+ my $data = $kadmin->keytab_rekey ('host/foo.example.com',
+ 'aes256-cts-hmac-sha1-96');
+ $data = $kadmin->keytab ('host/foo.example.com');
+ my $exists = $kadmin->exists ('host/oldshell.example.com');
+ $kadmin->destroy ('host/oldshell.example.com') if $exists;
+
+=head1 DESCRIPTION
+
+Wallet::Kadmin is a wrapper and base class for modules that provide an
+interface for wallet to do Kerberos administration, specifically create
+and delete principals and create keytabs for a principal. Each subclass
+administers a specific type of Kerberos implementation, such as MIT
+Kerberos or Heimdal, providing a standard set of API calls used to
+interact with that implementation's kadmin interface.
+
+The class uses Wallet::Config to find which type of kadmin interface is in
+use and then returns an object to use for interacting with that interface.
+See L<Wallet::Config/"KEYTAB OBJECT CONFIGURATION"> for details on how to
+configure this module.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new()
+
+Finds the proper Kerberos implementation and calls the new() constructor
+for that implementation's module, returning the resulting object. If the
+implementation is not recognized or set, die with an error message.
+
+=back
+
+=head1 INSTANCE METHODS
+
+These methods are provided by any object returned by new(), regardless of
+the underlying kadmin interface. They are implemented by the child class
+appropriate for the configured Kerberos implementation.
+
+=over 4
+
+=item create(PRINCIPAL)
+
+Adds a new principal with a given name. The principal is created with a
+random password, and any other flags set by Wallet::Config. Returns true
+on success and false on failure. If the principal already exists, return
+true as we are bringing our expectations in line with reality.
+
+=item destroy(PRINCIPAL)
+
+Removes a principal with the given name. Returns true on success or false
+on failure. If the principal does not exist, return true as we are
+bringing our expectations in line with reality.
+
+=item error([ERROR ...])
+
+Returns the error of the last failing operation or undef if no operations
+have failed. Callers should call this function to get the error message
+after an undef return from any other instance method.
+
+For the convenience of child classes, this method can also be called with
+one or more error strings. If so, those strings are concatenated
+together, trailing newlines are removed, any text of the form S<C< at \S+
+line \d+\.?>> at the end of the message is stripped off, and the result is
+stored as the error. Only child classes should call this method with an
+error string.
+
+=item exists(PRINCIPAL)
+
+Returns true if the given principal exists in the KDC and C<0> if it
+doesn't. If an error is encountered in checking whether the principal
+exists, exists() returns undef.
+
+=item fork_callback(CALLBACK)
+
+If the module has to fork an external process for some reason, such as a
+kadmin command-line client, the sub CALLBACK will be called in the child
+process before running the program. This can be used to, for example,
+properly clean up shared database handles.
+
+=item keytab(PRINCIPAL)
+
+keytab() creates a keytab for the given principal, storing it in the given
+file. A keytab is an on-disk store for the key or keys for a Kerberos
+principal. Keytabs are used by services to verify incoming authentication
+from clients or by automated processes that need to authenticate to
+Kerberos. To create a keytab, the principal has to have previously been
+created in the Kerberos KDC. Returns the keytab as binary data on success
+and undef on failure.
+
+=item keytab_rekey(PRINCIPAL [, ENCTYPE ...])
+
+Like keytab(), but randomizes the key for the principal before generating
+the keytab and writes it to the given file. This will invalidate any
+existing keytabs for that principal. This method can also limit the
+encryption types of the keys for that principal via the optional ENCTYPE
+arguments. The enctype values must be enctype strings recognized by the
+Kerberos implementation (strings like C<aes256-cts-hmac-sha1-96> or
+C<des-cbc-crc>). If none are given, the KDC defaults will be used.
+Returns the keytab as binary data on success and undef on failure.
+
+=back
+
+The following methods are utility methods to aid with child class
+implementation and should only be called by child classes.
+
+=over 4
+
+=item read_keytab(FILE)
+
+Reads the contents of the keytab stored in FILE into memory and returns it
+as binary data. On failure, returns undef and sets the object error.
+
+=back
+
+=head1 SEE ALSO
+
+kadmin(8), Wallet::Config(3), Wallet::Object::Keytab(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHORS
+
+Jon Robertson <jonrober@stanford.edu> and Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Kadmin/Heimdal.pm b/perl/lib/Wallet/Kadmin/Heimdal.pm
new file mode 100644
index 0000000..42de8e0
--- /dev/null
+++ b/perl/lib/Wallet/Kadmin/Heimdal.pm
@@ -0,0 +1,314 @@
+# Wallet::Kadmin::Heimdal -- Wallet Kerberos administration API for Heimdal.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2009, 2010, 2014
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Kadmin::Heimdal;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Heimdal::Kadm5 qw(KRB5_KDB_DISALLOW_ALL_TIX);
+use Wallet::Config ();
+use Wallet::Kadmin ();
+
+@ISA = qw(Wallet::Kadmin);
+
+# 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';
+
+##############################################################################
+# Utility functions
+##############################################################################
+
+# Add the realm to the end of the principal if no realm is currently present.
+sub canonicalize_principal {
+ my ($self, $principal) = @_;
+ if ($Wallet::Config::KEYTAB_REALM && $principal !~ /\@/) {
+ $principal .= '@' . $Wallet::Config::KEYTAB_REALM;
+ }
+ return $principal;
+}
+
+# Generate a long random password.
+#
+# Please note: This is not a cryptographically secure password! It's used
+# only because the Heimdal kadmin interface requires a password on create.
+# The keys will be set before the principal is ever set active, so it will
+# never be possible to use the password. It just needs to be random in case
+# password quality checks are applied to it.
+#
+# Make the password reasonably long and include a variety of character classes
+# so that it should pass any password strength checking.
+sub insecure_random_password {
+ my ($self) = @_;
+ my @classes = (
+ 'abcdefghijklmnopqrstuvwxyz',
+ 'ABCDEFGHIJKLMNOPQRSTUVWXYZ',
+ '0123456789',
+ '~`!@#$%^&*()-_+={[}]|:;<,>.?/'
+ );
+ my $password = q{};
+ for my $i (1..20) {
+ my $class = $i % scalar (@classes);
+ my $alphabet = $classes[$class];
+ my $letter = substr ($alphabet, int (rand (length $alphabet)), 1);
+ $password .= $letter;
+ }
+ return $password;
+}
+
+##############################################################################
+# Public interfaces
+##############################################################################
+
+# Check whether a given principal already exists in Kerberos. Returns true if
+# so, false otherwise.
+sub exists {
+ my ($self, $principal) = @_;
+ $principal = $self->canonicalize_principal ($principal);
+ my $kadmin = $self->{client};
+ my $princdata = eval { $kadmin->getPrincipal ($principal) };
+ if ($@) {
+ $self->error ("error getting principal: $@");
+ return;
+ }
+ return $princdata ? 1 : 0;
+}
+
+# Create a principal in Kerberos. If there is an error, return undef and set
+# the error. Return 1 on success or the principal already existing.
+sub create {
+ my ($self, $principal) = @_;
+ $principal = $self->canonicalize_principal ($principal);
+ my $exists = eval { $self->exists ($principal) };
+ if ($@) {
+ $self->error ("error adding principal $principal: $@");
+ return;
+ }
+ return 1 if $exists;
+
+ # The way Heimdal::Kadm5 works, we create a principal object, create the
+ # actual principal set inactive, then randomize it and activate it. We
+ # have to set a password, even though we're about to replace it with
+ # random keys, but since the principal is created inactive, it doesn't
+ # have to be a very good one.
+ my $kadmin = $self->{client};
+ eval {
+ my $princdata = $kadmin->makePrincipal ($principal);
+ my $attrs = $princdata->getAttributes;
+ $attrs |= KRB5_KDB_DISALLOW_ALL_TIX;
+ $princdata->setAttributes ($attrs);
+ my $password = $self->insecure_random_password;
+ $kadmin->createPrincipal ($princdata, $password, 0);
+ $kadmin->randKeyPrincipal ($principal);
+ $kadmin->enablePrincipal ($principal);
+ };
+ if ($@) {
+ $self->error ("error adding principal $principal: $@");
+ return;
+ }
+ return 1;
+}
+
+# Create a keytab for a principal. Returns the keytab as binary data or undef
+# on failure, setting the error.
+sub keytab {
+ my ($self, $principal) = @_;
+ $principal = $self->canonicalize_principal ($principal);
+ my $kadmin = $self->{client};
+ my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$";
+ unlink $file;
+ my $princdata = eval { $kadmin->getPrincipal ($principal) };
+ if ($@) {
+ $self->error ("error creating keytab for $principal: $@");
+ return;
+ } elsif (!$princdata) {
+ $self->error ("error creating keytab for $principal: principal does"
+ . " not exist");
+ return;
+ }
+ eval { $kadmin->extractKeytab ($princdata, $file) };
+ if ($@) {
+ $self->error ("error creating keytab for principal: $@");
+ return;
+ }
+ return $self->read_keytab ($file);
+}
+
+# Create a keytab for a principal, randomizing the keys for that principal at
+# the same time. Takes the principal and an optional list of encryption types
+# to which to limit the keytab. Return the keytab data on success and undef
+# on failure. If the keytab creation fails, sets the error.
+sub keytab_rekey {
+ my ($self, $principal, @enctypes) = @_;
+ $principal = $self->canonicalize_principal ($principal);
+
+ # The way Heimdal works, you can only remove enctypes from a principal,
+ # not add them back in. So we need to run randkeyPrincipal first each
+ # time to restore all possible enctypes and then whittle them back down
+ # to those we have been asked for this time.
+ my $kadmin = $self->{client};
+ eval { $kadmin->randKeyPrincipal ($principal) };
+ if ($@) {
+ $self->error ("error creating keytab for $principal: could not"
+ . " reinit enctypes: $@");
+ return;
+ }
+ my $princdata = eval { $kadmin->getPrincipal ($principal) };
+ if ($@) {
+ $self->error ("error creating keytab for $principal: $@");
+ return;
+ } elsif (!$princdata) {
+ $self->error ("error creating keytab for $principal: principal does"
+ . " not exist");
+ return;
+ }
+
+ # Now actually remove any non-requested enctypes, if we requested any.
+ if (@enctypes) {
+ my $alltypes = $princdata->getKeytypes;
+ my %wanted = map { $_ => 1 } @enctypes;
+ for my $key (@{ $alltypes }) {
+ my $keytype = $key->[0];
+ next if exists $wanted{$keytype};
+ eval { $princdata->delKeytypes ($keytype) };
+ if ($@) {
+ $self->error ("error removing keytype $keytype from the"
+ . " keytab: $@");
+ return;
+ }
+ }
+ eval { $kadmin->modifyPrincipal ($princdata) };
+ if ($@) {
+ $self->error ("error saving principal modifications: $@");
+ return;
+ }
+ }
+
+ # Create the keytab.
+ my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$";
+ unlink $file;
+ eval { $kadmin->extractKeytab ($princdata, $file) };
+ if ($@) {
+ $self->error ("error creating keytab for principal: $@");
+ return;
+ }
+ return $self->read_keytab ($file);
+}
+
+# Delete a principal from Kerberos. Return true if successful, false
+# otherwise. If the deletion fails, sets the error. If the principal doesn't
+# exist, return success; we're bringing reality in line with our expectations.
+sub destroy {
+ my ($self, $principal) = @_;
+ $principal = $self->canonicalize_principal ($principal);
+ my $exists = eval { $self->exists ($principal) };
+ if ($@) {
+ $self->error ("error checking principal existance: $@");
+ return;
+ } elsif (not $exists) {
+ return 1;
+ }
+ my $kadmin = $self->{client};
+ my $retval = eval { $kadmin->deletePrincipal ($principal) };
+ if ($@) {
+ $self->error ("error deleting $principal: $@");
+ return;
+ }
+ return 1;
+}
+
+# Create a new Wallet::Kadmin::Heimdal object and its underlying
+# Heimdal::Kadm5 object.
+sub new {
+ my ($class) = @_;
+ unless (defined ($Wallet::Config::KEYTAB_PRINCIPAL)
+ and defined ($Wallet::Config::KEYTAB_FILE)
+ and defined ($Wallet::Config::KEYTAB_REALM)) {
+ die "keytab object implementation not configured\n";
+ }
+ unless (defined ($Wallet::Config::KEYTAB_TMP)) {
+ die "KEYTAB_TMP configuration variable not set\n";
+ }
+ my @options = (RaiseError => 1,
+ Principal => $Wallet::Config::KEYTAB_PRINCIPAL,
+ Realm => $Wallet::Config::KEYTAB_REALM,
+ Keytab => $Wallet::Config::KEYTAB_FILE);
+ if ($Wallet::Config::KEYTAB_HOST) {
+ push (@options, Server => $Wallet::Config::KEYTAB_HOST);
+ }
+ my $client = Heimdal::Kadm5::Client->new (@options);
+ my $self = { client => $client };
+ bless ($self, $class);
+ return $self;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+keytabs keytab kadmin KDC API Allbery Heimdal unlinked
+
+=head1 NAME
+
+Wallet::Kadmin::Heimdal - Wallet Kerberos administration API for Heimdal
+
+=head1 SYNOPSIS
+
+ my $kadmin = Wallet::Kadmin::Heimdal->new;
+ $kadmin->create ('host/foo.example.com');
+ $kadmin->keytab_rekey ('host/foo.example.com', 'keytab',
+ 'aes256-cts-hmac-sha1-96');
+ my $data = $kadmin->keytab ('host/foo.example.com');
+ my $exists = $kadmin->exists ('host/oldshell.example.com');
+ $kadmin->destroy ('host/oldshell.example.com') if $exists;
+
+=head1 DESCRIPTION
+
+Wallet::Kadmin::Heimdal implements the Wallet::Kadmin API for Heimdal,
+providing an interface to create and delete principals and create keytabs.
+It provides the API documented in L<Wallet::Kadmin> for a Heimdal KDC.
+
+To use this class, several configuration parameters must be set. See
+L<Wallet::Config/"KEYTAB OBJECT CONFIGURATION"> for details.
+
+=head1 FILES
+
+=over 4
+
+=item KEYTAB_TMP/keytab.<pid>
+
+The keytab is created in this file and then read into memory. KEYTAB_TMP
+is set in the wallet configuration, and <pid> is the process ID of the
+current process. The file is unlinked after being read.
+
+=back
+
+=head1 SEE ALSO
+
+kadmin(8), Wallet::Config(3), Wallet::Kadmin(3),
+Wallet::Object::Keytab(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHORS
+
+Russ Allbery <eagle@eyrie.org> and Jon Robertson <jonrober@stanford.edu>.
+
+=cut
diff --git a/perl/lib/Wallet/Kadmin/MIT.pm b/perl/lib/Wallet/Kadmin/MIT.pm
new file mode 100644
index 0000000..1ae01bf
--- /dev/null
+++ b/perl/lib/Wallet/Kadmin/MIT.pm
@@ -0,0 +1,323 @@
+# Wallet::Kadmin::MIT -- Wallet Kerberos administration API for MIT.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Pulled into a module by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2007, 2008, 2009, 2010
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Kadmin::MIT;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Wallet::Config ();
+use Wallet::Kadmin ();
+
+@ISA = qw(Wallet::Kadmin);
+
+# 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.03';
+
+##############################################################################
+# kadmin Interaction
+##############################################################################
+
+# Make sure that principals are well-formed and don't contain characters that
+# will cause us problems when talking to kadmin. Takes a principal and
+# returns true if it's okay, false otherwise. Note that we do not permit
+# realm information here.
+sub valid_principal {
+ my ($self, $principal) = @_;
+ return scalar ($principal =~ m,^[\w-]+(/[\w_.-]+)?\z,);
+}
+
+# Run a kadmin command and capture the output. Returns the output, either as
+# a list of lines or, in scalar context, as one string. The exit status of
+# kadmin is often worthless.
+sub kadmin {
+ my ($self, $command) = @_;
+ unless (defined ($Wallet::Config::KEYTAB_PRINCIPAL)
+ and defined ($Wallet::Config::KEYTAB_FILE)
+ and defined ($Wallet::Config::KEYTAB_REALM)) {
+ die "keytab object implementation not configured\n";
+ }
+ my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', '-t',
+ $Wallet::Config::KEYTAB_FILE, '-q', $command);
+ push (@args, '-s', $Wallet::Config::KEYTAB_HOST)
+ if $Wallet::Config::KEYTAB_HOST;
+ push (@args, '-r', $Wallet::Config::KEYTAB_REALM)
+ if $Wallet::Config::KEYTAB_REALM;
+ my $pid = open (KADMIN, '-|');
+ if (not defined $pid) {
+ $self->error ("cannot fork: $!");
+ return;
+ } elsif ($pid == 0) {
+ $self->{fork_callback} () if $self->{fork_callback};
+ unless (open (STDERR, '>&STDOUT')) {
+ warn "wallet: cannot dup stdout: $!\n";
+ exit 1;
+ }
+ unless (exec ($Wallet::Config::KEYTAB_KADMIN, @args)) {
+ warn "wallet: cannot run $Wallet::Config::KEYTAB_KADMIN: $!\n";
+ exit 1;
+ }
+ }
+ local $_;
+ my @output;
+ while (<KADMIN>) {
+ if (/^wallet: cannot /) {
+ s/^wallet: //;
+ $self->error ($_);
+ return;
+ }
+ push (@output, $_) unless /Authenticating as principal/;
+ }
+ close KADMIN;
+ return wantarray ? @output : join ('', @output);
+}
+
+##############################################################################
+# Public interfaces
+##############################################################################
+
+# Set a callback to be called for forked kadmin processes.
+sub fork_callback {
+ my ($self, $callback) = @_;
+ $self->{fork_callback} = $callback;
+}
+
+# Check whether a given principal already exists in Kerberos. Returns true if
+# so, false otherwise. Returns undef if kadmin fails, with the error already
+# set by kadmin.
+sub exists {
+ my ($self, $principal) = @_;
+ return unless $self->valid_principal ($principal);
+ if ($Wallet::Config::KEYTAB_REALM) {
+ $principal .= '@' . $Wallet::Config::KEYTAB_REALM;
+ }
+ my $output = $self->kadmin ("getprinc $principal");
+ if (!defined $output) {
+ return;
+ } elsif ($output =~ /^get_principal: /) {
+ return 0;
+ } else {
+ return 1;
+ }
+}
+
+# Create a principal in Kerberos. Sets the error and returns undef on failure,
+# and returns 1 on either success or the principal already existing.
+sub create {
+ my ($self, $principal) = @_;
+ unless ($self->valid_principal ($principal)) {
+ $self->error ("invalid principal name $principal");
+ return;
+ }
+ return 1 if $self->exists ($principal);
+ if ($Wallet::Config::KEYTAB_REALM) {
+ $principal .= '@' . $Wallet::Config::KEYTAB_REALM;
+ }
+ my $flags = $Wallet::Config::KEYTAB_FLAGS || '';
+ my $output = $self->kadmin ("addprinc -randkey $flags $principal");
+ if (!defined $output) {
+ return;
+ } elsif ($output =~ /^add_principal: (.*)/m) {
+ $self->error ("error adding principal $principal: $1");
+ return;
+ }
+ return 1;
+}
+
+# Retrieve an existing keytab from the KDC via a remctl call. The KDC needs
+# to be running the keytab-backend script and support the keytab retrieve
+# remctl command. In addition, the user must have configured us with the path
+# to a ticket cache and the host to which to connect with remctl. Returns the
+# keytab on success and undef on failure.
+sub keytab {
+ my ($self, $principal) = @_;
+ my $host = $Wallet::Config::KEYTAB_REMCTL_HOST;
+ unless ($host and $Wallet::Config::KEYTAB_REMCTL_CACHE) {
+ $self->error ('keytab unchanging support not configured');
+ return;
+ }
+ eval { require Net::Remctl };
+ if ($@) {
+ $self->error ("keytab unchanging support not available: $@");
+ return;
+ }
+ if ($principal !~ /\@/ && $Wallet::Config::KEYTAB_REALM) {
+ $principal .= '@' . $Wallet::Config::KEYTAB_REALM;
+ }
+ local $ENV{KRB5CCNAME} = $Wallet::Config::KEYTAB_REMCTL_CACHE;
+ my $port = $Wallet::Config::KEYTAB_REMCTL_PORT || 0;
+ my $remctl_princ = $Wallet::Config::KEYTAB_REMCTL_PRINCIPAL || '';
+ my @command = ('keytab', 'retrieve', $principal);
+ my $result = Net::Remctl::remctl ($host, $port, $remctl_princ, @command);
+ if ($result->error) {
+ $self->error ("cannot retrieve keytab for $principal: ",
+ $result->error);
+ return;
+ } elsif ($result->status != 0) {
+ my $error = $result->stderr;
+ $error =~ s/\s+$//;
+ $error =~ s/\n/ /g;
+ $self->error ("cannot retrieve keytab for $principal: $error");
+ return;
+ } else {
+ return $result->stdout;
+ }
+}
+
+# Create a keytab for a principal, randomizing the keys for that principal
+# in the process. Takes the principal and an optional list of encryption
+# types to which to limit the keytab. Return the keytab data on success
+# and undef otherwise. If the keytab creation fails, sets the error.
+sub keytab_rekey {
+ my ($self, $principal, @enctypes) = @_;
+ unless ($self->valid_principal ($principal)) {
+ $self->error ("invalid principal name: $principal");
+ return;
+ }
+ if ($Wallet::Config::KEYTAB_REALM) {
+ $principal .= '@' . $Wallet::Config::KEYTAB_REALM;
+ }
+ my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$";
+ unlink $file;
+ my $command = "ktadd -q -k $file";
+ if (@enctypes) {
+ @enctypes = map { /:/ ? $_ : "$_:normal" } @enctypes;
+ $command .= ' -e "' . join (' ', @enctypes) . '"';
+ }
+ my $output = $self->kadmin ("$command $principal");
+ if (!defined $output) {
+ return;
+ } elsif ($output =~ /^(?:kadmin|ktadd): (.*)/m) {
+ $self->error ("error creating keytab for $principal: $1");
+ return;
+ }
+ return $self->read_keytab ($file);
+}
+
+# Delete a principal from Kerberos. Return true if successful, false
+# otherwise. If the deletion fails, sets the error. If the principal doesn't
+# exist, return success; we're bringing reality in line with our expectations.
+sub destroy {
+ my ($self, $principal) = @_;
+ unless ($self->valid_principal ($principal)) {
+ $self->error ("invalid principal name: $principal");
+ }
+ my $exists = $self->exists ($principal);
+ if (!defined $exists) {
+ return;
+ } elsif (not $exists) {
+ return 1;
+ }
+ if ($Wallet::Config::KEYTAB_REALM) {
+ $principal .= '@' . $Wallet::Config::KEYTAB_REALM;
+ }
+ my $output = $self->kadmin ("delprinc -force $principal");
+ if (!defined $output) {
+ return;
+ } elsif ($output =~ /^delete_principal: (.*)/m) {
+ $self->error ("error deleting $principal: $1");
+ return;
+ }
+ return 1;
+}
+
+# Create a new MIT kadmin object. Very empty for the moment, but later it
+# will probably fill out if we go to using a module rather than calling
+# kadmin directly.
+sub new {
+ my ($class) = @_;
+ unless (defined ($Wallet::Config::KEYTAB_TMP)) {
+ die "KEYTAB_TMP configuration variable not set\n";
+ }
+ my $self = {};
+ bless ($self, $class);
+ return $self;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+rekeying rekeys remctl backend keytabs keytab kadmin KDC API Allbery
+unlinked
+
+=head1 NAME
+
+Wallet::Kadmin::MIT - Wallet Kerberos administration API for MIT
+
+=head1 SYNOPSIS
+
+ my $kadmin = Wallet::Kadmin::MIT->new;
+ $kadmin->create ('host/foo.example.com');
+ my $data = $kadmin->keytab_rekey ('host/foo.example.com',
+ 'aes256-cts-hmac-sha1-96');
+ $data = $kadmin->keytab ('host/foo.example.com');
+ my $exists = $kadmin->exists ('host/oldshell.example.com');
+ $kadmin->destroy ('host/oldshell.example.com') if $exists;
+
+=head1 DESCRIPTION
+
+Wallet::Kadmin::MIT implements the Wallet::Kadmin API for MIT Kerberos,
+providing an interface to create and delete principals and create keytabs.
+It provides the API documented in L<Wallet::Kadmin> for an MIT Kerberos
+KDC.
+
+MIT Kerberos does not provide any method via the kadmin network protocol
+to retrieve a keytab for a principal without rekeying it, so the keytab()
+method (as opposed to keytab_rekey(), which rekeys the principal) is
+implemented using a remctl backend. For that method (used for unchanging
+keytab objects) to work, the necessary wallet configuration and remctl
+interface on the KDC must be set up.
+
+To use this class, several configuration parameters must be set. See
+L<Wallet::Config/"KEYTAB OBJECT CONFIGURATION"> for details.
+
+=head1 FILES
+
+=over 4
+
+=item KEYTAB_TMP/keytab.<pid>
+
+The keytab is created in this file and then read into memory. KEYTAB_TMP
+is set in the wallet configuration, and <pid> is the process ID of the
+current process. The file is unlinked after being read.
+
+=back
+
+=head1 LIMITATIONS
+
+Currently, this implementation calls an external B<kadmin> program rather
+than using a native Perl module and therefore requires B<kadmin> be
+installed and parses its output. It may miss some error conditions if the
+output of B<kadmin> ever changes.
+
+=head1 SEE ALSO
+
+kadmin(8), Wallet::Config(3), Wallet::Kadmin(3),
+Wallet::Object::Keytab(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHORS
+
+Russ Allbery <eagle@eyrie.org> and Jon Robertson <jonrober@stanford.edu>.
+
+=cut
diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm
new file mode 100644
index 0000000..8debac9
--- /dev/null
+++ b/perl/lib/Wallet/Object/Base.pm
@@ -0,0 +1,1015 @@
+# Wallet::Object::Base -- Parent class for any object stored in the wallet.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2008, 2010, 2011
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Object::Base;
+require 5.006;
+
+use strict;
+use vars qw($VERSION);
+
+use DBI;
+use POSIX qw(strftime);
+use Text::Wrap qw(wrap);
+use Wallet::ACL;
+
+# 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.06';
+
+##############################################################################
+# Constructors
+##############################################################################
+
+# Initialize an object from the database. Verifies that the object already
+# exists with the given type, and if it does, returns a new blessed object of
+# the specified class. Stores the database handle to use, the name, and the
+# type in the object. If the object doesn't exist, returns undef. This will
+# probably be usable as-is by most object types.
+sub new {
+ my ($class, $type, $name, $schema) = @_;
+ my %search = (ob_type => $type,
+ ob_name => $name);
+ my $object = $schema->resultset('Object')->find (\%search);
+ die "cannot find ${type}:${name}\n"
+ unless ($object and $object->ob_name eq $name);
+ my $self = {
+ schema => $schema,
+ name => $name,
+ type => $type,
+ };
+ bless ($self, $class);
+ return $self;
+}
+
+# Create a new object in the database of the specified name and type, setting
+# the ob_created_* fields accordingly, and returns a new blessed object of the
+# specified class. Stores the database handle to use, the name, and the type
+# in the object. Subclasses may need to override this to do additional setup.
+sub create {
+ my ($class, $type, $name, $schema, $user, $host, $time) = @_;
+ $time ||= time;
+ die "invalid object type\n" unless $type;
+ die "invalid object name\n" unless $name;
+ my $guard = $schema->txn_scope_guard;
+ eval {
+ my %record = (ob_type => $type,
+ ob_name => $name,
+ ob_created_by => $user,
+ ob_created_from => $host,
+ ob_created_on => strftime ('%Y-%m-%d %T',
+ localtime $time));
+ $schema->resultset('Object')->create (\%record);
+
+ %record = (oh_type => $type,
+ oh_name => $name,
+ oh_action => 'create',
+ oh_by => $user,
+ oh_from => $host,
+ oh_on => strftime ('%Y-%m-%d %T', localtime $time));
+ $schema->resultset('ObjectHistory')->create (\%record);
+
+ $guard->commit;
+ };
+ if ($@) {
+ die "cannot create object ${type}:${name}: $@\n";
+ }
+ my $self = {
+ schema => $schema,
+ name => $name,
+ type => $type,
+ };
+ bless ($self, $class);
+ return $self;
+}
+
+##############################################################################
+# Utility functions
+##############################################################################
+
+# Set or return the error stashed in the object.
+sub error {
+ my ($self, @error) = @_;
+ if (@error) {
+ my $error = join ('', @error);
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ $self->{error} = $error;
+ }
+ return $self->{error};
+}
+
+# Returns the type of the object.
+sub type {
+ my ($self) = @_;
+ return $self->{type};
+}
+
+# Returns the name of the object.
+sub name {
+ my ($self) = @_;
+ return $self->{name};
+}
+
+# Record a global object action for this object. Takes the action (which must
+# be one of get or store), and the trace information: user, host, and time.
+# Returns true on success and false on failure, setting error appropriately.
+#
+# This function commits its transaction when complete and should not be called
+# inside another transaction.
+sub log_action {
+ my ($self, $action, $user, $host, $time) = @_;
+ unless ($action =~ /^(get|store)\z/) {
+ $self->error ("invalid history action $action");
+ return;
+ }
+
+ # We have two traces to record, one in the object_history table and one in
+ # the object record itself. Commit both changes as a transaction. We
+ # assume that AutoCommit is turned off.
+ my $guard = $self->{schema}->txn_scope_guard;
+ eval {
+ my %record = (oh_type => $self->{type},
+ oh_name => $self->{name},
+ oh_action => $action,
+ oh_by => $user,
+ oh_from => $host,
+ oh_on => strftime ('%Y-%m-%d %T', localtime $time));
+ $self->{schema}->resultset('ObjectHistory')->create (\%record);
+
+ my %search = (ob_type => $self->{type},
+ ob_name => $self->{name});
+ my $object = $self->{schema}->resultset('Object')->find (\%search);
+ if ($action eq 'get') {
+ $object->ob_downloaded_by ($user);
+ $object->ob_downloaded_from ($host);
+ $object->ob_downloaded_on (strftime ('%Y-%m-%d %T',
+ localtime $time));
+ } elsif ($action eq 'store') {
+ $object->ob_stored_by ($user);
+ $object->ob_stored_from ($host);
+ $object->ob_stored_on (strftime ('%Y-%m-%d %T',
+ localtime $time));
+ }
+ $object->update;
+ $guard->commit;
+ };
+ if ($@) {
+ my $id = $self->{type} . ':' . $self->{name};
+ $self->error ("cannot update history for $id: $@");
+ return;
+ }
+ return 1;
+}
+
+# Record a setting change for this object. Takes the field, the old value,
+# the new value, and the trace information (user, host, and time). The field
+# may have the special value "type_data <field>" in which case the value after
+# the whitespace is used as the type_field value.
+#
+# This function does not commit and does not catch exceptions. It should
+# normally be called as part of a larger transaction that implements the
+# setting change and should be committed with that change.
+sub log_set {
+ my ($self, $field, $old, $new, $user, $host, $time) = @_;
+ my $type_field;
+ if ($field =~ /^type_data\s+/) {
+ ($field, $type_field) = split (' ', $field, 2);
+ }
+ my %fields = map { $_ => 1 }
+ qw(owner acl_get acl_store acl_show acl_destroy acl_flags expires
+ comment flags type_data);
+ unless ($fields{$field}) {
+ die "invalid history field $field";
+ }
+
+ my %record = (oh_type => $self->{type},
+ oh_name => $self->{name},
+ oh_action => 'set',
+ oh_field => $field,
+ oh_type_field => $type_field,
+ oh_old => $old,
+ oh_new => $new,
+ oh_by => $user,
+ oh_from => $host,
+ oh_on => strftime ('%Y-%m-%d %T', localtime $time));
+ $self->{schema}->resultset('ObjectHistory')->create (\%record);
+}
+
+##############################################################################
+# Get/set values
+##############################################################################
+
+# Set a particular attribute. Takes the attribute to set and its new value.
+# Returns undef on failure and true on success.
+sub _set_internal {
+ my ($self, $attr, $value, $user, $host, $time) = @_;
+ if ($attr !~ /^[a-z_]+\z/) {
+ $self->error ("invalid attribute $attr");
+ return;
+ }
+ $time ||= time;
+ my $name = $self->{name};
+ my $type = $self->{type};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot modify ${type}:${name}: object is locked");
+ return;
+ }
+
+ my $guard = $self->{schema}->txn_scope_guard;
+ eval {
+ my %search = (ob_type => $type,
+ ob_name => $name);
+ my $object = $self->{schema}->resultset('Object')->find (\%search);
+ my $old = $object->get_column ("ob_$attr");
+
+ $object->update ({ "ob_$attr" => $value });
+ $self->log_set ($attr, $old, $value, $user, $host, $time);
+ $guard->commit;
+ };
+ if ($@) {
+ my $id = $self->{type} . ':' . $self->{name};
+ $self->error ("cannot set $attr on $id: $@");
+ return;
+ }
+ return 1;
+}
+
+# Get a particular attribute. Returns the attribute value or undef if the
+# value isn't set or on a database error. The two cases can be distinguished
+# by whether $self->{error} is set.
+sub _get_internal {
+ my ($self, $attr) = @_;
+ undef $self->{error};
+ if ($attr !~ /^[a-z_]+\z/) {
+ $self->error ("invalid attribute $attr");
+ return;
+ }
+ $attr = 'ob_' . $attr;
+ my $name = $self->{name};
+ my $type = $self->{type};
+ my $value;
+ eval {
+ my %search = (ob_type => $type,
+ ob_name => $name);
+ my $object = $self->{schema}->resultset('Object')->find (\%search);
+ $value = $object->get_column ($attr);
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ return $value;
+}
+
+# Get or set an ACL on an object. Takes the type of ACL and, if setting, the
+# new ACL identifier. If setting it, trace information must also be provided.
+sub acl {
+ my ($self, $type, $id, $user, $host, $time) = @_;
+ if ($type !~ /^(get|store|show|destroy|flags)\z/) {
+ $self->error ("invalid ACL type $type");
+ return;
+ }
+ my $attr = "acl_$type";
+ if ($id) {
+ my $acl;
+ eval { $acl = Wallet::ACL->new ($id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ return $self->_set_internal ($attr, $acl->id, $user, $host, $time);
+ } elsif (defined $id) {
+ return $self->_set_internal ($attr, undef, $user, $host, $time);
+ } else {
+ return $self->_get_internal ($attr);
+ }
+}
+
+# Get or set an attribute on an object. Takes the name of the attribute and,
+# if setting, the values and trace information. The values must be provided
+# as a reference to an array, even if there is only one value.
+#
+# Attributes are used by backends for backend-specific information (such as
+# enctypes for a keytab). The default implementation rejects all attribute
+# names as unknown.
+sub attr {
+ my ($self, $attr, $values, $user, $host, $time) = @_;
+ $self->error ("unknown attribute $attr");
+ return;
+}
+
+# Format the object attributes for inclusion in show(). The default
+# implementation just returns the empty string.
+sub attr_show {
+ my ($self) = @_;
+ return '';
+}
+
+# Get or set the comment value of an object. If setting it, trace information
+# must also be provided.
+sub comment {
+ my ($self, $comment, $user, $host, $time) = @_;
+ if ($comment) {
+ return $self->_set_internal ('comment', $comment, $user, $host, $time);
+ } elsif (defined $comment) {
+ return $self->_set_internal ('comment', undef, $user, $host, $time);
+ } else {
+ return $self->_get_internal ('comment');
+ }
+}
+
+# Get or set the expires value of an object. Expects an expiration time in
+# seconds since epoch. If setting the expiration, trace information must also
+# be provided.
+sub expires {
+ my ($self, $expires, $user, $host, $time) = @_;
+ if ($expires) {
+ if ($expires !~ /^\d{4}-\d\d-\d\d( \d\d:\d\d:\d\d)?\z/) {
+ $self->error ("malformed expiration time $expires");
+ return;
+ }
+ return $self->_set_internal ('expires', $expires, $user, $host, $time);
+ } elsif (defined $expires) {
+ return $self->_set_internal ('expires', undef, $user, $host, $time);
+ } else {
+ return $self->_get_internal ('expires');
+ }
+}
+
+# Get or set the owner of an object. If setting it, trace information must
+# also be provided.
+sub owner {
+ my ($self, $owner, $user, $host, $time) = @_;
+ if ($owner) {
+ my $acl;
+ eval { $acl = Wallet::ACL->new ($owner, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ return $self->_set_internal ('owner', $acl->id, $user, $host, $time);
+ } elsif (defined $owner) {
+ return $self->_set_internal ('owner', undef, $user, $host, $time);
+ } else {
+ return $self->_get_internal ('owner');
+ }
+}
+
+##############################################################################
+# Flags
+##############################################################################
+
+# Check whether a flag is set on the object. Returns true if set, 0 if not
+# set, and undef on error.
+sub flag_check {
+ my ($self, $flag) = @_;
+ my $name = $self->{name};
+ my $type = $self->{type};
+ my $schema = $self->{schema};
+ my $value;
+ eval {
+ my %search = (fl_type => $type,
+ fl_name => $name,
+ fl_flag => $flag);
+ my $flag = $schema->resultset('Flag')->find (\%search);
+ if (not defined $flag) {
+ $value = 0;
+ } else {
+ $value = $flag->fl_flag;
+ }
+ };
+ if ($@) {
+ $self->error ("cannot check flag $flag for ${type}:${name}: $@");
+ return;
+ } else {
+ return ($value) ? 1 : 0;
+ }
+}
+
+# Clear a flag on an object. Takes the flag and trace information. Returns
+# true on success and undef on failure.
+sub flag_clear {
+ my ($self, $flag, $user, $host, $time) = @_;
+ $time ||= time;
+ my $name = $self->{name};
+ my $type = $self->{type};
+ my $schema = $self->{schema};
+ my $guard = $schema->txn_scope_guard;
+ eval {
+ my %search = (fl_type => $type,
+ fl_name => $name,
+ fl_flag => $flag);
+ my $flag = $schema->resultset('Flag')->find (\%search);
+ unless (defined $flag) {
+ die "flag not set\n";
+ }
+ $flag->delete;
+ $self->log_set ('flags', $flag->fl_flag, undef, $user, $host, $time);
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ("cannot clear flag $flag on ${type}:${name}: $@");
+ return;
+ }
+ return 1;
+}
+
+# List the flags on an object. Returns a list of flag names, which may be
+# empty. On error, returns the empty list. The caller should call error() in
+# this case to determine if an error occurred.
+sub flag_list {
+ my ($self) = @_;
+ undef $self->{error};
+ my @flags;
+ eval {
+ my %search = (fl_type => $self->{type},
+ fl_name => $self->{name});
+ my %attrs = (order_by => 'fl_flag');
+ my @flags_rs = $self->{schema}->resultset('Flag')->search (\%search,
+ \%attrs);
+ for my $flag (@flags_rs) {
+ push (@flags, $flag->fl_flag);
+ }
+ };
+ if ($@) {
+ my $id = $self->{type} . ':' . $self->{name};
+ $self->error ("cannot retrieve flags for $id: $@");
+ return;
+ } else {
+ return @flags;
+ }
+}
+
+# Set a flag on an object. Takes the flag and trace information. Returns
+# true on success and undef on failure.
+sub flag_set {
+ my ($self, $flag, $user, $host, $time) = @_;
+ $time ||= time;
+ my $name = $self->{name};
+ my $type = $self->{type};
+ my $schema = $self->{schema};
+ my $guard = $schema->txn_scope_guard;
+ eval {
+ my %search = (fl_type => $type,
+ fl_name => $name,
+ fl_flag => $flag);
+ my $flag = $schema->resultset('Flag')->find (\%search);
+ if (defined $flag) {
+ die "flag already set\n";
+ }
+ $flag = $schema->resultset('Flag')->create (\%search);
+ $self->log_set ('flags', undef, $flag->fl_flag, $user, $host, $time);
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ("cannot set flag $flag on ${type}:${name}: $@");
+ return;
+ }
+ return 1;
+}
+
+##############################################################################
+# History
+##############################################################################
+
+# Expand a given ACL id to add its name, for readability. Returns the
+# original id alone if there was a problem finding the name.
+sub format_acl_id {
+ my ($self, $id) = @_;
+ my $name = $id;
+
+ my %search = (ac_id => $id);
+ my $acl_rs = $self->{schema}->resultset('Acl')->find (\%search);
+ if (defined $acl_rs) {
+ $name = $acl_rs->ac_name . " ($id)";
+ }
+
+ return $name;
+}
+
+# Return the formatted history for a given object or undef on error.
+# Currently always returns the complete history, but eventually will need to
+# provide some way of showing only recent entries.
+sub history {
+ my ($self) = @_;
+ my $output = '';
+ eval {
+ my %search = (oh_type => $self->{type},
+ oh_name => $self->{name});
+ my %attrs = (order_by => 'oh_on');
+ my @history = $self->{schema}->resultset('ObjectHistory')
+ ->search (\%search, \%attrs);
+
+ for my $history_rs (@history) {
+ $output .= sprintf ("%s %s ", $history_rs->oh_on->ymd,
+ $history_rs->oh_on->hms);
+
+ my $old = $history_rs->oh_old;
+ my $new = $history_rs->oh_new;
+ my $action = $history_rs->oh_action;
+ my $field = $history_rs->oh_field;
+
+ if ($action eq 'set' and $field eq 'flags') {
+ if (defined ($new)) {
+ $output .= "set flag $new";
+ } elsif (defined ($old)) {
+ $output .= "clear flag $old";
+ }
+ } elsif ($action eq 'set' and $field eq 'type_data') {
+ my $attr = $history_rs->oh_type_field;
+ if (defined ($old) and defined ($new)) {
+ $output .= "set attribute $attr to $new (was $old)";
+ } elsif (defined ($old)) {
+ $output .= "remove $old from attribute $attr";
+ } elsif (defined ($new)) {
+ $output .= "add $new to attribute $attr";
+ }
+ } elsif ($action eq 'set'
+ and ($field eq 'owner' or $field =~ /^acl_/)) {
+ $old = $self->format_acl_id ($old) if defined ($old);
+ $new = $self->format_acl_id ($new) if defined ($new);
+ if (defined ($old) and defined ($new)) {
+ $output .= "set $field to $new (was $old)";
+ } elsif (defined ($new)) {
+ $output .= "set $field to $new";
+ } elsif (defined ($old)) {
+ $output .= "unset $field (was $old)";
+ }
+ } elsif ($action eq 'set') {
+ if (defined ($old) and defined ($new)) {
+ $output .= "set $field to $new (was $old)";
+ } elsif (defined ($new)) {
+ $output .= "set $field to $new";
+ } elsif (defined ($old)) {
+ $output .= "unset $field (was $old)";
+ }
+ } else {
+ $output .= $action;
+ }
+ $output .= sprintf ("\n by %s from %s\n", $history_rs->oh_by,
+ $history_rs->oh_from);
+ }
+ };
+ if ($@) {
+ my $id = $self->{type} . ':' . $self->{name};
+ $self->error ("cannot read history for $id: $@");
+ return;
+ }
+ return $output;
+}
+
+##############################################################################
+# Object manipulation
+##############################################################################
+
+# The get methods must always be overridden by the subclass.
+sub get { die "Do not instantiate Wallet::Object::Base directly\n"; }
+
+# Provide a default store implementation that returns an immutable object
+# error so that auto-generated types don't have to provide their own.
+sub store {
+ my ($self, $data, $user, $host, $time) = @_;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot store $id: object is locked");
+ return;
+ }
+ $self->error ("cannot store $id: object type is immutable");
+ return;
+}
+
+# The default show function. This may be adequate for many types; types that
+# have additional data should call this method, grab the results, and then add
+# their data on to the end.
+sub show {
+ my ($self) = @_;
+ my $name = $self->{name};
+ my $type = $self->{type};
+ my @attrs = ([ ob_type => 'Type' ],
+ [ ob_name => 'Name' ],
+ [ ob_owner => 'Owner' ],
+ [ ob_acl_get => 'Get ACL' ],
+ [ ob_acl_store => 'Store ACL' ],
+ [ ob_acl_show => 'Show ACL' ],
+ [ ob_acl_destroy => 'Destroy ACL' ],
+ [ ob_acl_flags => 'Flags ACL' ],
+ [ ob_expires => 'Expires' ],
+ [ ob_comment => 'Comment' ],
+ [ ob_created_by => 'Created by' ],
+ [ ob_created_from => 'Created from' ],
+ [ ob_created_on => 'Created on' ],
+ [ ob_stored_by => 'Stored by' ],
+ [ ob_stored_from => 'Stored from' ],
+ [ ob_stored_on => 'Stored on' ],
+ [ ob_downloaded_by => 'Downloaded by' ],
+ [ ob_downloaded_from => 'Downloaded from' ],
+ [ ob_downloaded_on => 'Downloaded on' ]);
+ my $fields = join (', ', map { $_->[0] } @attrs);
+ my @data;
+ my $object_rs;
+ eval {
+ my %search = (ob_type => $type,
+ ob_name => $name);
+ $object_rs = $self->{schema}->resultset('Object')->find (\%search);
+ };
+ if ($@) {
+ $self->error ("cannot retrieve data for ${type}:${name}: $@");
+ return;
+ }
+ my $output = '';
+ my @acls;
+
+ # Format the results. We use a hack to insert the flags before the first
+ # trace field since they're not a field in the object in their own right.
+ # The comment should be word-wrapped at 80 columns.
+ for my $i (0 .. $#attrs) {
+ my $field = $attrs[$i][0];
+ my $fieldtext = $attrs[$i][1];
+ next unless my $value = $object_rs->get_column ($field);
+
+ if ($field eq 'ob_comment' && length ($value) > 79 - 17) {
+ local $Text::Wrap::columns = 80;
+ local $Text::Wrap::unexpand = 0;
+ $value = wrap (' ' x 17, ' ' x 17, $value);
+ $value =~ s/^ {17}//;
+ }
+ if ($field eq 'ob_created_by') {
+ my @flags = $self->flag_list;
+ if (not @flags and $self->error) {
+ return;
+ }
+ if (@flags) {
+ $output .= sprintf ("%15s: %s\n", 'Flags', "@flags");
+ }
+ my $attr_output = $self->attr_show;
+ if (not defined $attr_output) {
+ return;
+ }
+ $output .= $attr_output;
+ }
+ if ($field =~ /^ob_(owner|acl_)/) {
+ my $acl = eval { Wallet::ACL->new ($value, $self->{schema}) };
+ if ($acl and not $@) {
+ $value = $acl->name || $value;
+ push (@acls, [ $acl, $value ]);
+ }
+ }
+ $output .= sprintf ("%15s: %s\n", $fieldtext, $value);
+ }
+ if (@acls) {
+ my %seen;
+ @acls = grep { !$seen{$_->[1]}++ } @acls;
+ for my $acl (@acls) {
+ $output .= "\n" . $acl->[0]->show;
+ }
+ }
+ return $output;
+}
+
+# The default destroy function only destroys the database metadata. Generally
+# subclasses need to override this to destroy whatever additional information
+# is stored about this object.
+sub destroy {
+ my ($self, $user, $host, $time) = @_;
+ $time ||= time;
+ my $name = $self->{name};
+ my $type = $self->{type};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot destroy ${type}:${name}: object is locked");
+ return;
+ }
+ my $guard = $self->{schema}->txn_scope_guard;
+ eval {
+
+ # Remove any flags that may exist for the record.
+ my %search = (fl_type => $type,
+ fl_name => $name);
+ $self->{schema}->resultset('Flag')->search (\%search)->delete;
+
+ # Remove any object records
+ %search = (ob_type => $type,
+ ob_name => $name);
+ $self->{schema}->resultset('Object')->search (\%search)->delete;
+
+ # And create a new history object for the destroy action.
+ my %record = (oh_type => $type,
+ oh_name => $name,
+ oh_action => 'destroy',
+ oh_by => $user,
+ oh_from => $host,
+ oh_on => strftime ('%Y-%m-%d %T', localtime $time));
+ $self->{schema}->resultset('ObjectHistory')->create (\%record);
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ("cannot destroy ${type}:${name}: $@");
+ return;
+ }
+ return 1;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=head1 NAME
+
+Wallet::Object::Base - Generic parent class for wallet objects
+
+=for stopwords
+DBH HOSTNAME DATETIME ACL backend metadata timestamp Allbery wallet-backend
+backend-specific subclasses
+
+=head1 SYNOPSIS
+
+ package Wallet::Object::Simple;
+ @ISA = qw(Wallet::Object::Base);
+ sub get {
+ my ($self, $user, $host, $time) = @_;
+ $self->log_action ('get', $user, $host, $time) or return;
+ return "Some secure data";
+ }
+
+=head1 DESCRIPTION
+
+Wallet::Object::Base is the generic parent class for wallet objects (data
+types that can be stored in the wallet system). It provides default
+functions and behavior, including handling generic object settings. All
+handlers for objects stored in the wallet should inherit from it. It is
+not used directly.
+
+=head1 PUBLIC CLASS METHODS
+
+The following methods are called by the rest of the wallet system and
+should be implemented by all objects stored in the wallet. They should be
+called with the desired wallet object class as the first argument
+(generally using the Wallet::Object::Type->new syntax).
+
+=over 4
+
+=item new(TYPE, NAME, DBH)
+
+Creates a new object with the given object type and name, based on data
+already in the database. This method will only succeed if an object of
+the given TYPE and NAME is already present in the wallet database. If no
+such object exits, throws an exception. Otherwise, returns an object
+blessed into the class used for the new() call (so subclasses can leave
+this method alone and not override it).
+
+Takes a Wallet::Schema object, which is stored in the object and used
+for any further operations.
+
+=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
+
+Similar to new() but instead creates a new entry in the database. This
+method will throw an exception if an entry for that type and name already
+exists in the database or if creating the database record fails.
+Otherwise, a new database entry will be created with that type and name,
+no owner, no ACLs, no expiration, no flags, and with created by, from, and
+on set to the PRINCIPAL, HOSTNAME, and DATETIME parameters. If DATETIME
+isn't given, the current time is used. The database handle is treated as
+with new().
+
+=back
+
+=head1 PUBLIC INSTANCE METHODS
+
+The following methods may be called on instantiated wallet objects.
+Normally, the only methods that a subclass will need to override are
+get(), store(), show(), and destroy().
+
+If the locked flag is set on an object, no actions may be performed on
+that object except for the flag methods and show(). All other actions
+will be rejected with an error saying the object is locked.
+
+=over 4
+
+=item acl(TYPE [, ACL, PRINCIPAL, HOSTNAME [, DATETIME]])
+
+Sets or retrieves a given object ACL as a numeric ACL ID. TYPE must be
+one of C<get>, C<store>, C<show>, C<destroy>, or C<flags>, corresponding
+to the ACLs kept on an object. If no other arguments are given, returns
+the current ACL setting as an ACL ID or undef if that ACL isn't set. If
+other arguments are given, change that ACL to ACL and return true on
+success and false on failure. Pass in the empty string for ACL to clear
+the ACL. The other arguments are used for logging and history and should
+indicate the user and host from which the change is made and the time of
+the change.
+
+=item attr(ATTRIBUTE [, VALUES, PRINCIPAL, HOSTNAME [, DATETIME]])
+
+Sets or retrieves a given object attribute. Attributes are used to store
+backend-specific information for a particular object type and ATTRIBUTE
+must be an attribute type known to the underlying object implementation.
+The default implementation of this method rejects all attributes as
+unknown.
+
+If no other arguments besides ATTRIBUTE are given, returns the values of
+that attribute, if any, as a list. On error, returns the empty list. To
+distinguish between an error and an empty return, call error() afterward.
+It is guaranteed to return undef unless there was an error.
+
+If other arguments are given, sets the given ATTRIBUTE values to VALUES,
+which must be a reference to an array (even if only one value is being
+set). Pass a reference to an empty array to clear the attribute values.
+The other arguments are used for logging and history and should indicate
+the user and host from which the change is made and the time of the
+change. Returns true on success and false on failure.
+
+=item attr_show()
+
+Returns a formatted text description of the type-specific attributes of
+the object, or undef on error. The default implementation of this method
+always returns the empty string. If there are any type-specific
+attributes set, this method should return that metadata, formatted as key:
+value pairs with the keys right-aligned in the first 15 characters,
+followed by a space, a colon, and the value.
+
+=item comment([COMMENT, PRINCIPAL, HOSTNAME [, DATETIME]])
+
+Sets or retrieves the comment associated with an object. If no arguments
+are given, returns the current comment or undef if no comment is set. If
+arguments are given, change the comment to COMMENT and return true on
+success and false on failure. Pass in the empty string for COMMENT to
+clear the comment.
+
+The other arguments are used for logging and history and should indicate
+the user and host from which the change is made and the time of the
+change.
+
+=item destroy(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Destroys the object by removing all record of it from the database. The
+Wallet::Object::Base implementation handles the generic database work, but
+any subclass should override this method to do any deletion of files or
+entries in external databases and any other database entries and then call
+the parent method to handle the generic database cleanup. Returns true on
+success and false on failure. The arguments are used for logging and
+history and should indicate the user and host from which the change is
+made and the time of the change.
+
+=item error([ERROR ...])
+
+Returns the error of the last failing operation or undef if no operations
+have failed. Callers should call this function to get the error message
+after an undef return from any other instance method.
+
+For the convenience of child classes, this method can also be called with
+one or more error strings. If so, those strings are concatenated
+together, trailing newlines are removed, any text of the form S<C< at \S+
+line \d+\.?>> at the end of the message is stripped off, and the result is
+stored as the error. Only child classes should call this method with an
+error string.
+
+=item expires([EXPIRES, PRINCIPAL, HOSTNAME [, DATETIME]])
+
+Sets or retrieves the expiration date of an object. If no arguments are
+given, returns the current expiration or undef if no expiration is set.
+If arguments are given, change the expiration to EXPIRES and return true
+on success and false on failure. EXPIRES must be in the format
+C<YYYY-MM-DD HH:MM:SS>, although the time portion may be omitted. Pass in
+the empty string for EXPIRES to clear the expiration date.
+
+The other arguments are used for logging and history and should indicate
+the user and host from which the change is made and the time of the
+change.
+
+=item flag_check(FLAG)
+
+Check whether the given flag is set on an object. Returns true if set,
+C<0> if not set, and undef on error.
+
+=item flag_clear(FLAG, PRINCIPAL, HOSTNAME [, DATETIME])
+
+Clears FLAG on an object. Returns true on success and false on failure.
+The other arguments are used for logging and history and should indicate
+the user and host from which the change is made and the time of the
+change.
+
+=item flag_list()
+
+List the flags set on an object. If no flags are set, returns the empty
+list. On failure, returns an empty list. To distinguish between the
+empty response and an error, the caller should call error() after an empty
+return. It is guaranteed to return undef if there was no error.
+
+=item flag_set(FLAG, PRINCIPAL, HOSTNAME [, DATETIME])
+
+Sets FLAG on an object. Returns true on success and false on failure.
+The other arguments are used for logging and history and should indicate
+the user and host from which the change is made and the time of the
+change.
+
+=item get(PRINCIPAL, HOSTNAME [, DATETIME])
+
+An object implementation must override this method with one that returns
+either the data of the object or undef on some error, using the provided
+arguments to update history information. The Wallet::Object::Base
+implementation just throws an exception.
+
+=item history()
+
+Returns the formatted history for the object. There will be two lines for
+each action on the object. The first line has the timestamp of the action
+and the action, and the second line gives the user who performed the
+action and the host from which they performed it (based on the trace
+information passed into the other object methods).
+
+=item name()
+
+Returns the object's name.
+
+=item owner([OWNER, PRINCIPAL, HOSTNAME [, DATETIME]])
+
+Sets or retrieves the owner of an object as a numeric ACL ID. If no
+arguments are given, returns the current owner ACL ID or undef if none is
+set. If arguments are given, change the owner to OWNER and return true on
+success and false on failure. Pass in the empty string for OWNER to clear
+the owner. The other arguments are used for logging and history and
+should indicate the user and host from which the change is made and the
+time of the change.
+
+=item show()
+
+Returns a formatted text description of the object suitable for human
+display, or undef on error. All of the base metadata about the object,
+formatted as key: value pairs with the keys aligned in the first 15
+characters followed by a space, a colon, and the value. The attr_show()
+method of the object is also called and any formatted output it returns
+will be included. If any ACLs or an owner are set, after this data there
+is a blank line and then the information for each unique ACL, separated by
+blank lines.
+
+=item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME])
+
+Store user-supplied data into the given object. This may not be supported
+by all backends (for instance, backends that automatically generate the
+data will not support this). The default implementation rejects all
+store() calls with an error message saying that the object is immutable.
+
+=item type()
+
+Returns the object's type.
+
+=back
+
+=head1 UTILITY METHODS
+
+The following instance methods should not be called externally but are
+provided for subclasses to call to implement some generic actions.
+
+=over 4
+
+=item log_action (ACTION, PRINCIPAL, HOSTNAME, DATETIME)
+
+Updates the history tables and trace information appropriately for ACTION,
+which should be either C<get> or C<store>. No other changes are made to
+the database, just updates of the history table and trace fields with the
+provided data about who performed the action and when.
+
+This function commits its transaction when complete and therefore should
+not be called inside another transaction. Normally it's called as a
+separate transaction after the data is successfully stored or retrieved.
+
+=item log_set (FIELD, OLD, NEW, PRINCIPAL, HOSTNAME, DATETIME)
+
+Updates the history tables for the change in a setting value for an
+object. FIELD should be one of C<owner>, C<acl_get>, C<acl_store>,
+C<acl_show>, C<acl_destroy>, C<acl_flags>, C<expires>, C<flags>, or a
+value starting with C<type_data> followed by a space and a type-specific
+field name. The last form is the most common form used by a subclass.
+OLD is the previous value of the field or undef if the field was unset,
+and NEW is the new value of the field or undef if the field should be
+unset.
+
+This function does not commit and does not catch database exceptions. It
+should normally be called as part of a larger transaction that implements
+the change in the setting.
+
+=back
+
+=head1 SEE ALSO
+
+wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Object/Duo.pm b/perl/lib/Wallet/Object/Duo.pm
new file mode 100644
index 0000000..e5773c8
--- /dev/null
+++ b/perl/lib/Wallet/Object/Duo.pm
@@ -0,0 +1,331 @@
+# Wallet::Object::Duo -- Duo integration object implementation for the wallet.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2014
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Object::Duo;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use JSON;
+use Net::Duo::Admin;
+use Net::Duo::Admin::Integration;
+use Perl6::Slurp qw(slurp);
+use Wallet::Config ();
+use Wallet::Object::Base;
+
+@ISA = qw(Wallet::Object::Base);
+
+# 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';
+
+##############################################################################
+# Core methods
+##############################################################################
+
+# Override attr_show to display the Duo integration key attribute.
+sub attr_show {
+ my ($self) = @_;
+ my $output = '';
+ my $key;
+ eval {
+ my %search = (du_name => $self->{name});
+ my $row = $self->{schema}->resultset ('Duo')->find (\%search);
+ $key = $row->get_column ('du_key');
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ return sprintf ("%15s: %s\n", 'Duo key', $key);
+}
+
+# Override new to start by creating a Net::Duo::Admin object for subsequent
+# calls.
+sub new {
+ my ($class, $type, $name, $schema) = @_;
+
+ # We have to have a Duo integration key file set.
+ if (not $Wallet::Config::DUO_KEY_FILE) {
+ die "duo object implementation not configured\n";
+ }
+ my $key_file = $Wallet::Config::DUO_KEY_FILE;
+ my $agent = $Wallet::Config::DUO_AGENT;
+
+ # Construct the Net::Duo::Admin object.
+ require Net::Duo::Admin;
+ my $duo = Net::Duo::Admin->new (
+ {
+ key_file => $key_file,
+ user_agent => $agent,
+ }
+ );
+
+ # Construct the object.
+ my $self = $class->SUPER::new ($type, $name, $schema);
+ $self->{duo} = $duo;
+ return $self;
+}
+
+# Override create to start by creating a new integration in Duo, and only
+# create the entry in the database if that succeeds. Error handling isn't
+# great here since we don't have a way to communicate the error back to the
+# caller.
+sub create {
+ my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
+
+ # We have to have a Duo integration key file set.
+ if (not $Wallet::Config::DUO_KEY_FILE) {
+ die "duo object implementation not configured\n";
+ }
+ my $key_file = $Wallet::Config::DUO_KEY_FILE;
+ my $agent = $Wallet::Config::DUO_AGENT;
+
+ # Construct the Net::Duo::Admin object.
+ require Net::Duo::Admin;
+ my $duo = Net::Duo::Admin->new (
+ {
+ key_file => $key_file,
+ user_agent => $agent,
+ }
+ );
+
+ # Create the object in Duo.
+ require Net::Duo::Admin::Integration;
+ my %data = (
+ name => $name,
+ notes => 'Managed by wallet',
+ type => $Wallet::Config::DUO_TYPE,
+ );
+ my $integration = Net::Duo::Admin::Integration->create ($duo, \%data);
+
+ # Create the object in wallet.
+ my @trace = ($creator, $host, $time);
+ my $self = $class->SUPER::create ($type, $name, $schema, @trace);
+ $self->{duo} = $duo;
+
+ # Add the integration key to the object metadata.
+ my $guard = $self->{schema}->txn_scope_guard;
+ eval {
+ my %record = (
+ du_name => $name,
+ du_key => $integration->integration_key,
+ );
+ $self->{schema}->resultset ('Duo')->create (\%record);
+ $guard->commit;
+ };
+ if ($@) {
+ my $id = $self->{type} . ':' . $self->{name};
+ $self->error ("cannot set Duo key for $id: $@");
+ return;
+ }
+
+ # Done. Return the object.
+ return $self;
+}
+
+# Override destroy to delete the integration out of Duo as well.
+sub destroy {
+ my ($self, $user, $host, $time) = @_;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot destroy $id: object is locked");
+ return;
+ }
+ my $schema = $self->{schema};
+ my $guard = $schema->txn_scope_guard;
+ eval {
+ my %search = (du_name => $self->{name});
+ my $row = $schema->resultset ('Duo')->find (\%search);
+ my $key = $row->get_column ('du_key');
+ my $int = Net::Duo::Admin::Integration->new ($self->{duo}, $key);
+ $int->delete;
+ $row->delete;
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ return $self->SUPER::destroy ($user, $host, $time);
+}
+
+# Our get implementation. Retrieve the integration information from Duo and
+# construct the configuration file expected by the Duo PAM module.
+sub get {
+ my ($self, $user, $host, $time) = @_;
+ $time ||= time;
+
+ # Check that the object isn't locked.
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot get $id: object is locked");
+ return;
+ }
+
+ # Retrieve the integration from Duo.
+ my $key;
+ eval {
+ my %search = (du_name => $self->{name});
+ my $row = $self->{schema}->resultset ('Duo')->find (\%search);
+ $key = $row->get_column ('du_key');
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ my $integration = Net::Duo::Admin::Integration->new ($self->{duo}, $key);
+
+ # We also need the admin server name, which we can get from the Duo object
+ # configuration with a bit of JSON decoding.
+ my $json = JSON->new->utf8 (1);
+ my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
+
+ # Construct the returned file.
+ my $output = "[duo]\n";
+ $output .= "ikey = $key\n";
+ $output .= 'skey = ' . $integration->secret_key . "\n";
+ $output .= "host = $config->{api_hostname}\n";
+
+ # Log the action and return.
+ $self->log_action ('get', $user, $host, $time);
+ return $output;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+Allbery Duo integration DBH keytab
+
+=head1 NAME
+
+Wallet::Object::Duo - Duo integration object implementation for wallet
+
+=head1 SYNOPSIS
+
+ my @name = qw(duo host.example.com);
+ my @trace = ($user, $host, time);
+ my $object = Wallet::Object::Duo->create (@name, $schema, @trace);
+ my $config = $object->get (@trace);
+ $object->destroy (@trace);
+
+=head1 DESCRIPTION
+
+Wallet::Object::Duo is a representation of Duo integrations the wallet.
+It implements the wallet object API and provides the necessary glue to
+create a Duo integration, return a configuration file containing the key
+and API information for that integration, and delete the integration from
+Duo when the wallet object is destroyed.
+
+Currently, only one configured integration type can be managed by the
+wallet, and the integration information is always returned in the
+configuration file format expected by the Duo UNIX integration. The
+results of retrieving this object will be text, suitable for putting in
+the UNIX integration configuration file, containing the integration key,
+secret key, and admin hostname for that integration.
+
+This object can be retrieved repeatedly without changing the secret key,
+matching Duo's native behavior with integrations. To change the keys of
+the integration, delete it and recreate it.
+
+To use this object, at least one configuration parameter must be set. See
+L<Wallet::Config> for details on supported configuration parameters and
+information about how to set wallet configuration.
+
+=head1 METHODS
+
+This object mostly inherits from Wallet::Object::Base. See the
+documentation for that class for all generic methods. Below are only
+those methods that are overridden or behave specially for this
+implementation.
+
+=over 4
+
+=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
+
+This is a class method and should be called on the Wallet::Object::Duo
+class. It creates a new object with the given TYPE and NAME (TYPE is
+normally C<duo> and must be for the rest of the wallet system to use the
+right class, but this module doesn't check for ease of subclassing), using
+DBH as the handle to the wallet metadata database. PRINCIPAL, HOSTNAME,
+and DATETIME are stored as history information. PRINCIPAL should be the
+user who is creating the object. If DATETIME isn't given, the current
+time is used.
+
+When a new Duo integration object is created, a new integration will be
+created in the configured Duo account and the integration key will be
+stored in the wallet object. If the integration already exists, create()
+will fail. The new integration's type is controlled by the DUO_TYPE
+configuration variable, which defaults to C<unix>. See L<Wallet::Config>
+for more information.
+
+If create() fails, it throws an exception.
+
+=item destroy(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Destroys a Duo integration object by removing it from the database and
+deleting the integration from Duo. If deleting the Duo integration fails,
+destroy() fails. Returns true on success and false on failure. The
+caller should call error() to get the error message after a failure.
+PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
+PRINCIPAL should be the user who is destroying the object. If DATETIME
+isn't given, the current time is used.
+
+=item get(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Retrieves the configuration information for the Duo integration and
+returns that information in the format expected by the configuration file
+for the Duo UNIX integration. Returns undef on failure. The caller
+should call error() to get the error message if get() returns undef.
+
+The returned configuration look look like:
+
+ [duo]
+ ikey = <integration-key>
+ skey = <secret-key>
+ host = <api-hostname>
+
+The C<host> parameter will be taken from the configuration file pointed
+to by the DUO_KEY_FILE configuration variable.
+
+PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
+PRINCIPAL should be the user who is downloading the keytab. If DATETIME
+isn't given, the current time is used.
+
+=back
+
+=head1 LIMITATIONS
+
+Only one Duo account is supported for a given wallet implementation.
+Currently, only one Duo integration type is supported as well. Further
+development should expand the available integration types, possibly as
+additional wallet object types.
+
+=head1 SEE ALSO
+
+Net::Duo(3), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Object/File.pm b/perl/lib/Wallet/Object/File.pm
new file mode 100644
index 0000000..4afef04
--- /dev/null
+++ b/perl/lib/Wallet/Object/File.pm
@@ -0,0 +1,242 @@
+# Wallet::Object::File -- File object implementation for the wallet.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2008, 2010
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Object::File;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Digest::MD5 qw(md5_hex);
+use Wallet::Config ();
+use Wallet::Object::Base;
+
+@ISA = qw(Wallet::Object::Base);
+
+# 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.03';
+
+##############################################################################
+# File naming
+##############################################################################
+
+# Returns the path into which that file object will be stored or undef on
+# error. On error, sets the internal error.
+sub file_path {
+ my ($self) = @_;
+ my $name = $self->{name};
+ unless ($Wallet::Config::FILE_BUCKET) {
+ $self->error ('file support not configured');
+ return;
+ }
+ unless ($name) {
+ $self->error ('file objects may not have empty names');
+ return;
+ }
+ my $hash = substr (md5_hex ($name), 0, 2);
+ $name =~ s/([^\w-])/sprintf ('%%%02X', ord ($1))/ge;
+ my $parent = "$Wallet::Config::FILE_BUCKET/$hash";
+ unless (-d $parent || mkdir ($parent, 0700)) {
+ $self->error ("cannot create file bucket $hash: $!");
+ return;
+ }
+ return "$Wallet::Config::FILE_BUCKET/$hash/$name";
+}
+
+##############################################################################
+# Core methods
+##############################################################################
+
+# Override destroy to delete the file as well.
+sub destroy {
+ my ($self, $user, $host, $time) = @_;
+ my $id = $self->{type} . ':' . $self->{name};
+ my $path = $self->file_path;
+ if (defined ($path) && -f $path && !unlink ($path)) {
+ $self->error ("cannot delete $id: $!");
+ return;
+ }
+ return $self->SUPER::destroy ($user, $host, $time);
+}
+
+# Return the contents of the file.
+sub get {
+ my ($self, $user, $host, $time) = @_;
+ $time ||= time;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot get $id: object is locked");
+ return;
+ }
+ my $path = $self->file_path;
+ return unless $path;
+ unless (open (FILE, '<', $path)) {
+ $self->error ("cannot get $id: object has not been stored");
+ return;
+ }
+ local $/;
+ my $data = <FILE>;
+ unless (close FILE) {
+ $self->error ("cannot get $id: $!");
+ return;
+ }
+ $self->log_action ('get', $user, $host, $time);
+ return $data;
+}
+
+# Store the file on the wallet server.
+sub store {
+ my ($self, $data, $user, $host, $time) = @_;
+ $time ||= time;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot store $id: object is locked");
+ return;
+ }
+ if ($Wallet::Config::FILE_MAX_SIZE) {
+ my $max = $Wallet::Config::FILE_MAX_SIZE;
+ if (length ($data) > $max) {
+ $self->error ("data exceeds maximum of $max bytes");
+ return;
+ }
+ }
+ my $path = $self->file_path;
+ return unless $path;
+ unless (open (FILE, '>', $path)) {
+ $self->error ("cannot store $id: $!");
+ return;
+ }
+ unless (print FILE ($data) and close FILE) {
+ $self->error ("cannot store $id: $!");
+ close FILE;
+ return;
+ }
+ $self->log_action ('store', $user, $host, $time);
+ return 1;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=head1 NAME
+
+Wallet::Object::File - File object implementation for wallet
+
+=for stopwords
+API HOSTNAME DATETIME keytab remctld backend nul Allbery wallet-backend
+
+=head1 SYNOPSIS
+
+ my @name = qw(file mysql-lsdb)
+ my @trace = ($user, $host, time);
+ my $object = Wallet::Object::Keytab->create (@name, $schema, @trace);
+ unless ($object->store ("the-password\n")) {
+ die $object->error, "\n";
+ }
+ my $password = $object->get (@trace);
+ $object->destroy (@trace);
+
+=head1 DESCRIPTION
+
+Wallet::Object::File is a representation of simple file objects in the
+wallet. It implements the wallet object API and provides the necessary
+glue to store a file on the wallet server, retrieve it later, and delete
+it when the file object is deleted. A file object must be stored before
+it can be retrieved with get.
+
+To use this object, the configuration option specifying where on the
+wallet server to store file objects must be set. See L<Wallet::Config>
+for details on this configuration parameter and information about how to
+set wallet configuration.
+
+=head1 METHODS
+
+This object mostly inherits from Wallet::Object::Base. See the
+documentation for that class for all generic methods. Below are only
+those methods that are overridden or behave specially for this
+implementation.
+
+=over 4
+
+=item destroy(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Destroys a file object by removing it from the database and deleting the
+corresponding file on the wallet server. Returns true on success and
+false on failure. The caller should call error() to get the error message
+after a failure. PRINCIPAL, HOSTNAME, and DATETIME are stored as history
+information. PRINCIPAL should be the user who is destroying the object.
+If DATETIME isn't given, the current time is used.
+
+=item get(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Retrieves the current contents of the file object or undef on error.
+store() must be called before get() will be successful. The caller should
+call error() to get the error message if get() returns undef. PRINCIPAL,
+HOSTNAME, and DATETIME are stored as history information. PRINCIPAL
+should be the user who is downloading the keytab. If DATETIME isn't
+given, the current time is used.
+
+=item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME])
+
+Store DATA as the current contents of the file object. Any existing data
+will be overwritten. Returns true on success and false on failure. The
+caller should call error() to get the error message after a failure.
+PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
+PRINCIPAL should be the user who is destroying the object. If DATETIME
+isn't given, the current time is used.
+
+If FILE_MAX_SIZE is set in the wallet configuration, a store() of DATA
+larger than that configuration setting will be rejected.
+
+=back
+
+=head1 FILES
+
+=over 4
+
+=item FILE_BUCKET/<hash>/<file>
+
+Files are stored on the wallet server under the directory FILE_BUCKET as
+set in the wallet configuration. <hash> is the first two characters of
+the hex-encoded MD5 hash of the wallet file object name, used to not put
+too many files in the same directory. <file> is the name of the file
+object with all characters other than alphanumerics, underscores, and
+dashes replaced by C<%> and the hex code of the character.
+
+=back
+
+=head1 LIMITATIONS
+
+The wallet implementation itself can handle arbitrary file object names.
+However, due to limitations in the B<remctld> server usually used to run
+B<wallet-backend>, file object names containing nul characters (ASCII 0)
+may not be permitted. The file system used for storing file objects may
+impose a length limitation on the file object name.
+
+=head1 SEE ALSO
+
+remctld(8), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Object/Keytab.pm b/perl/lib/Wallet/Object/Keytab.pm
new file mode 100644
index 0000000..24c3302
--- /dev/null
+++ b/perl/lib/Wallet/Object/Keytab.pm
@@ -0,0 +1,513 @@
+# Wallet::Object::Keytab -- Keytab object implementation for the wallet.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2008, 2009, 2010, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Object::Keytab;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Wallet::Config ();
+use Wallet::Object::Base;
+use Wallet::Kadmin;
+
+@ISA = qw(Wallet::Object::Base);
+
+# 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.09';
+
+##############################################################################
+# Enctype restriction
+##############################################################################
+
+# Set the enctype restrictions for a keytab. Called by attr() and takes a
+# reference to the encryption types to set. Returns true on success and false
+# on failure, setting the object error if it fails.
+sub enctypes_set {
+ my ($self, $enctypes, $user, $host, $time) = @_;
+ $time ||= time;
+ my @trace = ($user, $host, $time);
+ my $name = $self->{name};
+ my %enctypes = map { $_ => 1 } @$enctypes;
+ my $guard = $self->{schema}->txn_scope_guard;
+ eval {
+ # Find all enctypes for the given keytab.
+ my %search = (ke_name => $name);
+ my @enctypes = $self->{schema}->resultset('KeytabEnctype')
+ ->search (\%search);
+ my (@current);
+ for my $enctype_rs (@enctypes) {
+ push (@current, $enctype_rs->ke_enctype);
+ }
+
+ # Use the existing enctypes and the enctypes we should have to match
+ # against ones that need to be removed, and note those that already
+ # exist.
+ for my $enctype (@current) {
+ if ($enctypes{$enctype}) {
+ delete $enctypes{$enctype};
+ } else {
+ %search = (ke_name => $name,
+ ke_enctype => $enctype);
+ $self->{schema}->resultset('KeytabEnctype')->find (\%search)
+ ->delete;
+ $self->log_set ('type_data enctypes', $enctype, undef, @trace);
+ }
+ }
+
+ # When inserting new enctypes, we unfortunately have to do the
+ # consistency check against the enctypes table ourselves, since SQLite
+ # doesn't enforce integrity constraints. We do this in sorted order
+ # to make it easier to test.
+ for my $enctype (sort keys %enctypes) {
+ my %search = (en_name => $enctype);
+ my $enctype_rs = $self->{schema}->resultset('Enctype')
+ ->find (\%search);
+ unless (defined $enctype_rs) {
+ die "unknown encryption type $enctype\n";
+ }
+ my %record = (ke_name => $name,
+ ke_enctype => $enctype);
+ $self->{schema}->resultset('KeytabEnctype')->create (\%record);
+ $self->log_set ('type_data enctypes', undef, $enctype, @trace);
+ }
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ return 1;
+}
+
+# Return a list of the encryption types current set for a keytab. Called by
+# attr() or get(). Returns the empty list on failure or on an empty list of
+# enctype restrictions, but sets the object error on failure so the caller
+# should use that to determine success.
+sub enctypes_list {
+ my ($self) = @_;
+ my @enctypes;
+ eval {
+ my %search = (ke_name => $self->{name});
+ my %attrs = (order_by => 'ke_enctype');
+ my @enctypes_rs = $self->{schema}->resultset('KeytabEnctype')
+ ->search (\%search, \%attrs);
+ for my $enctype_rs (@enctypes_rs) {
+ push (@enctypes, $enctype_rs->ke_enctype);
+ }
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ return @enctypes;
+}
+
+##############################################################################
+# Synchronization
+##############################################################################
+
+# Set a synchronization target or clear the targets if $targets is an
+# empty list. Returns true on success and false on failure.
+#
+# Currently, no synchronization targets are supported, but we preserve the
+# ability to clear synchronization and the basic structure of the code so
+# that they can be added later.
+sub sync_set {
+ my ($self, $targets, $user, $host, $time) = @_;
+ $time ||= time;
+ my @trace = ($user, $host, $time);
+ if (@$targets > 1) {
+ $self->error ('only one synchronization target supported');
+ return;
+ } elsif (@$targets) {
+ my $target = $targets->[0];
+ $self->error ("unsupported synchronization target $target");
+ return;
+ } else {
+ my $guard = $self->{schema}->txn_scope_guard;
+ eval {
+ my $name = $self->{name};
+ my %search = (ks_name => $name);
+ my $sync_rs = $self->{schema}->resultset('KeytabSync')
+ ->find (\%search);
+ if (defined $sync_rs) {
+ my $target = $sync_rs->ks_target;
+ $sync_rs->delete;
+ $self->log_set ('type_data sync', $target, undef, @trace);
+ }
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ }
+ return 1;
+}
+
+# Return a list of the current synchronization targets. Returns the empty
+# list on failure or on an empty list of enctype restrictions, but sets
+# the object error on failure so the caller should use that to determine
+# success.
+sub sync_list {
+ my ($self) = @_;
+ my @targets;
+ eval {
+ my %search = (ks_name => $self->{name});
+ my %attrs = (order_by => 'ks_target');
+ my @syncs = $self->{schema}->resultset('KeytabSync')->search (\%search,
+ \%attrs);
+ for my $sync_rs (@syncs) {
+ push (@targets, $sync_rs->ks_target);
+ }
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ return @targets;
+}
+
+##############################################################################
+# Core methods
+##############################################################################
+
+# Override attr to support setting the enctypes and sync attributes. Note
+# that the sync attribute has no supported targets at present and hence will
+# always return an error, but the code is still here so that it doesn't have
+# to be rewritten once a new sync target is added.
+sub attr {
+ my ($self, $attribute, $values, $user, $host, $time) = @_;
+ $time ||= time;
+ my @trace = ($user, $host, $time);
+ my %known = map { $_ => 1 } qw(enctypes sync);
+ undef $self->{error};
+ unless ($known{$attribute}) {
+ $self->error ("unknown attribute $attribute");
+ return;
+ }
+ if ($values) {
+ if ($attribute eq 'enctypes') {
+ return $self->enctypes_set ($values, $user, $host, $time);
+ } elsif ($attribute eq 'sync') {
+ return $self->sync_set ($values, $user, $host, $time);
+ }
+ } else {
+ if ($attribute eq 'enctypes') {
+ return $self->enctypes_list;
+ } elsif ($attribute eq 'sync') {
+ return $self->sync_list;
+ }
+ }
+}
+
+# Override attr_show to display the enctypes and sync attributes.
+sub attr_show {
+ my ($self) = @_;
+ my $output = '';
+ my @targets = $self->attr ('sync');
+ if (not @targets and $self->error) {
+ return;
+ } elsif (@targets) {
+ $output .= sprintf ("%15s: %s\n", 'Synced with', "@targets");
+ }
+ my @enctypes = $self->attr ('enctypes');
+ if (not @enctypes and $self->error) {
+ return;
+ } elsif (@enctypes) {
+ $output .= sprintf ("%15s: %s\n", 'Enctypes', $enctypes[0]);
+ shift @enctypes;
+ for my $enctype (@enctypes) {
+ $output .= (' ' x 17) . $enctype . "\n";
+ }
+ }
+ return $output;
+}
+
+# Override new to start by creating a handle for the kadmin module we're
+# using.
+sub new {
+ my ($class, $type, $name, $schema) = @_;
+ my $self = {
+ schema => $schema,
+ kadmin => undef,
+ };
+ bless $self, $class;
+ my $kadmin = Wallet::Kadmin->new ();
+ $self->{kadmin} = $kadmin;
+
+ $self = $class->SUPER::new ($type, $name, $schema);
+ $self->{kadmin} = $kadmin;
+ return $self;
+}
+
+# Override create to start by creating the principal in Kerberos and only
+# create the entry in the database if that succeeds. Error handling isn't
+# great here since we don't have a way to communicate the error back to the
+# caller.
+sub create {
+ my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
+ my $self = {
+ schema => $schema,
+ kadmin => undef,
+ };
+ bless $self, $class;
+ my $kadmin = Wallet::Kadmin->new ();
+ $self->{kadmin} = $kadmin;
+
+ if (not $kadmin->create ($name)) {
+ die $kadmin->error, "\n";
+ }
+ $self = $class->SUPER::create ($type, $name, $schema, $creator, $host,
+ $time);
+ $self->{kadmin} = $kadmin;
+ return $self;
+}
+
+# Override destroy to delete the principal out of Kerberos as well.
+sub destroy {
+ my ($self, $user, $host, $time) = @_;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot destroy $id: object is locked");
+ return;
+ }
+ my $schema = $self->{schema};
+ my $guard = $schema->txn_scope_guard;
+ eval {
+ my %search = (ks_name => $self->{name});
+ my $sync_rs = $schema->resultset('KeytabSync')->search (\%search);
+ $sync_rs->delete_all if defined $sync_rs;
+
+ %search = (ke_name => $self->{name});
+ my $enctype_rs = $schema->resultset('KeytabEnctype')->search (\%search);
+ $enctype_rs->delete_all if defined $enctype_rs;
+
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ my $kadmin = $self->{kadmin};
+ if (not $kadmin->destroy ($self->{name})) {
+ $self->error ($kadmin->error);
+ return;
+ }
+ return $self->SUPER::destroy ($user, $host, $time);
+}
+
+# Our get implementation. Generate a keytab into a temporary file and then
+# return that as the return value.
+sub get {
+ my ($self, $user, $host, $time) = @_;
+ $time ||= time;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot get $id: object is locked");
+ return;
+ }
+ my $kadmin = $self->{kadmin};
+ my $result;
+ if ($self->flag_check ('unchanging')) {
+ $result = $kadmin->keytab ($self->{name});
+ } else {
+ my @enctypes = $self->attr ('enctypes');
+ $result = $kadmin->keytab_rekey ($self->{name}, @enctypes);
+ }
+ if (defined $result) {
+ $self->log_action ('get', $user, $host, $time);
+ } else {
+ $self->error ($kadmin->error);
+ }
+ return $result;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+keytab API KDC keytabs HOSTNAME DATETIME enctypes enctype DBH metadata
+unmanaged kadmin Allbery unlinked
+
+=head1 NAME
+
+Wallet::Object::Keytab - Keytab object implementation for wallet
+
+=head1 SYNOPSIS
+
+ my @name = qw(keytab host/shell.example.com);
+ my @trace = ($user, $host, time);
+ my $object = Wallet::Object::Keytab->create (@name, $schema, @trace);
+ my $keytab = $object->get (@trace);
+ $object->destroy (@trace);
+
+=head1 DESCRIPTION
+
+Wallet::Object::Keytab is a representation of Kerberos keytab objects in
+the wallet. It implements the wallet object API and provides the
+necessary glue to create principals in a Kerberos KDC, create and return
+keytabs for those principals, and delete them out of Kerberos when the
+wallet object is destroyed.
+
+A keytab is an on-disk store for the key or keys for a Kerberos principal.
+Keytabs are used by services to verify incoming authentication from
+clients or by automated processes that need to authenticate to Kerberos.
+To create a keytab, the principal has to be created in Kerberos and then a
+keytab is generated and stored in a file on disk.
+
+This implementation generates a new random key (and hence invalidates all
+existing keytabs) each time the keytab is retrieved with the get() method.
+
+To use this object, several configuration parameters must be set. See
+L<Wallet::Config> for details on those configuration parameters and
+information about how to set wallet configuration.
+
+=head1 METHODS
+
+This object mostly inherits from Wallet::Object::Base. See the
+documentation for that class for all generic methods. Below are only
+those methods that are overridden or behave specially for this
+implementation.
+
+=over 4
+
+=item attr(ATTRIBUTE [, VALUES, PRINCIPAL, HOSTNAME [, DATETIME]])
+
+Sets or retrieves a given object attribute. The following attribute is
+supported:
+
+=over 4
+
+=item enctypes
+
+Restricts the generated keytab to a specific set of encryption types. The
+values of this attribute must be enctype strings recognized by Kerberos
+(strings like C<aes256-cts-hmac-sha1-96> or C<des-cbc-crc>). Encryption
+types must also be present in the list of supported enctypes stored in the
+database database or the attr() method will reject them. Note that the
+salt should not be included; since the salt is irrelevant for keytab keys,
+it will always be set to the default by the wallet.
+
+If this attribute is set, the principal will be restricted to that
+specific enctype list when get() is called for that keytab. If it is not
+set, the default set in the KDC will be used.
+
+This attribute is ignored if the C<unchanging> flag is set on a keytab.
+Keytabs retrieved with C<unchanging> set will contain all keys present in
+the KDC for that Kerberos principal and therefore may contain different
+enctypes than those requested by this attribute.
+
+=item sync
+
+This attribute is intended to set a list of external systems with which
+data about this keytab is synchronized, but there are no supported targets
+currently. However, there is support for clearing this attribute or
+returning its current value.
+
+=back
+
+If no other arguments besides ATTRIBUTE are given, returns the values of
+that attribute, if any, as a list. On error, returns the empty list. To
+distinguish between an error and an empty return, call error() afterward.
+It is guaranteed to return undef unless there was an error.
+
+If other arguments are given, sets the given ATTRIBUTE values to VALUES,
+which must be a reference to an array (even if only one value is being
+set). Pass a reference to an empty array to clear the attribute values.
+PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
+PRINCIPAL should be the user who is destroying the object. If DATETIME
+isn't given, the current time is used.
+
+=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
+
+This is a class method and should be called on the Wallet::Object::Keytab
+class. It creates a new object with the given TYPE and NAME (TYPE is
+normally C<keytab> and must be for the rest of the wallet system to use
+the right class, but this module doesn't check for ease of subclassing),
+using DBH as the handle to the wallet metadata database. PRINCIPAL,
+HOSTNAME, and DATETIME are stored as history information. PRINCIPAL
+should be the user who is creating the object. If DATETIME isn't given,
+the current time is used.
+
+When a new keytab object is created, the Kerberos principal designated by
+NAME is also created in the Kerberos realm determined from the wallet
+configuration. If the principal already exists, create() still succeeds
+(so that a previously unmanaged principal can be imported into the
+wallet). Otherwise, if the Kerberos principal could not be created,
+create() fails. The principal is created with the randomized keys. NAME
+must not contain the realm; instead, the KEYTAB_REALM configuration
+variable should be set. See L<Wallet::Config> for more information.
+
+If create() fails, it throws an exception.
+
+=item destroy(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Destroys a keytab object by removing it from the database and deleting the
+principal out of Kerberos. If deleting the principal fails, destroy()
+fails, but destroy() succeeds if the principal didn't exist when it was
+called (so that it can be used to clean up stranded entries). Returns
+true on success and false on failure. The caller should call error() to
+get the error message after a failure. PRINCIPAL, HOSTNAME, and DATETIME
+are stored as history information. PRINCIPAL should be the user who is
+destroying the object. If DATETIME isn't given, the current time is used.
+
+=item get(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Retrieves a keytab for this object and returns the keytab data or undef on
+error. The caller should call error() to get the error message if get()
+returns undef. The keytab is created with new randomized keys,
+invalidating any existing keytabs for that principal, unless the
+unchanging flag is set on the object. PRINCIPAL, HOSTNAME, and DATETIME
+are stored as history information. PRINCIPAL should be the user who is
+downloading the keytab. If DATETIME isn't given, the current time is
+used.
+
+=back
+
+=head1 FILES
+
+=over 4
+
+=item KEYTAB_TMP/keytab.<pid>
+
+The keytab is created in this file and then read into memory. KEYTAB_TMP
+is set in the wallet configuration, and <pid> is the process ID of the
+current process. The file is unlinked after being read.
+
+=back
+
+=head1 LIMITATIONS
+
+Only one Kerberos realm is supported for a given wallet implementation and
+all keytab objects stored must be in that realm. Keytab names in the
+wallet database do not have realm information.
+
+=head1 SEE ALSO
+
+kadmin(8), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Object/WAKeyring.pm b/perl/lib/Wallet/Object/WAKeyring.pm
new file mode 100644
index 0000000..f8bd0f7
--- /dev/null
+++ b/perl/lib/Wallet/Object/WAKeyring.pm
@@ -0,0 +1,370 @@
+# Wallet::Object::WAKeyring -- WebAuth keyring object implementation.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Object::WAKeyring;
+require 5.006;
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+use Digest::MD5 qw(md5_hex);
+use Fcntl qw(LOCK_EX);
+use Wallet::Config ();
+use Wallet::Object::Base;
+use WebAuth 3.06 qw(WA_KEY_AES WA_AES_128);
+
+@ISA = qw(Wallet::Object::Base);
+
+# 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';
+
+##############################################################################
+# File naming
+##############################################################################
+
+# Returns the path into which that keyring object will be stored or undef on
+# error. On error, sets the internal error.
+sub file_path {
+ my ($self) = @_;
+ my $name = $self->{name};
+ unless ($Wallet::Config::WAKEYRING_BUCKET) {
+ $self->error ('WebAuth keyring support not configured');
+ return;
+ }
+ unless ($name) {
+ $self->error ('WebAuth keyring objects may not have empty names');
+ return;
+ }
+ my $hash = substr (md5_hex ($name), 0, 2);
+ $name =~ s/([^\w-])/sprintf ('%%%02X', ord ($1))/ge;
+ my $parent = "$Wallet::Config::WAKEYRING_BUCKET/$hash";
+ unless (-d $parent || mkdir ($parent, 0700)) {
+ $self->error ("cannot create keyring bucket $hash: $!");
+ return;
+ }
+ return "$Wallet::Config::WAKEYRING_BUCKET/$hash/$name";
+}
+
+##############################################################################
+# Core methods
+##############################################################################
+
+# Override destroy to delete the file as well.
+sub destroy {
+ my ($self, $user, $host, $time) = @_;
+ my $id = $self->{type} . ':' . $self->{name};
+ my $path = $self->file_path;
+ if (defined ($path) && -f $path && !unlink ($path)) {
+ $self->error ("cannot delete $id: $!");
+ return;
+ }
+ return $self->SUPER::destroy ($user, $host, $time);
+}
+
+# Update the keyring if needed, and then return the contents of the current
+# keyring.
+sub get {
+ my ($self, $user, $host, $time) = @_;
+ $time ||= time;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot get $id: object is locked");
+ return;
+ }
+ my $path = $self->file_path;
+ return unless defined $path;
+
+ # Create a WebAuth context and ensure we can load the relevant modules.
+ my $wa = eval { WebAuth->new };
+ if ($@) {
+ $self->error ("cannot initialize WebAuth: $@");
+ return;
+ }
+
+ # Check if the keyring already exists. If not, create a new one with a
+ # single key that's immediately valid and two more that will become valid
+ # in the future.
+ #
+ # If the keyring does already exist, get a lock on the file. At the end
+ # of this process, we'll do an atomic update and then drop our lock.
+ #
+ # FIXME: There are probably better ways to do this. There are some race
+ # conditions here, particularly with new keyrings.
+ unless (open (FILE, '+<', $path)) {
+ my $data;
+ eval {
+ my $key = $wa->key_create (WA_KEY_AES, WA_AES_128);
+ my $ring = $wa->keyring_new ($key);
+ $key = $wa->key_create (WA_KEY_AES, WA_AES_128);
+ my $valid = time + $Wallet::Config::WAKEYRING_REKEY_INTERVAL;
+ $ring->add (time, $valid, $key);
+ $key = $wa->key_create (WA_KEY_AES, WA_AES_128);
+ $valid += $Wallet::Config::WAKEYRING_REKEY_INTERVAL;
+ $ring->add (time, $valid, $key);
+ $data = $ring->encode;
+ $ring->write ($path);
+ };
+ if ($@) {
+ $self->error ("cannot create new keyring");
+ return;
+ };
+ $self->log_action ('get', $user, $host, $time);
+ return $data;
+ }
+ unless (flock (FILE, LOCK_EX)) {
+ $self->error ("cannot get lock on keyring: $!");
+ return;
+ }
+
+ # Read the keyring.
+ my $ring = eval { WebAuth::Keyring->read ($wa, $path) };
+ if ($@) {
+ $self->error ("cannot read keyring: $@");
+ return;
+ }
+
+ # If the most recent key has a valid-after older than now +
+ # WAKEYRING_REKEY_INTERVAL, we generate a new key with a valid_after of
+ # now + 2 * WAKEYRING_REKEY_INTERVAL.
+ my ($count, $newest) = (0, 0);
+ for my $entry ($ring->entries) {
+ $count++;
+ if ($entry->valid_after > $newest) {
+ $newest = $entry->valid_after;
+ }
+ }
+ eval {
+ if ($newest <= time + $Wallet::Config::WAKEYRING_REKEY_INTERVAL) {
+ my $valid = time + 2 * $Wallet::Config::WAKEYRING_REKEY_INTERVAL;
+ my $key = $wa->key_create (WA_KEY_AES, WA_AES_128);
+ $ring->add (time, $valid, $key);
+ }
+ };
+ if ($@) {
+ $self->error ("cannot add new key: $@");
+ return;
+ }
+
+ # If there are any keys older than the purge interval, remove them, but
+ # only do so if we have more than three keys (the one that's currently
+ # active, the one that's going to come active in the rekey interval, and
+ # the one that's going to come active after that.
+ #
+ # FIXME: Be sure that we don't remove the last currently-valid key.
+ my $cutoff = time - $Wallet::Config::WAKEYRING_PURGE_INTERVAL;
+ my $i = 0;
+ my @purge;
+ if ($count > 3) {
+ for my $entry ($ring->entries) {
+ if ($entry->creation < $cutoff) {
+ push (@purge, $i);
+ }
+ $i++;
+ }
+ }
+ if (@purge && $count - @purge >= 3) {
+ eval {
+ for my $key (reverse @purge) {
+ $ring->remove ($key);
+ }
+ };
+ if ($@) {
+ $self->error ("cannot remove old keys: $@");
+ return;
+ }
+ }
+
+ # Encode the key.
+ my $data = eval { $ring->encode };
+ if ($@) {
+ $self->error ("cannot encode keyring: $@");
+ return;
+ }
+
+ # Write the new keyring to the path.
+ eval { $ring->write ($path) };
+ if ($@) {
+ $self->error ("cannot store new keyring: $@");
+ return;
+ }
+ close FILE;
+ $self->log_action ('get', $user, $host, $time);
+ return $data;
+}
+
+# Store the file on the wallet server.
+#
+# FIXME: Check the provided keyring for validity.
+sub store {
+ my ($self, $data, $user, $host, $time) = @_;
+ $time ||= time;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot store $id: object is locked");
+ return;
+ }
+ if ($Wallet::Config::FILE_MAX_SIZE) {
+ my $max = $Wallet::Config::FILE_MAX_SIZE;
+ if (length ($data) > $max) {
+ $self->error ("data exceeds maximum of $max bytes");
+ return;
+ }
+ }
+ my $path = $self->file_path;
+ return unless $path;
+ unless (open (FILE, '>', $path)) {
+ $self->error ("cannot store $id: $!");
+ return;
+ }
+ unless (print FILE ($data) and close FILE) {
+ $self->error ("cannot store $id: $!");
+ close FILE;
+ return;
+ }
+ $self->log_action ('store', $user, $host, $time);
+ return 1;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+WebAuth keyring keyrings API HOSTNAME DATETIME keytab AES rekey Allbery
+
+=head1 NAME
+
+Wallet::Object::WAKeyring - WebAuth keyring object implementation for wallet
+
+=head1 SYNOPSIS
+
+ my ($user, $host, $time);
+ my @name = qw(wa-keyring www.stanford.edu);
+ my @trace = ($user, $host, $time);
+ my $object = Wallet::Object::WAKeyring->create (@name, $schema, $trace);
+ my $keyring = $object->get (@trace);
+ unless ($object->store ($keyring)) {
+ die $object->error, "\n";
+ }
+ $object->destroy (@trace);
+
+=head1 DESCRIPTION
+
+Wallet::Object::WAKeyring is a representation of a WebAuth keyring in the
+wallet. It implements the wallet object API and provides the necessary
+glue to store a keyring on the wallet server, retrieve it, update the
+keyring with new keys automatically as needed, purge old keys
+automatically, and delete the keyring when the object is deleted.
+
+WebAuth keyrings hold one or more keys. Each key has a creation time and
+a validity time. The key cannot be used until its validity time has been
+reached. This permits safe key rotation: a new key is added with a
+validity time in the future, and then the keyring is updated everywhere it
+needs to be before that validity time is reached. This wallet object
+automatically handles key rotation by adding keys with validity dates in
+the future and removing keys with creation dates substantially in the
+past.
+
+To use this object, various configuration options specifying where to
+store the keyrings and how to handle key rotation must be set. See
+Wallet::Config for details on these configuration parameters and
+information about how to set wallet configuration.
+
+=head1 METHODS
+
+This object mostly inherits from Wallet::Object::Base. See the
+documentation for that class for all generic methods. Below are only
+those methods that are overridden or behave specially for this
+implementation.
+
+=over 4
+
+=item destroy(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Destroys a WebAuth keyring object by removing it from the database and
+deleting the corresponding file on the wallet server. Returns true on
+success and false on failure. The caller should call error() to get the
+error message after a failure. PRINCIPAL, HOSTNAME, and DATETIME are
+stored as history information. PRINCIPAL should be the user who is
+destroying the object. If DATETIME isn't given, the current time is used.
+
+=item get(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Either creates a new WebAuth keyring (if this object has not bee stored or
+retrieved before) or does any necessary periodic maintenance on the
+keyring and then returns its data. The caller should call error() to get
+the error message if get() returns undef. PRINCIPAL, HOSTNAME, and
+DATETIME are stored as history information. PRINCIPAL should be the user
+who is downloading the keytab. If DATETIME isn't given, the current time
+is used.
+
+If this object has never been stored or retrieved before, a new keyring
+will be created with three 128-bit AES keys: one that is immediately
+valid, one that will become valid after the rekey interval, and one that
+will become valid after twice the rekey interval.
+
+If keyring data for this object already exists, the creation and validity
+dates for each key in the keyring will be examined. If the key with the
+validity date the farthest into the future has a date that's less than or
+equal to the current time plus the rekey interval, a new 128-bit AES key
+will be added to the keyring with a validity time of twice the rekey
+interval in the future. Finally, all keys with a creation date older than
+the configured purge interval will be removed provided that the keyring
+has at least three keys
+
+=item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME])
+
+Store DATA as the current contents of the WebAuth keyring object. Note
+that this is not checked for validity, just assumed to be a valid keyring.
+Any existing data will be overwritten. Returns true on success and false
+on failure. The caller should call error() to get the error message after
+a failure. PRINCIPAL, HOSTNAME, and DATETIME are stored as history
+information. PRINCIPAL should be the user who is destroying the object.
+If DATETIME isn't given, the current time is used.
+
+If FILE_MAX_SIZE is set in the wallet configuration, a store() of DATA
+larger than that configuration setting will be rejected.
+
+=back
+
+=head1 FILES
+
+=over 4
+
+=item WAKEYRING_BUCKET/<hash>/<file>
+
+WebAuth keyrings are stored on the wallet server under the directory
+WAKEYRING_BUCKET as set in the wallet configuration. <hash> is the first
+two characters of the hex-encoded MD5 hash of the wallet file object name,
+used to not put too many files in the same directory. <file> is the name
+of the file object with all characters other than alphanumerics,
+underscores, and dashes replaced by "%" and the hex code of the character.
+
+=back
+
+=head1 SEE ALSO
+
+Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8), WebAuth(3)
+
+This module is part of the wallet system. The current version is available
+from <http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Policy/Stanford.pm b/perl/lib/Wallet/Policy/Stanford.pm
new file mode 100644
index 0000000..5ac29e0
--- /dev/null
+++ b/perl/lib/Wallet/Policy/Stanford.pm
@@ -0,0 +1,422 @@
+# Wallet::Policy::Stanford -- Stanford's wallet naming and ownership policy.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Policy::Stanford;
+
+use 5.008;
+use strict;
+use warnings;
+
+use base qw(Exporter);
+
+# Declare variables that should be set in BEGIN for robustness.
+our (@EXPORT_OK, $VERSION);
+
+# Set $VERSION and everything export-related in a BEGIN block for robustness
+# against circular module loading (not that we load any modules, but
+# consistency is good).
+BEGIN {
+ $VERSION = '1.00';
+ @EXPORT_OK = qw(default_owner verify_name);
+}
+
+##############################################################################
+# Configuration
+##############################################################################
+
+# These variables are all declared as globals so that they can be overridden
+# from wallet.conf if desirable.
+
+# The domain to append to hostnames to fully-qualify them.
+our $DOMAIN = 'stanford.edu';
+
+# Groups for file object naming, each mapped to the ACL to use for
+# non-host-based objects owned by that group. This default is entirely
+# Stanford-specific, even more so than the rest of this file.
+our %ACL_FOR_GROUP = (
+ 'its-apps' => 'group/its-app-support',
+ 'its-crc-sg' => 'group/crcsg',
+ 'its-idg' => 'group/its-idg',
+ 'its-rc' => 'group/its-rc',
+ 'its-sa-core' => 'group/its-sa-core',
+);
+
+# Legacy group names for older file objects.
+our @GROUPS_LEGACY = qw(apps crcsg gsb idg sysadmin sulair vast);
+
+# File object types. Each type can have one or more parameters: whether it is
+# host-based (host), whether it takes a qualifier after the host or service
+# (extra), and whether that qualifier is mandatory (need_extra).
+our %FILE_TYPE = (
+ config => { extra => 1, need_extra => 1 },
+ db => { extra => 1, need_extra => 1 },
+ 'gpg-key' => { },
+ htpasswd => { host => 1, extra => 1, need_extra => 1 },
+ password => { extra => 1, need_extra => 1 },
+ 'password-ipmi' => { host => 1 },
+ 'password-root' => { host => 1 },
+ 'password-tivoli' => { host => 1 },
+ properties => { extra => 1 },
+ 'ssh-dsa' => { host => 1 },
+ 'ssh-rsa' => { host => 1 },
+ 'ssl-key' => { host => 1, extra => 1 },
+ 'ssl-keypair' => { host => 1, extra => 1 },
+ 'ssl-keystore' => { extra => 1 },
+ 'ssl-pkcs12' => { extra => 1 },
+ 'tivoli-key' => { host => 1 },
+);
+
+# Host-based file object types for the legacy file object naming scheme.
+our @FILE_HOST_LEGACY = qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key);
+
+# File object types for the legacy file object naming scheme.
+our @FILE_TYPES_LEGACY = qw(config db gpg-key htpasswd password properties
+ ssh-rsa ssh-dsa ssl-key ssl-keystore ssl-pkcs12 tivoli-key);
+
+# Host-based Kerberos principal prefixes.
+our @KEYTAB_HOST = qw(HTTP afpserver cifs ftp host imap ipp ldap lpr nfs pop
+ postgres sieve smtp webauth xmpp);
+
+# The Kerberos realm, used when forming principals for krb5 ACLs.
+our $REALM = 'stanford.edu';
+
+# A file listing principal names that should be required to use a root
+# instance to autocreate any objects.
+our $ROOT_REQUIRED = '/etc/remctl/acl/its-idg';
+
+##############################################################################
+# Implementation
+##############################################################################
+
+# Retrieve an existing ACL and return its members as a list.
+#
+# $name - Name of the ACL to retrieve
+#
+# Returns: Members of the ACL as a list of pairs
+# The empty list on any failure to retrieve the ACL
+sub _acl_members {
+ my ($name) = @_;
+ my $schema = eval { Wallet::Schema->connect };
+ return if (!$schema || $@);
+ my $acl = eval { Wallet::ACL->new ($name, $schema) };
+ return if (!$acl || $@);
+ return $acl->list;
+}
+
+# Retrieve an existing ACL and check whether it contains a netdb-root member.
+# This is used to check if a default ACL is already present with a netdb-root
+# member so that we can return a default owner that matches. We only ever
+# increase the ACL from netdb to netdb-root, never degrade it, so this doesn't
+# pose a security problem.
+#
+# On any failure, just return an empty ACL to use the default.
+sub _acl_has_netdb_root {
+ my ($name) = @_;
+ for my $line (_acl_members($name)) {
+ return 1 if $line->[0] eq 'netdb-root';
+ }
+ return;
+}
+
+# Map a file object name to a hostname for the legacy file object naming
+# scheme and return it. Returns undef if this file object name doesn't map to
+# a hostname.
+sub _host_for_file_legacy {
+ my ($name) = @_;
+ my %allowed = map { $_ => 1 } @FILE_HOST_LEGACY;
+ my $allowed_regex = '(?:' . join ('|', sort keys %allowed) . ')';
+ if ($name !~ /^[^-]+-(.*)-$allowed_regex(?:-.*)?$/) {
+ return;
+ }
+ my $host = $1;
+ if ($host !~ /\./) {
+ $host .= q{.} . $DOMAIN;
+ }
+ return $host;
+}
+
+# Map a file object name to a hostname. Returns undef if this file object
+# name doesn't map to a hostname.
+sub _host_for_file {
+ my ($name) = @_;
+
+ # If $name doesn't contain /, defer to the legacy naming scheme.
+ if ($name !~ m{ / }xms) {
+ return _host_for_file_legacy($name);
+ }
+
+ # Parse the name and check whether this is a host-based object.
+ my ($type, $host) = split('/', $name);
+ return if !$FILE_TYPE{$type}{host};
+ return $host;
+}
+
+# Map a keytab object name to a hostname and return it. Returns undef if this
+# keytab principal name doesn't map to a hostname.
+sub _host_for_keytab {
+ my ($name) = @_;
+ my %allowed = map { $_ => 1 } @KEYTAB_HOST;
+ return unless $name =~ m,/,;
+ my ($service, $host) = split ('/', $name, 2);
+ return unless $allowed{$service};
+ if ($host !~ /\./) {
+ $host .= q{.} . $DOMAIN;
+ }
+ return $host;
+}
+
+# The default owner of host-based objects should be the host keytab and the
+# NetDB ACL for that host, with one twist. If the creator of a new node is
+# using a root instance, we want to require everyone managing that node be
+# using root instances by default.
+sub default_owner {
+ my ($type, $name) = @_;
+
+ # How to determine the host for host-based objects.
+ my %host_for = (
+ keytab => \&_host_for_keytab,
+ file => \&_host_for_file,
+ );
+
+ # If we have a possible host mapping, see if we can use that.
+ if (defined($host_for{$type})) {
+ my $host = $host_for{$type}->($name);
+ if ($host) {
+ my $acl_name = "host/$host";
+ my @acl;
+ if ($ENV{REMOTE_USER} =~ m,/root,
+ || _acl_has_netdb_root ($acl_name)) {
+ @acl = ([ 'netdb-root', $host ],
+ [ 'krb5', "host/$host\@$REALM" ]);
+ } else {
+ @acl = ([ 'netdb', $host ],
+ [ 'krb5', "host/$host\@$REALM" ]);
+ }
+ return ($acl_name, @acl);
+ }
+ }
+
+ # We have no open if this is not a file object.
+ return if $type ne 'file';
+
+ # Parse the name of the file object only far enough to get type and group
+ # (if there is a group).
+ my ($file_type, $group) = split('/', $name);
+
+ # Host-based file objects should be caught by the above. We certainly
+ # can't do anything about them here.
+ return if $FILE_TYPE{$file_type}{host};
+
+ # If we have a mapping for this group, retrieve the ACL contents. We
+ # would like to just return the ACL name, but wallet currently requires we
+ # return the whole ACL.
+ my $acl = $ACL_FOR_GROUP{$group};
+ return if !defined($acl);
+ my @members = _acl_members($acl);
+ return if @members == 0;
+ return ($acl, @members);
+}
+
+# Enforce a naming policy. Host-based keytabs must have fully-qualified
+# hostnames, limit the acceptable characters for service/* keytabs, and
+# enforce our naming constraints on */cgi principals.
+#
+# Also use this function to require that IDG staff always do implicit object
+# creation using a */root instance.
+sub verify_name {
+ my ($type, $name, $user) = @_;
+ my %staff;
+ if (open (STAFF, '<', $ROOT_REQUIRED)) {
+ local $_;
+ while (<STAFF>) {
+ s/^\s+//;
+ s/\s+$//;
+ next if m,/root\@,;
+ $staff{$_} = 1;
+ }
+ close STAFF;
+ }
+
+ # Check for a staff member not using their root instance.
+ if (defined ($user) && $staff{$user}) {
+ return 'use a */root instance for wallet object creation';
+ }
+
+ # Check keytab naming conventions.
+ if ($type eq 'keytab') {
+ my %host = map { $_ => 1 } @KEYTAB_HOST;
+ if ($name !~ m,^[a-zA-Z0-9_-]+/[a-z0-9.-]+$,) {
+ return "invalid principal name $name";
+ }
+ my ($principal, $instance)
+ = ($name =~ m,^([a-zA-Z0-9_-]+)/([a-z0-9.-]+)$,);
+ unless (defined ($principal) && defined ($instance)) {
+ return "invalid principal name $name";
+ }
+ if ($host{$principal} and $principal ne 'http') {
+ if ($instance !~ /^[a-z0-9-]+\.[a-z0-9.-]+$/) {
+ return "host name $instance is not fully qualified";
+ }
+ } elsif ($principal eq 'afs') {
+ if ($instance !~ /^[a-z0-9-]+\.[a-z0-9.-]+$/) {
+ return "AFS cell name $instance is not fully qualified";
+ }
+ } elsif ($principal eq 'service') {
+ if ($instance !~ /^[a-z0-9-]+$/) {
+ return "invalid service principal name $name";
+ }
+ } elsif ($instance eq 'cgi') {
+ if ($principal !~ /^[a-z][a-z0-9]{1,7}$/
+ and $principal !~ /^(class|dept|group)-[a-z0-9_-]+$/) {
+ return "invalid CGI principal name $name";
+ }
+ } elsif ($instance eq 'cron') {
+ if ($principal !~ /^[a-z][a-z0-9]{1,7}$/
+ and $principal !~ /^(class|dept|group)-[a-z0-9_-]+$/) {
+ return "invalid cron principal name $name";
+ }
+ } else {
+ return "unknown principal type $principal";
+ }
+ }
+
+ # Check file object naming conventions.
+ if ($type eq 'file') {
+ if ($name =~ m{ / }xms) {
+ my @name = split('/', $name);
+
+ # Names have between two and four components and all must be
+ # non-empty.
+ if (@name > 4) {
+ return "too many components in $name";
+ }
+ if (@name < 2) {
+ return "too few components in $name";
+ }
+ if (grep { $_ eq q{} } @name) {
+ return "empty component in $name";
+ }
+
+ # All objects start with the type. First check if this is a
+ # host-based type.
+ my $type = shift @name;
+ if ($FILE_TYPE{$type} && $FILE_TYPE{$type}{host}) {
+ my ($host, $extra) = @name;
+ if ($host !~ m{ [.] }xms) {
+ return "host name $host is not fully qualified";
+ }
+ if (defined($extra) && !$FILE_TYPE{$type}{extra}) {
+ return "extraneous component at end of $name";
+ }
+ if (!defined($extra) && $FILE_TYPE{$type}{need_extra}) {
+ return "missing component in $name";
+ }
+ return;
+ }
+
+ # Otherwise, the name is group-based. There be at least two
+ # remaining components.
+ if (@name < 2) {
+ return "too few components in $name";
+ }
+ my ($group, $service, $extra) = @name;
+
+ # Check the group.
+ if (!$ACL_FOR_GROUP{$group}) {
+ return "unknown group $group";
+ }
+
+ # Check the type. Be sure it's not host-based.
+ if (!$FILE_TYPE{$type}) {
+ return "unknown type $type";
+ }
+ if ($FILE_TYPE{$type}{host}) {
+ return "bad name for host-based file type $type";
+ }
+
+ # Check the extra data.
+ if (defined($extra) && !$FILE_TYPE{$type}{extra}) {
+ return "extraneous component at end of $name";
+ }
+ if (!defined($extra) && $FILE_TYPE{$type}{need_extra}) {
+ return "missing component in $name";
+ }
+ return;
+ } else {
+ # Legacy naming scheme.
+ my %groups = map { $_ => 1 } @GROUPS_LEGACY;
+ my %types = map { $_ => 1 } @FILE_TYPES_LEGACY;
+ if ($name !~ m,^[a-zA-Z0-9_.-]+$,) {
+ return "invalid file object $name";
+ }
+ my $group_regex = '(?:' . join ('|', sort keys %groups) . ')';
+ my $type_regex = '(?:' . join ('|', sort keys %types) . ')';
+ if ($name !~ /^$group_regex-/) {
+ return "no recognized owning group in $name";
+ } elsif ($name !~ /^$group_regex-.*-$type_regex(-.*)?$/) {
+ return "invalid file object name $name";
+ }
+ }
+ }
+
+ # Success.
+ return;
+}
+
+1;
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+Allbery
+
+=head1 NAME
+
+Wallet::Policy::Stanford - Stanford's wallet naming and ownership policy
+
+=head1 SYNOPSIS
+
+ use Wallet::Policy::Stanford;
+ my ($type, $name, $user) = @_;
+
+ my $error = valid_name($type, $name, $user);
+ my ($name, @acl) = default_owner($type, $name);
+
+=head1 DESCRIPTION
+
+Wallet::Policy::Stanford implements Stanford's wallet naming and ownership
+policy as described in F<docs/stanford-naming> in the wallet distribution.
+It is primarily intended as an example for other sites, but it is used at
+Stanford to implement that policy.
+
+This module provides the default_owner() and verify_name() functions that
+are part of the wallet configuration interface (as documented in
+L<Wallet::Config>). They can be imported directly into a wallet
+configuration file from this module or wrapped to apply additional rules.
+
+=head1 SEE ALSO
+
+Wallet::Config(3)
+
+The L<Stanford policy|http://www.eyrie.org/~eagle/software/wallet/naming.html>
+implemented by this module.
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Report.pm b/perl/lib/Wallet/Report.pm
new file mode 100644
index 0000000..1085546
--- /dev/null
+++ b/perl/lib/Wallet/Report.pm
@@ -0,0 +1,680 @@
+# Wallet::Report -- Wallet system reporting interface.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2008, 2009, 2010, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Report;
+require 5.006;
+
+use strict;
+use vars qw($VERSION);
+
+use Wallet::ACL;
+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';
+
+##############################################################################
+# Constructor, destructor, and accessors
+##############################################################################
+
+# Create a new wallet report object. Opens a connection to the database that
+# will be used for all of the wallet configuration information. Throw an
+# exception if anything goes wrong.
+sub new {
+ my ($class) = @_;
+ my $schema = Wallet::Schema->connect;
+ my $self = { schema => $schema };
+ bless ($self, $class);
+ return $self;
+}
+
+# Returns the database handle (used mostly for testing).
+sub dbh {
+ my ($self) = @_;
+ return $self->{schema}->storage->dbh;
+}
+
+# Returns the DBIx::Class-based database schema object.
+sub schema {
+ my ($self) = @_;
+ return $self->{schema};
+}
+
+# Set or return the error stashed in the object.
+sub error {
+ my ($self, @error) = @_;
+ if (@error) {
+ my $error = join ('', @error);
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ $self->{error} = $error;
+ }
+ return $self->{error};
+}
+
+# Disconnect the database handle on object destruction to avoid warnings.
+sub DESTROY {
+ my ($self) = @_;
+ $self->{schema}->storage->dbh->disconnect;
+}
+
+##############################################################################
+# Object reports
+##############################################################################
+
+# Return the SQL statement to find every object in the database.
+sub objects_all {
+ my ($self) = @_;
+ my @objects;
+
+ my %search = ();
+ my %options = (order_by => [ qw/ob_type ob_name/ ],
+ select => [ qw/ob_type ob_name/ ]);
+
+ return (\%search, \%options);
+}
+
+# Return the SQL statement and the search field required to find all objects
+# matching a specific type.
+sub objects_type {
+ my ($self, $type) = @_;
+ my @objects;
+
+ my %search = (ob_type => $type);
+ my %options = (order_by => [ qw/ob_type ob_name/ ],
+ select => [ qw/ob_type ob_name/ ]);
+
+ return (\%search, \%options);
+}
+
+# Return the SQL statement and search field required to find all objects owned
+# by a given ACL. If the requested owner is null, we ignore this and do a
+# different search for IS NULL. If the requested owner does not actually
+# match any ACLs, set an error and return undef.
+sub objects_owner {
+ my ($self, $owner) = @_;
+ my @objects;
+
+ my %search;
+ my %options = (order_by => [ qw/ob_type ob_name/ ],
+ select => [ qw/ob_type ob_name/ ]);
+
+ if (lc ($owner) eq 'null') {
+ %search = (ob_owner => undef);
+ } else {
+ my $acl = eval { Wallet::ACL->new ($owner, $self->{schema}) };
+ return unless $acl;
+ %search = (ob_owner => $acl->id);
+ }
+
+ return (\%search, \%options);
+}
+
+# Return the SQL statement and search field required to find all objects that
+# have a specific flag set.
+sub objects_flag {
+ my ($self, $flag) = @_;
+ my @objects;
+
+ my %search = ('flags.fl_flag' => $flag);
+ my %options = (join => 'flags',
+ prefetch => 'flags',
+ order_by => [ qw/ob_type ob_name/ ],
+ select => [ qw/ob_type ob_name/ ]);
+
+ return (\%search, \%options);
+}
+
+# Return the SQL statement and search field required to find all objects that
+# a given ACL has any permissions on. This expands from objects_owner in that
+# it will also match any records that have the ACL set for get, store, show,
+# destroy, or flags. If the requested owner does not actually match any ACLs,
+# set an error and return the empty string.
+sub objects_acl {
+ my ($self, $search) = @_;
+ my @objects;
+
+ my $schema = $self->{schema};
+ my $acl = eval { Wallet::ACL->new ($search, $schema) };
+ return unless $acl;
+
+ my @search = ({ ob_owner => $acl->id },
+ { ob_acl_get => $acl->id },
+ { ob_acl_store => $acl->id },
+ { ob_acl_show => $acl->id },
+ { ob_acl_destroy => $acl->id },
+ { ob_acl_flags => $acl->id });
+ my %options = (order_by => [ qw/ob_type ob_name/ ],
+ select => [ qw/ob_type ob_name/ ]);
+
+ return (\@search, \%options);
+}
+
+# Return the SQL statement to find all objects that have been created but
+# have never been retrieved (via get).
+sub objects_unused {
+ my ($self) = @_;
+ my @objects;
+
+ my %search = (ob_downloaded_on => undef);
+ my %options = (order_by => [ qw/ob_type ob_name/ ],
+ select => [ qw/ob_type ob_name/ ]);
+
+ return (\%search, \%options);
+}
+
+# Returns a list of all objects stored in the wallet database in the form of
+# type and name pairs. On error and for an empty database, the empty list
+# will be returned. To distinguish between an empty list and an error, call
+# error(), which will return undef if there was no error. Farms out specific
+# statement to another subroutine for specific search types, but each case
+# should return ob_type and ob_name in that order.
+sub objects {
+ my ($self, $type, @args) = @_;
+ undef $self->{error};
+
+ # Get the search and options array refs from specific functions.
+ my ($search_ref, $options_ref);
+ if (!defined $type || $type eq '') {
+ ($search_ref, $options_ref) = $self->objects_all;
+ } else {
+ if ($type ne 'unused' && @args != 1) {
+ $self->error ("object searches require one argument to search");
+ } elsif ($type eq 'type') {
+ ($search_ref, $options_ref) = $self->objects_type (@args);
+ } elsif ($type eq 'owner') {
+ ($search_ref, $options_ref) = $self->objects_owner (@args);
+ } elsif ($type eq 'flag') {
+ ($search_ref, $options_ref) = $self->objects_flag (@args);
+ } elsif ($type eq 'acl') {
+ ($search_ref, $options_ref) = $self->objects_acl (@args);
+ } elsif ($type eq 'unused') {
+ ($search_ref, $options_ref) = $self->objects_unused (@args);
+ } else {
+ $self->error ("do not know search type: $type");
+ }
+ return unless $search_ref;
+ }
+
+ # Perform the search and return on any errors.
+ my @objects;
+ my $schema = $self->{schema};
+ eval {
+ my @objects_rs = $schema->resultset('Object')->search ($search_ref,
+ $options_ref);
+ for my $object_rs (@objects_rs) {
+ push (@objects, [ $object_rs->ob_type, $object_rs->ob_name ]);
+ }
+ };
+ if ($@) {
+ $self->error ("cannot list objects: $@");
+ return;
+ }
+
+ return @objects;
+}
+
+##############################################################################
+# ACL reports
+##############################################################################
+
+# Returns the SQL statement required to find and return all ACLs in the
+# database.
+sub acls_all {
+ my ($self) = @_;
+ my @acls;
+
+ my $schema = $self->{schema};
+ my %search = ();
+ my %options = (order_by => [ qw/ac_id/ ],
+ select => [ qw/ac_id ac_name/ ]);
+
+ eval {
+ my @acls_rs = $schema->resultset('Acl')->search (\%search, \%options);
+ for my $acl_rs (@acls_rs) {
+ push (@acls, [ $acl_rs->ac_id, $acl_rs->ac_name ]);
+ }
+ };
+
+ if ($@) {
+ $self->error ("cannot list ACLs: $@");
+ return;
+ }
+ return (@acls);
+}
+
+# Returns the SQL statement required to find all empty ACLs in the database.
+sub acls_empty {
+ my ($self) = @_;
+ my @acls;
+
+ my $schema = $self->{schema};
+ my %search = (ae_id => undef);
+ my %options = (join => 'acl_entries',
+ prefetch => 'acl_entries',
+ order_by => [ qw/ac_id/ ],
+ select => [ qw/ac_id ac_name/ ]);
+
+ eval {
+ my @acls_rs = $schema->resultset('Acl')->search (\%search, \%options);
+ for my $acl_rs (@acls_rs) {
+ push (@acls, [ $acl_rs->ac_id, $acl_rs->ac_name ]);
+ }
+ };
+
+ if ($@) {
+ $self->error ("cannot list ACLs: $@");
+ return;
+ }
+ return (@acls);
+}
+
+# Returns the SQL statement and the field required to find ACLs containing the
+# specified entry. The identifier is automatically surrounded by wildcards to
+# do a substring search.
+sub acls_entry {
+ my ($self, $type, $identifier) = @_;
+ my @acls;
+
+ my $schema = $self->{schema};
+ my %search = (ae_scheme => $type,
+ ae_identifier => { like => '%'.$identifier.'%' });
+ my %options = (join => 'acl_entries',
+ prefetch => 'acl_entries',
+ order_by => [ qw/ac_id/ ],
+ select => [ qw/ac_id ac_name/ ],
+ distinct => 1);
+
+ eval {
+ my @acls_rs = $schema->resultset('Acl')->search (\%search, \%options);
+ for my $acl_rs (@acls_rs) {
+ push (@acls, [ $acl_rs->ac_id, $acl_rs->ac_name ]);
+ }
+ };
+
+ if ($@) {
+ $self->error ("cannot list ACLs: $@");
+ return;
+ }
+ return (@acls);
+}
+
+# Returns the SQL statement required to find unused ACLs.
+sub acls_unused {
+ my ($self) = @_;
+ my @acls;
+
+ my $schema = $self->{schema};
+ my %search = (
+ #'acls_owner.ob_owner' => undef,
+ #'acls_get.ob_owner' => undef,
+ #'acls_store.ob_owner' => undef,
+ #'acls_show.ob_owner' => undef,
+ #'acls_destroy.ob_owner' => undef,
+ #'acls_flags.ob_owner' => undef,
+ );
+ my %options = (#join => [ qw/acls_owner acls_get acls_store acls_show acls_destroy acls_flags/ ],
+ order_by => [ qw/ac_id/ ],
+ select => [ qw/ac_id ac_name/ ]);
+
+ eval {
+ my @acls_rs = $schema->resultset('Acl')->search (\%search, \%options);
+
+ # FIXME: Almost certainly a way of doing this with the search itself.
+ for my $acl_rs (@acls_rs) {
+ next if $acl_rs->acls_owner->first;
+ next if $acl_rs->acls_get->first;
+ next if $acl_rs->acls_store->first;
+ next if $acl_rs->acls_show->first;
+ next if $acl_rs->acls_destroy->first;
+ next if $acl_rs->acls_flags->first;
+ push (@acls, [ $acl_rs->ac_id, $acl_rs->ac_name ]);
+ }
+ };
+
+ if ($@) {
+ $self->error ("cannot list ACLs: $@");
+ return;
+ }
+ return (@acls);
+}
+
+# Obtain a textual representation of the membership of an ACL, returning undef
+# on error and setting the internal error.
+sub acl_membership {
+ my ($self, $id) = @_;
+ my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ my @members = map { "$_->[0] $_->[1]" } $acl->list;
+ if (!@members && $acl->error) {
+ $self->error ($acl->error);
+ return;
+ }
+ return join ("\n", @members);
+}
+
+# Duplicate ACL detection unfortunately needs to do something more complex
+# than just return a SQL statement, so it's handled differently than other
+# reports. All the work is done here and the results returned as a list of
+# sets of duplicates.
+sub acls_duplicate {
+ my ($self) = @_;
+ my @acls = sort map { $_->[1] } $self->acls;
+ return if (!@acls && $self->{error});
+ return if @acls < 2;
+ my %result;
+ for my $i (0 .. ($#acls - 1)) {
+ my $members = $self->acl_membership ($acls[$i]);
+ return unless defined $members;
+ for my $j (($i + 1) .. $#acls) {
+ my $check = $self->acl_membership ($acls[$j]);
+ return unless defined $check;
+ if ($check eq $members) {
+ $result{$acls[$i]} ||= [];
+ push (@{ $result{$acls[$i]} }, $acls[$j]);
+ }
+ }
+ }
+ my @result;
+ for my $acl (sort keys %result) {
+ push (@result, [ $acl, sort @{ $result{$acl} } ]);
+ }
+ return @result;
+}
+
+# Returns a list of all ACLs stored in the wallet database as a list of pairs
+# of ACL IDs and ACL names, possibly limited by some criteria. On error and
+# for an empty database, the empty list will be returned. To distinguish
+# between an empty list and an error, call error(), which will return undef if
+# there was no error.
+sub acls {
+ my ($self, $type, @args) = @_;
+ undef $self->{error};
+
+ # Find the ACLs for any given search.
+ my @acls;
+ if (!defined $type || $type eq '') {
+ @acls = $self->acls_all;
+ } else {
+ if ($type eq 'duplicate') {
+ return $self->acls_duplicate;
+ } elsif ($type eq 'entry') {
+ if (@args == 0) {
+ $self->error ('ACL searches require an argument to search');
+ return;
+ } else {
+ @acls = $self->acls_entry (@args);
+ }
+ } elsif ($type eq 'empty') {
+ @acls = $self->acls_empty;
+ } elsif ($type eq 'unused') {
+ @acls = $self->acls_unused;
+ } else {
+ $self->error ("unknown search type: $type");
+ return;
+ }
+ }
+ return @acls;
+}
+
+# Returns all ACL entries contained in owner ACLs for matching objects.
+# Objects are specified by type and name, which may be SQL wildcard
+# expressions. Each list member will be a pair of ACL scheme and ACL
+# identifier, with duplicates removed. On error and for no matching entries,
+# the empty list will be returned. To distinguish between an empty return and
+# an error, call error(), which will return undef if there was no error.
+sub owners {
+ my ($self, $type, $name) = @_;
+ undef $self->{error};
+ my $schema = $self->{schema};
+
+ my @owners;
+ eval {
+ my %search = (
+ 'acls_owner.ob_type' => { like => $type },
+ 'acls_owner.ob_name' => { like => $name });
+ my %options = (
+ join => { 'acls' => 'acls_owner' },
+ order_by => [ qw/ae_scheme ae_identifier/ ],
+ distinct => 1,
+ );
+
+ my @acls_rs = $schema->resultset('AclEntry')->search (\%search,
+ \%options);
+ for my $acl_rs (@acls_rs) {
+ my $scheme = $acl_rs->ae_scheme;
+ my $identifier = $acl_rs->ae_identifier;
+ push (@owners, [ $scheme, $identifier ]);
+ }
+ };
+ if ($@) {
+ $self->error ("cannot report on owners: $@");
+ return;
+ }
+ return @owners;
+}
+
+##############################################################################
+# Auditing
+##############################################################################
+
+# Audit the database for violations of local policy. Returns a list of
+# objects (as type and name pairs) or a list of ACLs (as ID and name pairs).
+# On error and for no matching entries, the empty list will be returned. To
+# distinguish between an empty return and an error, call error(), which will
+# return undef if there was no error.
+sub audit {
+ my ($self, $type, $audit) = @_;
+ undef $self->{error};
+ unless (defined ($type) and defined ($audit)) {
+ $self->error ("type and audit not specified");
+ return;
+ }
+ if ($type eq 'objects') {
+ if ($audit eq 'name') {
+ return unless defined &Wallet::Config::verify_name;
+ my @objects = $self->objects;
+ my @results;
+ for my $object (@objects) {
+ my ($type, $name) = @$object;
+ my $error = Wallet::Config::verify_name ($type, $name);
+ push (@results, $object) if $error;
+ }
+ return @results;
+ } else {
+ $self->error ("unknown object audit: $audit");
+ return;
+ }
+ } elsif ($type eq 'acls') {
+ if ($audit eq 'name') {
+ return unless defined &Wallet::Config::verify_acl_name;
+ my @acls = $self->acls;
+ my @results;
+ for my $acl (@acls) {
+ my $error = Wallet::Config::verify_acl_name ($acl->[1]);
+ push (@results, $acl) if $error;
+ }
+ return @results;
+ } else {
+ $self->error ("unknown acl audit: $audit");
+ return;
+ }
+ } else {
+ $self->error ("unknown audit type: $type");
+ return;
+ }
+}
+
+1;
+__DATA__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=head1 NAME
+
+Wallet::Report - Wallet system reporting interface
+
+=for stopwords
+ACL ACLs wildcard Allbery SQL tuples
+
+=head1 SYNOPSIS
+
+ use Wallet::Report;
+ my $report = Wallet::Report->new;
+ my @objects = $report->objects ('type', 'keytab');
+ for my $object (@objects) {
+ print "@$object\n";
+ }
+ @objects = $report->audit ('objects', 'name');
+
+=head1 DESCRIPTION
+
+Wallet::Report provides a mechanism to generate lists and reports on the
+contents of the wallet database. The format of the results returned
+depend on the type of search, but will generally be returned as a list of
+tuples identifying objects, ACLs, or ACL entries.
+
+To use this object, several configuration variables must be set (at least
+the database configuration). For information on those variables and how
+to set them, see L<Wallet::Config>. For more information on the normal
+user interface to the wallet server, see L<Wallet::Server>.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new()
+
+Creates a new wallet report object and connects to the database. On any
+error, this method throws an exception.
+
+=back
+
+=head1 INSTANCE METHODS
+
+For all methods that can fail, the caller should call error() after a
+failure to get the error message. For all methods that return lists, if
+they return an empty list, the caller should call error() to distinguish
+between an empty report and an error.
+
+=over 4
+
+=item acls([ TYPE [, SEARCH ... ]])
+
+Returns a list of all ACLs matching a search type and string in the
+database, or all ACLs if no search information is given. There are
+currently four search types. C<duplicate> returns sets of duplicate ACLs
+(ones with exactly the same entries). C<empty> takes no arguments and
+will return only those ACLs that have no entries within them. C<entry>
+takes two arguments, an entry scheme and a (possibly partial) entry
+identifier, and will return any ACLs containing an entry with that scheme
+and with an identifier containing that value. C<unused> returns all ACLs
+that are not referenced by any object.
+
+The return value for everything except C<duplicate> is a list of
+references to pairs of ACL ID and name. For example, if there are two
+ACLs in the database, one with name C<ADMIN> and ID 1 and one with name
+C<group/admins> and ID 3, acls() with no arguments would return:
+
+ ([ 1, 'ADMIN' ], [ 3, 'group/admins' ])
+
+The return value for the C<duplicate> search is sets of ACL names that are
+duplicates (have the same entries). For example, if C<d1>, C<d2>, and
+C<d3> are all duplicates, and C<o1> and C<o2> are also duplicates, the
+result would be:
+
+ ([ 'd1', 'd2', 'd3' ], [ 'o1', 'o2' ])
+
+Returns the empty list on failure. An error can be distinguished from
+empty search results by calling error(). error() is guaranteed to return
+the error message if there was an error and undef if there was no error.
+
+=item audit(TYPE, AUDIT)
+
+Audits the wallet database for violations of local policy. TYPE is the
+general class of thing to audit, and AUDIT is the specific audit to
+perform. TYPE may be either C<objects> or C<acls>. Currently, the only
+implemented audit is C<name>. This returns a list of all objects, as
+references to pairs of type and name, or ACLs, as references to pairs of
+ID and name, that are not accepted by the verify_name() or
+verify_acl_name() function defined in the wallet configuration. See
+L<Wallet::Config> for more information.
+
+Returns the empty list on failure. An error can be distinguished from
+empty search results by calling error(). error() is guaranteed to return
+the error message if there was an error and undef if there was no error.
+
+=item error()
+
+Returns the error of the last failing operation or undef if no operations
+have failed. Callers should call this function to get the error message
+after an undef return from any other instance method.
+
+=item objects([ TYPE [, SEARCH ... ]])
+
+Returns a list of all objects matching a search type and string in the
+database, or all objects in the database if no search information is
+given.
+
+There are five types of searches currently. C<type>, with a given type,
+will return only those entries where the type matches the given type.
+C<owner>, with a given owner, will only return those objects owned by the
+given ACL name or ID. C<flag>, with a given flag name, will only return
+those items with a flag set to the given value. C<acl> operates like
+C<owner>, but will return only those objects that have the given ACL name
+or ID on any of the possible ACL settings, not just owner. C<unused> will
+return all entries for which a get command has never been issued.
+
+The return value is a list of references to pairs of type and name. For
+example, if two objects existed in the database, both of type C<keytab>
+and with values C<host/example.com> and C<foo>, objects() with no
+arguments would return:
+
+ ([ 'keytab', 'host/example.com' ], [ 'keytab', 'foo' ])
+
+Returns the empty list on failure. To distinguish between this and an
+empty search result, the caller should call error(). error() is
+guaranteed to return the error message if there was an error and undef if
+there was no error.
+
+=item owners(TYPE, NAME)
+
+Returns a list of all ACL lines contained in owner ACLs for objects
+matching TYPE and NAME, which are interpreted as SQL patterns using C<%>
+as a wildcard. The return value is a list of references to pairs of
+schema and identifier, with duplicates removed.
+
+Returns the empty list on failure. To distinguish between this and no
+matches, the caller should call error(). error() is guaranteed to return
+the error message if there was an error and undef if there was no error.
+
+=back
+
+=head1 SEE ALSO
+
+Wallet::Config(3), Wallet::Server(3)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org> and Jon Robertson <jonrober@stanford.edu>.
+
+=cut
diff --git a/perl/lib/Wallet/Schema.pm b/perl/lib/Wallet/Schema.pm
new file mode 100644
index 0000000..74b4c99
--- /dev/null
+++ b/perl/lib/Wallet/Schema.pm
@@ -0,0 +1,354 @@
+# Database schema and connector for the wallet system.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema;
+
+use strict;
+use warnings;
+
+use Wallet::Config;
+
+use base 'DBIx::Class::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.
+our $VERSION = '0.09';
+
+__PACKAGE__->load_namespaces;
+__PACKAGE__->load_components (qw/Schema::Versioned/);
+
+##############################################################################
+# Core overrides
+##############################################################################
+
+# Override DBI::connect to supply our own connect string, username, and
+# password and to set some standard options. Takes no arguments other than
+# the implicit class argument.
+sub connect {
+ my ($class) = @_;
+ unless ($Wallet::Config::DB_DRIVER
+ and (defined ($Wallet::Config::DB_INFO)
+ or defined ($Wallet::Config::DB_NAME))) {
+ die "database connection information not configured\n";
+ }
+ my $dsn = "DBI:$Wallet::Config::DB_DRIVER:";
+ if (defined $Wallet::Config::DB_INFO) {
+ $dsn .= $Wallet::Config::DB_INFO;
+ } else {
+ $dsn .= "database=$Wallet::Config::DB_NAME";
+ $dsn .= ";host=$Wallet::Config::DB_HOST" if $Wallet::Config::DB_HOST;
+ $dsn .= ";port=$Wallet::Config::DB_PORT" if $Wallet::Config::DB_PORT;
+ }
+ my $user = $Wallet::Config::DB_USER;
+ my $pass = $Wallet::Config::DB_PASSWORD;
+ my %attrs = (PrintError => 0, RaiseError => 1);
+ my $schema = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) };
+ if ($@) {
+ die "cannot connect to database: $@\n";
+ }
+ return $schema;
+}
+
+1;
+
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+RaiseError PrintError AutoCommit ACL verifier API APIs enums keytab backend
+enctypes DBI Allbery
+
+=head1 NAME
+
+Wallet::Schema - Database schema and connector for the wallet system
+
+=head1 SYNOPSIS
+
+ use Wallet::Schema;
+ my $schema = Wallet::Schema->connect;
+
+=head1 DESCRIPTION
+
+This class encapsulates the database schema for the wallet system. The
+documentation you're reading explains and comments the schema. The
+class runs using the DBIx::Class module.
+
+connect() will obtain the database connection information from the wallet
+configuration; see L<Wallet::Config> for more details. It will also
+automatically set the RaiseError attribute to true and the PrintError and
+AutoCommit attributes to false, matching the assumptions made by the
+wallet database code.
+
+=head1 SCHEMA
+
+=head2 Normalization Tables
+
+Holds the supported object types and their corresponding Perl classes:
+
+ create table types
+ (ty_name varchar(16) primary key,
+ ty_class varchar(64));
+ insert into types (ty_name, ty_class)
+ values ('file', 'Wallet::Object::File');
+ insert into types (ty_name, ty_class)
+ values ('keytab', 'Wallet::Object::Keytab');
+
+Holds the supported ACL schemes and their corresponding Perl classes:
+
+ create table acl_schemes
+ (as_name varchar(32) primary key,
+ as_class varchar(64));
+ insert into acl_schemes (as_name, as_class)
+ values ('krb5', 'Wallet::ACL::Krb5');
+ insert into acl_schemes (as_name, as_class)
+ values ('krb5-regex', 'Wallet::ACL::Krb5::Regex');
+ insert into acl_schemes (as_name, as_class)
+ values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute');
+ insert into acl_schemes (as_name, as_class)
+ values ('netdb', 'Wallet::ACL::NetDB');
+ insert into acl_schemes (as_name, as_class)
+ values ('netdb-root', 'Wallet::ACL::NetDB::Root');
+
+If you have extended the wallet to support additional object types or
+additional ACL schemes, you will want to add additional rows to these
+tables mapping those types or schemes to Perl classes that implement the
+object or ACL verifier APIs.
+
+=head2 ACL Tables
+
+A wallet ACL consists of zero or more ACL entries, each of which is a
+scheme and an identifier. The scheme identifies the check that should be
+performed and the identifier is additional scheme-specific information.
+Each ACL references entries in the following table:
+
+ create table acls
+ (ac_id integer auto_increment primary key,
+ ac_name varchar(255) not null,
+ unique (ac_name));
+
+This just keeps track of unique ACL identifiers. The data is then stored
+in:
+
+ create table acl_entries
+ (ae_id integer not null references acls(ac_id),
+ ae_scheme varchar(32)
+ not null references acl_schemes(as_name),
+ ae_identifier varchar(255) not null,
+ primary key (ae_id, ae_scheme, ae_identifier));
+ create index ae_id on acl_entries (ae_id);
+
+ACLs may be referred to in the API via either the numeric ID or the
+human-readable name, but internally ACLs are always referenced by numeric
+ID so that they can be renamed without requiring complex data
+modifications.
+
+Currently, the ACL named C<ADMIN> (case-sensitive) is special-cased in the
+Wallet::Server code and granted global access.
+
+Every change made to any ACL in the database will be recorded in this
+table.
+
+ create table acl_history
+ (ah_id integer auto_increment primary key,
+ ah_acl integer not null,
+ ah_action varchar(16) not null,
+ ah_scheme varchar(32) default null,
+ ah_identifier varchar(255) default null,
+ ah_by varchar(255) not null,
+ ah_from varchar(255) not null,
+ ah_on datetime not null);
+ create index ah_acl on acl_history (ah_acl);
+
+ah_action must be one of C<create>, C<destroy>, C<add>, or C<remove>
+(enums aren't used for compatibility with databases other than MySQL).
+For a change of type create or destroy, only the action and the trace
+records (by, from, and on) are stored. For a change to the lines of an
+ACL, the scheme and identifier of the line that was added or removed is
+included. Note that changes to the ACL name are not recorded; ACLs are
+always tracked by system-generated ID, so name changes are purely
+cosmetic.
+
+ah_by stores the authenticated identity that made the change, ah_from
+stores the host from which they made the change, and ah_on stores the time
+the change was made.
+
+=head2 Object Tables
+
+Each object stored in the wallet is represented by an entry in the objects
+table:
+
+ create table objects
+ (ob_type varchar(16)
+ not null references types(ty_name),
+ ob_name varchar(255) not null,
+ ob_owner integer default null references acls(ac_id),
+ ob_acl_get integer default null references acls(ac_id),
+ ob_acl_store integer default null references acls(ac_id),
+ ob_acl_show integer default null references acls(ac_id),
+ ob_acl_destroy integer default null references acls(ac_id),
+ ob_acl_flags integer default null references acls(ac_id),
+ ob_expires datetime default null,
+ ob_created_by varchar(255) not null,
+ ob_created_from varchar(255) not null,
+ ob_created_on datetime not null,
+ ob_stored_by varchar(255) default null,
+ ob_stored_from varchar(255) default null,
+ ob_stored_on datetime default null,
+ ob_downloaded_by varchar(255) default null,
+ ob_downloaded_from varchar(255) default null,
+ ob_downloaded_on datetime default null,
+ ob_comment varchar(255) default null,
+ primary key (ob_name, ob_type));
+ create index ob_owner on objects (ob_owner);
+ create index ob_expires on objects (ob_expires);
+
+Object names are not globally unique but only unique within their type, so
+the table has a joint primary key. Each object has an owner and then up
+to five more specific ACLs. The owner provides permission for get, store,
+and show operations if no more specific ACL is set. It does not provide
+permission for destroy or flags.
+
+The ob_acl_flags ACL controls who can set flags on this object. Each
+object may have zero or more flags associated with it:
+
+ create table flags
+ (fl_type varchar(16)
+ not null references objects(ob_type),
+ fl_name varchar(255)
+ not null references objects(ob_name),
+ fl_flag enum('locked', 'unchanging')
+ not null,
+ primary key (fl_type, fl_name, fl_flag));
+ create index fl_object on flags (fl_type, fl_name);
+
+Every change made to any object in the wallet database will be recorded in
+this table:
+
+ create table object_history
+ (oh_id integer auto_increment primary key,
+ oh_type varchar(16)
+ not null references objects(ob_type),
+ oh_name varchar(255)
+ not null references objects(ob_name),
+ oh_action varchar(16) not null,
+ oh_field varchar(16) default null,
+ oh_type_field varchar(255) default null,
+ oh_old varchar(255) default null,
+ oh_new varchar(255) default null,
+ oh_by varchar(255) not null,
+ oh_from varchar(255) not null,
+ oh_on datetime not null);
+ create index oh_object on object_history (oh_type, oh_name);
+
+oh_action must be one of C<create>, C<destroy>, C<get>, C<store>, or
+C<set>. oh_field must be one of C<owner>, C<acl_get>, C<acl_store>,
+C<acl_show>, C<acl_destroy>, C<acl_flags>, C<expires>, C<flags>, or
+C<type_data>. Enums aren't used for compatibility with databases other
+than MySQL.
+
+For a change of type create, get, store, or destroy, only the action and
+the trace records (by, from, and on) are stored. For changes to columns
+or to the flags table, oh_field takes what attribute is changed, oh_from
+takes the previous value converted to a string and oh_to takes the next
+value similarly converted to a string. The special field value
+"type_data" is used when type-specific data is changed, and in that case
+(and only that case) some type-specific name for the data being changed is
+stored in oh_type_field.
+
+When clearing a flag, oh_old will have the name of the flag and oh_new
+will be null. When setting a flag, oh_old will be null and oh_new will
+have the name of the flag.
+
+oh_by stores the authenticated identity that made the change, oh_from
+stores the host from which they made the change, and oh_on stores the time
+the change was made.
+
+=head2 Duo Backend Data
+
+Duo integration objects store some additional metadata about the
+integration to aid in synchronization with Duo.
+
+ create table duo
+ (du_name varchar(255)
+ not null references objects(ob_name),
+ du_key varchar(255) not null);
+ create index du_key on duo (du_key);
+
+du_key holds the Duo integration key, which is the unique name of the
+integration within Duo. Additional data may be added later to represent
+the other possible settings within Duo.
+
+=head2 Keytab Backend Data
+
+The keytab backend has stub support for synchronizing keys with an
+external system, although no external systems are currently supported.
+The permitted external systems are listed in a normalization table:
+
+ create table sync_targets
+ (st_name varchar(255) primary key);
+
+and then the synchronization targets for a given keytab are stored in this
+table:
+
+ create table keytab_sync
+ (ks_name varchar(255)
+ not null references objects(ob_name),
+ ks_target varchar(255)
+ not null references sync_targets(st_name),
+ primary key (ks_name, ks_target));
+ create index ks_name on keytab_sync (ks_name);
+
+The keytab backend supports restricting the allowable enctypes for a given
+keytab. The permitted enctypes are listed in a normalization table:
+
+ create table enctypes
+ (en_name varchar(255) primary key);
+
+and then the restrictions for a given keytab are stored in this table:
+
+ create table keytab_enctypes
+ (ke_name varchar(255)
+ not null references objects(ob_name),
+ ke_enctype varchar(255)
+ not null references enctypes(en_name),
+ primary key (ke_name, ke_enctype));
+ create index ke_name on keytab_enctypes (ke_name);
+
+To use this functionality, you will need to populate the enctypes table
+with the enctypes that a keytab may be restricted to. Currently, there is
+no automated mechanism to do this.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item connect()
+
+Opens a new database connection and returns the database object. On any
+failure, throws an exception. Unlike the DBI method, connect() takes no
+arguments; all database connection information is derived from the wallet
+configuration.
+
+=back
+
+=head1 SEE ALSO
+
+wallet-backend(8), Wallet::Config(3)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/Schema/Result/Acl.pm b/perl/lib/Wallet/Schema/Result/Acl.pm
new file mode 100644
index 0000000..226738a
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/Acl.pm
@@ -0,0 +1,110 @@
+# Wallet schema for an ACL.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::Acl;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=for stopwords
+ACL
+
+=head1 NAME
+
+Wallet::Schema::Result::Acl - Wallet schema for an ACL
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("acls");
+
+=head1 ACCESSORS
+
+=head2 ac_id
+
+ data_type: 'integer'
+ is_auto_increment: 1
+ is_nullable: 0
+
+=head2 ac_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=cut
+
+__PACKAGE__->add_columns(
+ "ac_id",
+ { data_type => "integer", is_auto_increment => 1, is_nullable => 0 },
+ "ac_name",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+);
+__PACKAGE__->set_primary_key("ac_id");
+__PACKAGE__->add_unique_constraint("ac_name", ["ac_name"]);
+
+__PACKAGE__->has_one(
+ 'acl_entries',
+ 'Wallet::Schema::Result::AclEntry',
+ { 'foreign.ae_id' => 'self.ac_id' },
+ { cascade_copy => 0, cascade_delete => 0 },
+ );
+__PACKAGE__->has_many(
+ 'acl_history',
+ 'Wallet::Schema::Result::AclHistory',
+ { 'foreign.ah_id' => 'self.ac_id' },
+ { cascade_copy => 0, cascade_delete => 0 },
+ );
+
+# References for all of the various potential ACLs in owners.
+__PACKAGE__->has_many(
+ 'acls_owner',
+ 'Wallet::Schema::Result::Object',
+ { 'foreign.ob_owner' => 'self.ac_id' },
+ );
+__PACKAGE__->has_many(
+ 'acls_get',
+ 'Wallet::Schema::Result::Object',
+ { 'foreign.ob_acl_get' => 'self.ac_id' },
+ );
+__PACKAGE__->has_many(
+ 'acls_store',
+ 'Wallet::Schema::Result::Object',
+ { 'foreign.ob_acl_store' => 'self.ac_id' },
+ );
+__PACKAGE__->has_many(
+ 'acls_show',
+ 'Wallet::Schema::Result::Object',
+ { 'foreign.ob_acl_show' => 'self.ac_id' },
+ );
+__PACKAGE__->has_many(
+ 'acls_destroy',
+ 'Wallet::Schema::Result::Object',
+ { 'foreign.ob_acl_destroy' => 'self.ac_id' },
+ );
+__PACKAGE__->has_many(
+ 'acls_flags',
+ 'Wallet::Schema::Result::Object',
+ { 'foreign.ob_acl_flags' => 'self.ac_id' },
+ );
+
+# Override the insert method so that we can automatically create history
+# items.
+#sub insert {
+# my ($self, @args) = @_;
+# my $ret = $self->next::method (@args);
+# print "ID: ".$self->ac_id."\n";
+# use Data::Dumper; print Dumper (@args);
+
+# return $self;
+#}
+
+1;
diff --git a/perl/lib/Wallet/Schema/Result/AclEntry.pm b/perl/lib/Wallet/Schema/Result/AclEntry.pm
new file mode 100644
index 0000000..a33a98c
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/AclEntry.pm
@@ -0,0 +1,74 @@
+# Wallet schema for an entry in an ACL.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::AclEntry;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=for stopwords
+ACL
+
+=head1 NAME
+
+Wallet::Schema::Result::AclEntry - Wallet schema for an entry in an ACL
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("acl_entries");
+
+=head1 ACCESSORS
+
+=head2 ae_id
+
+ data_type: 'integer'
+ is_nullable: 0
+
+=head2 ae_scheme
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 32
+
+=head2 ae_identifier
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=cut
+
+__PACKAGE__->add_columns(
+ "ae_id",
+ { data_type => "integer", is_nullable => 0 },
+ "ae_scheme",
+ { data_type => "varchar", is_nullable => 0, size => 32 },
+ "ae_identifier",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+);
+__PACKAGE__->set_primary_key("ae_id", "ae_scheme", "ae_identifier");
+
+__PACKAGE__->belongs_to(
+ 'acls',
+ 'Wallet::Schema::Result::Acl',
+ { 'foreign.ac_id' => 'self.ae_id' },
+ { is_deferrable => 1, on_delete => 'CASCADE',
+ on_update => 'CASCADE' },
+ );
+
+__PACKAGE__->has_one(
+ 'acl_scheme',
+ 'Wallet::Schema::Result::AclScheme',
+ { 'foreign.as_name' => 'self.ae_scheme' },
+ { cascade_delete => 0 },
+ );
+1;
diff --git a/perl/lib/Wallet/Schema/Result/AclHistory.pm b/perl/lib/Wallet/Schema/Result/AclHistory.pm
new file mode 100644
index 0000000..11593b7
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/AclHistory.pm
@@ -0,0 +1,113 @@
+# Wallet schema for ACL history.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013, 2014
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::AclHistory;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->load_components("InflateColumn::DateTime");
+
+=for stopwords
+ACL
+
+=head1 NAME
+
+Wallet::Schema::Result::AclHistory - Wallet schema for ACL history
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("acl_history");
+
+=head1 ACCESSORS
+
+=head2 ah_id
+
+ data_type: 'integer'
+ is_auto_increment: 1
+ is_nullable: 0
+
+=head2 ah_acl
+
+ data_type: 'integer'
+ is_nullable: 0
+
+=head2 ah_action
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 16
+
+=head2 ah_scheme
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 32
+
+=head2 ah_identifier
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 255
+
+=head2 ah_by
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 ah_from
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 ah_on
+
+ data_type: 'datetime'
+ datetime_undef_if_invalid: 1
+ is_nullable: 0
+
+=cut
+
+__PACKAGE__->add_columns(
+ "ah_id",
+ { data_type => "integer", is_auto_increment => 1, is_nullable => 0 },
+ "ah_acl",
+ { data_type => "integer", is_nullable => 0 },
+ "ah_action",
+ { data_type => "varchar", is_nullable => 0, size => 16 },
+ "ah_scheme",
+ { data_type => "varchar", is_nullable => 1, size => 32 },
+ "ah_identifier",
+ { data_type => "varchar", is_nullable => 1, size => 255 },
+ "ah_by",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "ah_from",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "ah_on",
+ {
+ data_type => "datetime",
+ datetime_undef_if_invalid => 1,
+ is_nullable => 0,
+ },
+);
+__PACKAGE__->set_primary_key("ah_id");
+
+# Add an index on the ACL.
+sub sqlt_deploy_hook {
+ my ($self, $sqlt_table) = @_;
+ my $name = 'acl_history_idx_ah_acl';
+ $sqlt_table->add_index (name => $name, fields => [qw(ah_acl)]);
+}
+
+1;
diff --git a/perl/lib/Wallet/Schema/Result/AclScheme.pm b/perl/lib/Wallet/Schema/Result/AclScheme.pm
new file mode 100644
index 0000000..91a58b2
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/AclScheme.pm
@@ -0,0 +1,84 @@
+# Wallet schema for ACL scheme.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::AclScheme;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+__PACKAGE__->load_components (qw//);
+
+=for stopwords
+ACL verifier APIs
+
+=head1 NAME
+
+Wallet::Schema::Result::AclScheme - Wallet schema for ACL scheme
+
+=head1 DESCRIPTION
+
+This is a normalization table used to constrain the values in other
+tables. It contains the types of ACL schemes that Wallet will
+recognize, and the modules that govern each of those schemes.
+
+By default it contains the following entries:
+
+ insert into acl_schemes (as_name, as_class)
+ values ('krb5', 'Wallet::ACL::Krb5');
+ insert into acl_schemes (as_name, as_class)
+ values ('krb5-regex', 'Wallet::ACL::Krb5::Regex');
+ insert into acl_schemes (as_name, as_class)
+ values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute');
+ insert into acl_schemes (as_name, as_class)
+ values ('netdb', 'Wallet::ACL::NetDB');
+ insert into acl_schemes (as_name, as_class)
+ values ('netdb-root', 'Wallet::ACL::NetDB::Root');
+
+If you have extended the wallet to support additional ACL schemes, you
+will want to add additional rows to this table mapping those schemes
+to Perl classes that implement the ACL verifier APIs.
+
+=cut
+
+__PACKAGE__->table("acl_schemes");
+
+=head1 ACCESSORS
+
+=head2 as_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 32
+
+=head2 as_class
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 64
+
+=cut
+
+__PACKAGE__->add_columns(
+ "as_name",
+ { data_type => "varchar", is_nullable => 0, size => 32 },
+ "as_class",
+ { data_type => "varchar", is_nullable => 1, size => 64 },
+);
+__PACKAGE__->set_primary_key("as_name");
+
+#__PACKAGE__->resultset->populate ([
+# [ qw/as_name as_class/ ],
+# [ 'krb5', 'Wallet::ACL::Krb5' ],
+# [ 'krb5-regex', 'Wallet::ACL::Krb5::Regex' ],
+# [ 'ldap-attr', 'Wallet::ACL::LDAP::Attribute' ],
+# [ 'netdb', 'Wallet::ACL::NetDB' ],
+# [ 'netdb-root', 'Wallet::ACL::NetDB::Root' ],
+# ]);
+
+1;
diff --git a/perl/lib/Wallet/Schema/Result/Duo.pm b/perl/lib/Wallet/Schema/Result/Duo.pm
new file mode 100644
index 0000000..80a71dc
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/Duo.pm
@@ -0,0 +1,53 @@
+# Wallet schema for Duo metadata.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2014
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::Duo;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=for stopwords
+keytab enctype
+
+=head1 NAME
+
+Wallet::Schema::Result::Duo - Wallet schema for Duo metadata
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("duo");
+
+=head1 ACCESSORS
+
+=head2 du_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 du_key
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=cut
+
+__PACKAGE__->add_columns(
+ "du_name",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "du_key",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+);
+__PACKAGE__->set_primary_key("du_name");
+
+1;
diff --git a/perl/lib/Wallet/Schema/Result/Enctype.pm b/perl/lib/Wallet/Schema/Result/Enctype.pm
new file mode 100644
index 0000000..5733669
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/Enctype.pm
@@ -0,0 +1,45 @@
+# Wallet schema for Kerberos encryption type.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::Enctype;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=for stopwords
+Kerberos
+
+=head1 NAME
+
+Wallet::Schema::Result::Enctype - Wallet schema for Kerberos encryption type
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("enctypes");
+
+=head1 ACCESSORS
+
+=head2 en_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=cut
+
+__PACKAGE__->add_columns(
+ "en_name",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+);
+__PACKAGE__->set_primary_key("en_name");
+
+1;
diff --git a/perl/lib/Wallet/Schema/Result/Flag.pm b/perl/lib/Wallet/Schema/Result/Flag.pm
new file mode 100644
index 0000000..e223ff8
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/Flag.pm
@@ -0,0 +1,62 @@
+# Wallet schema for object flags.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::Flag;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=head1 NAME
+
+Wallet::Schema::Result::Flag - Wallet schema for object flags
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("flags");
+
+=head1 ACCESSORS
+
+=head2 fl_type
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 16
+
+=head2 fl_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 fl_flag
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 32
+
+=cut
+
+__PACKAGE__->add_columns(
+ "fl_type" =>
+ { data_type => "varchar", is_nullable => 0, size => 16 },
+ "fl_name" =>
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "fl_flag" => {
+ data_type => 'enum',
+ is_enum => 1,
+ extra => { list => [qw/locked unchanging/] },
+ },
+);
+__PACKAGE__->set_primary_key("fl_type", "fl_name", "fl_flag");
+
+
+1;
diff --git a/perl/lib/Wallet/Schema/Result/KeytabEnctype.pm b/perl/lib/Wallet/Schema/Result/KeytabEnctype.pm
new file mode 100644
index 0000000..daea724
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/KeytabEnctype.pm
@@ -0,0 +1,53 @@
+# Wallet schema for keytab enctype.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::KeytabEnctype;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=for stopwords
+keytab enctype
+
+=head1 NAME
+
+Wallet::Schema::Result::KeytabEnctype - Wallet schema for keytab enctype
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("keytab_enctypes");
+
+=head1 ACCESSORS
+
+=head2 ke_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 ke_enctype
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=cut
+
+__PACKAGE__->add_columns(
+ "ke_name",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "ke_enctype",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+);
+__PACKAGE__->set_primary_key("ke_name", "ke_enctype");
+
+1;
diff --git a/perl/lib/Wallet/Schema/Result/KeytabSync.pm b/perl/lib/Wallet/Schema/Result/KeytabSync.pm
new file mode 100644
index 0000000..ca84277
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/KeytabSync.pm
@@ -0,0 +1,53 @@
+# Wallet schema for keytab synchronization.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::KeytabSync;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=for stopwords
+keytab
+
+=head1 NAME
+
+Wallet::Schema::Result::KeytabSync - Wallet schema for keytab synchronization
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("keytab_sync");
+
+=head1 ACCESSORS
+
+=head2 ks_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 ks_target
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=cut
+
+__PACKAGE__->add_columns(
+ "ks_name",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "ks_target",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+);
+__PACKAGE__->set_primary_key("ks_name", "ks_target");
+
+1;
diff --git a/perl/lib/Wallet/Schema/Result/Object.pm b/perl/lib/Wallet/Schema/Result/Object.pm
new file mode 100644
index 0000000..fd64e1b
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/Object.pm
@@ -0,0 +1,266 @@
+# Wallet schema for an object.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::Object;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->load_components("InflateColumn::DateTime");
+
+=head1 NAME
+
+Wallet::Schema::Result::Object - Wallet schema for an object
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("objects");
+
+=head1 ACCESSORS
+
+=head2 ob_type
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 16
+
+=head2 ob_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 ob_owner
+
+ data_type: 'integer'
+ is_nullable: 1
+
+=head2 ob_acl_get
+
+ data_type: 'integer'
+ is_nullable: 1
+
+=head2 ob_acl_store
+
+ data_type: 'integer'
+ is_nullable: 1
+
+=head2 ob_acl_show
+
+ data_type: 'integer'
+ is_nullable: 1
+
+=head2 ob_acl_destroy
+
+ data_type: 'integer'
+ is_nullable: 1
+
+=head2 ob_acl_flags
+
+ data_type: 'integer'
+ is_nullable: 1
+
+=head2 ob_expires
+
+ data_type: 'datetime'
+ datetime_undef_if_invalid: 1
+ is_nullable: 1
+
+=head2 ob_created_by
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 ob_created_from
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 ob_created_on
+
+ data_type: 'datetime'
+ datetime_undef_if_invalid: 1
+ is_nullable: 0
+
+=head2 ob_stored_by
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 255
+
+=head2 ob_stored_from
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 255
+
+=head2 ob_stored_on
+
+ data_type: 'datetime'
+ datetime_undef_if_invalid: 1
+ is_nullable: 1
+
+=head2 ob_downloaded_by
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 255
+
+=head2 ob_downloaded_from
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 255
+
+=head2 ob_downloaded_on
+
+ data_type: 'datetime'
+ datetime_undef_if_invalid: 1
+ is_nullable: 1
+
+=head2 ob_comment
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 255
+
+=cut
+
+__PACKAGE__->add_columns(
+ "ob_type",
+ { data_type => "varchar", is_nullable => 0, size => 16 },
+ "ob_name",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "ob_owner",
+ { data_type => "integer", is_nullable => 1 },
+ "ob_acl_get",
+ { data_type => "integer", is_nullable => 1 },
+ "ob_acl_store",
+ { data_type => "integer", is_nullable => 1 },
+ "ob_acl_show",
+ { data_type => "integer", is_nullable => 1 },
+ "ob_acl_destroy",
+ { data_type => "integer", is_nullable => 1 },
+ "ob_acl_flags",
+ { data_type => "integer", is_nullable => 1 },
+ "ob_expires",
+ {
+ data_type => "datetime",
+ datetime_undef_if_invalid => 1,
+ is_nullable => 1,
+ },
+ "ob_created_by",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "ob_created_from",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "ob_created_on",
+ {
+ data_type => "datetime",
+ datetime_undef_if_invalid => 1,
+ is_nullable => 0,
+ },
+ "ob_stored_by",
+ { data_type => "varchar", is_nullable => 1, size => 255 },
+ "ob_stored_from",
+ { data_type => "varchar", is_nullable => 1, size => 255 },
+ "ob_stored_on",
+ {
+ data_type => "datetime",
+ datetime_undef_if_invalid => 1,
+ is_nullable => 1,
+ },
+ "ob_downloaded_by",
+ { data_type => "varchar", is_nullable => 1, size => 255 },
+ "ob_downloaded_from",
+ { data_type => "varchar", is_nullable => 1, size => 255 },
+ "ob_downloaded_on",
+ {
+ data_type => "datetime",
+ datetime_undef_if_invalid => 1,
+ is_nullable => 1,
+ },
+ "ob_comment",
+ { data_type => "varchar", is_nullable => 1, size => 255 },
+);
+__PACKAGE__->set_primary_key("ob_name", "ob_type");
+
+__PACKAGE__->has_one(
+ 'types',
+ 'Wallet::Schema::Result::Type',
+ { 'foreign.ty_name' => 'self.ob_type' },
+ );
+
+__PACKAGE__->has_many(
+ 'flags',
+ 'Wallet::Schema::Result::Flag',
+ { 'foreign.fl_type' => 'self.ob_type',
+ 'foreign.fl_name' => 'self.ob_name' },
+ { cascade_copy => 0, cascade_delete => 0 },
+ );
+
+__PACKAGE__->has_many(
+ 'object_history',
+ 'Wallet::Schema::Result::ObjectHistory',
+ { 'foreign.oh_type' => 'self.ob_type',
+ 'foreign.oh_name' => 'self.ob_name' },
+ { cascade_copy => 0, cascade_delete => 0 },
+ );
+
+__PACKAGE__->has_many(
+ 'keytab_enctypes',
+ 'Wallet::Schema::Result::KeytabEnctype',
+ { 'foreign.ke_name' => 'self.ob_name' },
+ { cascade_copy => 0, cascade_delete => 0 },
+ );
+
+__PACKAGE__->has_many(
+ 'keytab_sync',
+ 'Wallet::Schema::Result::KeytabSync',
+ { 'foreign.ks_name' => 'self.ob_name' },
+ { cascade_copy => 0, cascade_delete => 0 },
+ );
+
+# References for all of the various potential ACLs.
+__PACKAGE__->belongs_to(
+ 'acls_owner',
+ 'Wallet::Schema::Result::Acl',
+ { 'foreign.ac_id' => 'self.ob_owner' },
+ );
+__PACKAGE__->belongs_to(
+ 'acls_get',
+ 'Wallet::Schema::Result::Acl',
+ { 'foreign.ac_id' => 'self.ob_acl_get' },
+ );
+__PACKAGE__->belongs_to(
+ 'acls_store',
+ 'Wallet::Schema::Result::Acl',
+ { 'foreign.ac_id' => 'self.ob_acl_store' },
+ );
+__PACKAGE__->belongs_to(
+ 'acls_show',
+ 'Wallet::Schema::Result::Acl',
+ { 'foreign.ac_id' => 'self.ob_acl_show' },
+ );
+__PACKAGE__->belongs_to(
+ 'acls_destroy',
+ 'Wallet::Schema::Result::Acl',
+ { 'foreign.ac_id' => 'self.ob_acl_destroy' },
+ );
+__PACKAGE__->belongs_to(
+ 'acls_flags',
+ 'Wallet::Schema::Result::Acl',
+ { 'foreign.ac_id' => 'self.ob_acl_flags' },
+ );
+
+1;
diff --git a/perl/lib/Wallet/Schema/Result/ObjectHistory.pm b/perl/lib/Wallet/Schema/Result/ObjectHistory.pm
new file mode 100644
index 0000000..5e9c8bd
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/ObjectHistory.pm
@@ -0,0 +1,135 @@
+# Wallet schema for object history.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013, 2014
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::ObjectHistory;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->load_components("InflateColumn::DateTime");
+
+=head1 NAME
+
+Wallet::Schema::Result::ObjectHistory - Wallet schema for object history
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("object_history");
+
+=head1 ACCESSORS
+
+=head2 oh_id
+
+ data_type: 'integer'
+ is_auto_increment: 1
+ is_nullable: 0
+
+=head2 oh_type
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 16
+
+=head2 oh_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 oh_action
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 16
+
+=head2 oh_field
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 16
+
+=head2 oh_type_field
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 255
+
+=head2 oh_old
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 255
+
+=head2 oh_new
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 255
+
+=head2 oh_by
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 oh_from
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=head2 oh_on
+
+ data_type: 'datetime'
+ datetime_undef_if_invalid: 1
+ is_nullable: 0
+
+=cut
+
+__PACKAGE__->add_columns(
+ "oh_id",
+ { data_type => "integer", is_auto_increment => 1, is_nullable => 0 },
+ "oh_type",
+ { data_type => "varchar", is_nullable => 0, size => 16 },
+ "oh_name",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "oh_action",
+ { data_type => "varchar", is_nullable => 0, size => 16 },
+ "oh_field",
+ { data_type => "varchar", is_nullable => 1, size => 16 },
+ "oh_type_field",
+ { data_type => "varchar", is_nullable => 1, size => 255 },
+ "oh_old",
+ { data_type => "varchar", is_nullable => 1, size => 255 },
+ "oh_new",
+ { data_type => "varchar", is_nullable => 1, size => 255 },
+ "oh_by",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "oh_from",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+ "oh_on",
+ {
+ data_type => "datetime",
+ datetime_undef_if_invalid => 1,
+ is_nullable => 0,
+ },
+);
+__PACKAGE__->set_primary_key("oh_id");
+
+# Add an index on object type and object name.
+sub sqlt_deploy_hook {
+ my ($self, $sqlt_table) = @_;
+ my $name = 'object_history_idx_oh_type_oh_name';
+ $sqlt_table->add_index (name => $name, fields => [qw(oh_type oh_name)]);
+}
+
+1;
diff --git a/perl/lib/Wallet/Schema/Result/SyncTarget.pm b/perl/lib/Wallet/Schema/Result/SyncTarget.pm
new file mode 100644
index 0000000..4300a54
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/SyncTarget.pm
@@ -0,0 +1,48 @@
+# Wallet schema for synchronization targets.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::SyncTarget;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=head1 NAME
+
+Wallet::Schema::Result::SyncTarget - Wallet schema for synchronization targets
+
+=head1 DESCRIPTION
+
+=cut
+
+__PACKAGE__->table("sync_targets");
+
+=head1 ACCESSORS
+
+=head2 st_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 255
+
+=cut
+
+__PACKAGE__->add_columns(
+ "st_name",
+ { data_type => "varchar", is_nullable => 0, size => 255 },
+);
+__PACKAGE__->set_primary_key("st_name");
+
+#__PACKAGE__->has_many(
+# 'keytab_sync',
+# 'Wallet::Schema::Result::KeytabSync',
+# { 'foreign.ks_target' => 'self.st_name' },
+# { cascade_copy => 0, cascade_delete => 0 },
+# );
+1;
diff --git a/perl/lib/Wallet/Schema/Result/Type.pm b/perl/lib/Wallet/Schema/Result/Type.pm
new file mode 100644
index 0000000..748a8a8
--- /dev/null
+++ b/perl/lib/Wallet/Schema/Result/Type.pm
@@ -0,0 +1,75 @@
+# Wallet schema for object types.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2012, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+package Wallet::Schema::Result::Type;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=for stopwords
+APIs
+
+=head1 NAME
+
+Wallet::Schema::Result::Type - Wallet schema for object types
+
+=head1 DESCRIPTION
+
+This is a normalization table used to constrain the values in other
+tables. It contains the types of wallet objects that are considered
+valid, and the modules that govern each.
+
+By default it contains the following entries:
+
+ insert into types (ty_name, ty_class)
+ values ('file', 'Wallet::Object::File');
+ insert into types (ty_name, ty_class)
+ values ('keytab', 'Wallet::Object::Keytab');
+
+If you have extended the wallet to support additional object types ,
+you will want to add additional rows to this table mapping those types
+to Perl classes that implement the object APIs.
+
+=cut
+
+__PACKAGE__->table("types");
+
+=head1 ACCESSORS
+
+=head2 ty_name
+
+ data_type: 'varchar'
+ is_nullable: 0
+ size: 16
+
+=head2 ty_class
+
+ data_type: 'varchar'
+ is_nullable: 1
+ size: 64
+
+=cut
+
+__PACKAGE__->add_columns(
+ "ty_name",
+ { data_type => "varchar", is_nullable => 0, size => 16 },
+ "ty_class",
+ { data_type => "varchar", is_nullable => 1, size => 64 },
+);
+__PACKAGE__->set_primary_key("ty_name");
+
+#__PACKAGE__->has_many(
+# 'objects',
+# 'Wallet::Schema::Result::Object',
+# { 'foreign.ob_type' => 'self.ty_name' },
+# { cascade_copy => 0, cascade_delete => 0 },
+# );
+
+1;
diff --git a/perl/lib/Wallet/Server.pm b/perl/lib/Wallet/Server.pm
new file mode 100644
index 0000000..3266928
--- /dev/null
+++ b/perl/lib/Wallet/Server.pm
@@ -0,0 +1,1095 @@
+# Wallet::Server -- Wallet system server implementation.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2008, 2010, 2011, 2013
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Server;
+require 5.006;
+
+use strict;
+use vars qw(%MAPPING $VERSION);
+
+use Wallet::ACL;
+use Wallet::Config;
+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.11';
+
+##############################################################################
+# Utility methods
+##############################################################################
+
+# Create a new wallet server object. A new server should be created for each
+# user who is making changes to the wallet. Takes the principal and host who
+# are sending wallet requests. Opens a connection to the database that will
+# be used for all of the wallet metadata based on the wallet configuration
+# information. We also instantiate the administrative ACL, which we'll use
+# for various things. Throw an exception if anything goes wrong.
+sub new {
+ my ($class, $user, $host) = @_;
+ my $schema = Wallet::Schema->connect;
+ my $acl = Wallet::ACL->new ('ADMIN', $schema);
+ my $self = {
+ schema => $schema,
+ user => $user,
+ host => $host,
+ admin => $acl,
+ };
+ bless ($self, $class);
+ return $self;
+}
+
+# Returns the database handle (used mostly for testing).
+sub dbh {
+ my ($self) = @_;
+ return $self->{schema}->storage->dbh;
+}
+
+# Returns the DBIx::Class-based database schema object.
+sub schema {
+ my ($self) = @_;
+ return $self->{schema};
+}
+
+# Set or return the error stashed in the object.
+sub error {
+ my ($self, @error) = @_;
+ if (@error) {
+ my $error = join ('', @error);
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ $self->{error} = $error;
+ }
+ return $self->{error};
+}
+
+# Disconnect the database handle on object destruction to avoid warnings.
+sub DESTROY {
+ my ($self) = @_;
+
+ if ($self->{schema}) {
+ $self->{schema}->storage->dbh->disconnect;
+ }
+}
+
+##############################################################################
+# Object methods
+##############################################################################
+
+# Given an object type, return the mapping to a class by querying the
+# database, or undef if no mapping exists. Also load the relevant module.
+sub type_mapping {
+ my ($self, $type) = @_;
+ my $class;
+ eval {
+ my $guard = $self->{schema}->txn_scope_guard;
+ my %search = (ty_name => $type);
+ my $type_rec = $self->{schema}->resultset('Type')->find (\%search);
+ $class = $type_rec->ty_class;
+ $guard->commit;
+ };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ if (defined $class) {
+ eval "require $class";
+ if ($@) {
+ $self->error ($@);
+ 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.
+# Returns true if so, false if not, setting the internal error as appropriate.
+#
+# This leaves those new ACLs in the database, which may not be the best
+# behavior, but it's the simplest given the current Wallet::ACL API. This
+# should probably be revisited later.
+sub create_check {
+ my ($self, $type, $name) = @_;
+ my $user = $self->{user};
+ my $host = $self->{host};
+ my $schema = $self->{schema};
+ unless (defined (&Wallet::Config::default_owner)) {
+ $self->error ("$user not authorized to create ${type}:${name}");
+ return;
+ }
+ my ($aname, @acl) = Wallet::Config::default_owner ($type, $name);
+ unless (defined $aname) {
+ $self->error ("$user not authorized to create ${type}:${name}");
+ return;
+ }
+ my $acl = eval { Wallet::ACL->new ($aname, $schema) };
+ if ($@) {
+ $acl = eval { Wallet::ACL->create ($aname, $schema, $user, $host) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ for my $entry (@acl) {
+ unless ($acl->add ($entry->[0], $entry->[1], $user, $host)) {
+ $self->error ($acl->error);
+ return;
+ }
+ }
+ } else {
+ my @entries = $acl->list;
+ if (not @entries and $acl->error) {
+ $self->error ($acl->error);
+ return;
+ }
+ @entries = sort { $$a[0] cmp $$b[0] && $$a[1] cmp $$b[1] } @entries;
+ @acl = sort { $$a[0] cmp $$b[0] && $$a[1] cmp $$b[1] } @acl;
+ my $okay = 1;
+ if (@entries != @acl) {
+ $okay = 0;
+ } else {
+ for my $i (0 .. $#entries) {
+ $okay = 0 unless ($entries[$i][0] eq $acl[$i][0]);
+ $okay = 0 unless ($entries[$i][1] eq $acl[$i][1]);
+ }
+ }
+ unless ($okay) {
+ $self->error ("ACL $aname exists and doesn't match default");
+ return;
+ }
+ }
+ if ($acl->check ($user)) {
+ return $aname;
+ } else {
+ $self->error ("$user not authorized to create ${type}:${name}");
+ return;
+ }
+}
+
+# Create an object and returns it. This function is called by both create and
+# autocreate and assumes that permissions and names have already been checked.
+# On error, returns undef and sets the internal error.
+sub create_object {
+ my ($self, $type, $name) = @_;
+ my $class = $self->type_mapping ($type);
+ unless ($class) {
+ $self->error ("unknown object type $type");
+ return;
+ }
+ my $schema = $self->{schema};
+ my $user = $self->{user};
+ my $host = $self->{host};
+ my $object = eval { $class->create ($type, $name, $schema, $user, $host) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ return $object;
+}
+
+# Create a new object and returns that object. This method can only be called
+# by wallet administrators. autocreate should be used by regular users who
+# may benefit from default ACLs. On error, returns undef and sets the
+# internal error.
+sub create {
+ my ($self, $type, $name) = @_;
+ unless ($self->{admin}->check ($self->{user})) {
+ my $id = $type . ':' . $name;
+ $self->error ("$self->{user} not authorized to create $id");
+ return;
+ }
+ if (defined (&Wallet::Config::verify_name)) {
+ my $error = Wallet::Config::verify_name ($type, $name, $self->{user});
+ if ($error) {
+ $self->error ("${type}:${name} rejected: $error");
+ return;
+ }
+ }
+ return unless $self->create_object ($type, $name);
+ return 1;
+}
+
+# Attempt to auto-create an object based on default ACLs. This method is
+# called by the wallet client when trying to get an object that doesn't
+# already exist. On error, returns undef and sets the internal error.
+sub autocreate {
+ my ($self, $type, $name) = @_;
+ if (defined (&Wallet::Config::verify_name)) {
+ my $error = Wallet::Config::verify_name ($type, $name, $self->{user});
+ if ($error) {
+ $self->error ("${type}:${name} rejected: $error");
+ return;
+ }
+ }
+ my $acl = $self->create_check ($type, $name);
+ return unless $acl;
+ my $object = $self->create_object ($type, $name);
+ return unless $object;
+ unless ($object->owner ($acl, $self->{user}, $self->{host})) {
+ $self->error ($object->error);
+ return;
+ }
+ return 1;
+}
+
+# Given the name and type of an object, returns a Perl object representing it
+# or returns undef and sets the internal error.
+sub retrieve {
+ my ($self, $type, $name) = @_;
+ my $class = $self->type_mapping ($type);
+ unless ($class) {
+ $self->error ("unknown object type $type");
+ return;
+ }
+ my $object = eval { $class->new ($type, $name, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ } else {
+ return $object;
+ }
+}
+
+# Sets the internal error variable to the correct message for permission
+# denied on an object.
+sub object_error {
+ my ($self, $object, $action) = @_;
+ my $user = $self->{user};
+ my $id = $object->type . ':' . $object->name;
+ if ($action eq 'getattr') {
+ $action = "get attributes for";
+ } elsif ($action eq 'setattr') {
+ $action = "set attributes for";
+ } elsif ($action !~ /^(create|get|store|show|destroy)\z/) {
+ $action = "set $action for";
+ }
+ $self->error ("$self->{user} not authorized to $action $id");
+}
+
+# Given an object and an action, checks if the current user has access to
+# perform that object. If so, returns true. If not, returns undef and sets
+# the internal error message. Note that we do not allow any special access to
+# admins for get and store; if they want to do that with objects, they need to
+# set the ACL accordingly.
+sub acl_verify {
+ my ($self, $object, $action) = @_;
+ my %actions = map { $_ => 1 }
+ qw(get store show destroy flags setattr getattr comment);
+ unless ($actions{$action}) {
+ $self->error ("unknown action $action");
+ return;
+ }
+ if ($action ne 'get' and $action ne 'store') {
+ return 1 if $self->{admin}->check ($self->{user});
+ }
+ my $id;
+ if ($action eq 'getattr') {
+ $id = $object->acl ('show');
+ } elsif ($action eq 'setattr') {
+ $id = $object->acl ('store');
+ } elsif ($action ne 'comment') {
+ $id = $object->acl ($action);
+ }
+ if (! defined ($id) and $action ne 'flags') {
+ $id = $object->owner;
+ }
+ unless (defined $id) {
+ $self->object_error ($object, $action);
+ return;
+ }
+ my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ my $status = $acl->check ($self->{user});
+ if ($status == 1) {
+ return 1;
+ } elsif (not defined $status) {
+ $self->error ($acl->error);
+ return;
+ } else {
+ $self->object_error ($object, $action);
+ return;
+ }
+}
+
+# Retrieves or sets an ACL on an object.
+sub acl {
+ my ($self, $type, $name, $acl, $id) = @_;
+ undef $self->{error};
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->object_error ($object, 'ACL');
+ return;
+ }
+ my $result;
+ if (defined $id) {
+ $result = $object->acl ($acl, $id, $self->{user}, $self->{host});
+ } else {
+ $result = $object->acl ($acl);
+ }
+ if (not defined ($result) and $object->error) {
+ $self->error ($object->error);
+ }
+ return $result;
+}
+
+# Retrieves or sets an attribute on an object.
+sub attr {
+ my ($self, $type, $name, $attr, @values) = @_;
+ undef $self->{error};
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ my $user = $self->{user};
+ my $host = $self->{host};
+ if (@values) {
+ return unless $self->acl_verify ($object, 'setattr');
+ if (@values == 1 and $values[0] eq '') {
+ @values = ();
+ }
+ my $result = $object->attr ($attr, [ @values ], $user, $host);
+ $self->error ($object->error) unless $result;
+ return $result;
+ } else {
+ return unless $self->acl_verify ($object, 'getattr');
+ my @result = $object->attr ($attr);
+ if (not @result and $object->error) {
+ $self->error ($object->error);
+ return;
+ } else {
+ return @result;
+ }
+ }
+}
+
+# Retrieves or sets the comment of an object.
+sub comment {
+ my ($self, $type, $name, $comment) = @_;
+ undef $self->{error};
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ my $result;
+ if (defined $comment) {
+ return unless $self->acl_verify ($object, 'comment');
+ $result = $object->comment ($comment, $self->{user}, $self->{host});
+ } else {
+ return unless $self->acl_verify ($object, 'show');
+ $result = $object->comment;
+ }
+ if (not defined ($result) and $object->error) {
+ $self->error ($object->error);
+ }
+ return $result;
+}
+
+# Retrieves or sets the expiration of an object.
+sub expires {
+ my ($self, $type, $name, $expires) = @_;
+ undef $self->{error};
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->object_error ($object, 'expires');
+ return;
+ }
+ my $result;
+ if (defined $expires) {
+ $result = $object->expires ($expires, $self->{user}, $self->{host});
+ } else {
+ $result = $object->expires;
+ }
+ if (not defined ($result) and $object->error) {
+ $self->error ($object->error);
+ }
+ return $result;
+}
+
+# Retrieves or sets the owner of an object.
+sub owner {
+ my ($self, $type, $name, $owner) = @_;
+ undef $self->{error};
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->object_error ($object, 'owner');
+ return;
+ }
+ my $result;
+ if (defined $owner) {
+ $result = $object->owner ($owner, $self->{user}, $self->{host});
+ } else {
+ $result = $object->owner;
+ }
+ if (not defined ($result) and $object->error) {
+ $self->error ($object->error);
+ }
+ return $result;
+}
+
+# Checks for the existence of an object. Returns 1 if it does, 0 if it
+# doesn't, and undef if there was an error in checking the existence of the
+# object.
+sub check {
+ my ($self, $type, $name) = @_;
+ my $object = $self->retrieve ($type, $name);
+ if (not defined $object) {
+ if ($self->error =~ /^cannot find/) {
+ return 0;
+ } else {
+ return;
+ }
+ }
+ return 1;
+}
+
+# Retrieve the information associated with an object, or returns undef and
+# sets the internal error if the retrieval fails or if the user isn't
+# authorized. If the object doesn't exist, attempts dynamic creation of the
+# object using the default ACL mappings (if any).
+sub get {
+ my ($self, $type, $name) = @_;
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ return unless $self->acl_verify ($object, 'get');
+ my $result = $object->get ($self->{user}, $self->{host});
+ $self->error ($object->error) unless defined $result;
+ return $result;
+}
+
+# Store new data in an object, or returns undef and sets the internal error if
+# the object can't be found or if the user isn't authorized. Also don't
+# permit storing undef, although storing the empty string is fine. If the
+# object doesn't exist, attempts dynamic creation of the object using the
+# default ACL mappings (if any).
+sub store {
+ my ($self, $type, $name, $data) = @_;
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ return unless $self->acl_verify ($object, 'store');
+ if (not defined ($data)) {
+ $self->{error} = "no data supplied to store";
+ return;
+ }
+ my $result = $object->store ($data, $self->{user}, $self->{host});
+ $self->error ($object->error) unless defined $result;
+ return $result;
+}
+
+# Return a human-readable description of the object's metadata, or returns
+# undef and sets the internal error if the object can't be found or if the
+# user isn't authorized.
+sub show {
+ my ($self, $type, $name) = @_;
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ return unless $self->acl_verify ($object, 'show');
+ my $result = $object->show;
+ $self->error ($object->error) unless defined $result;
+ return $result;
+}
+
+# Return a human-readable description of the object history, or returns undef
+# and sets the internal error if the object can't be found or if the user
+# isn't authorized.
+sub history {
+ my ($self, $type, $name) = @_;
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ return unless $self->acl_verify ($object, 'show');
+ my $result = $object->history;
+ $self->error ($object->error) unless defined $result;
+ return $result;
+}
+
+# Destroys the object, or returns undef and sets the internal error if the
+# object can't be found or if the user isn't authorized.
+sub destroy {
+ my ($self, $type, $name) = @_;
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ return unless $self->acl_verify ($object, 'destroy');
+ my $result = $object->destroy ($self->{user}, $self->{host});
+ $self->error ($object->error) unless defined $result;
+ return $result;
+}
+
+##############################################################################
+# Object flag methods
+##############################################################################
+
+# Clear a flag on an object. Takes the object and the flag. Returns true on
+# success or undef and sets the internal error on failure.
+sub flag_clear {
+ my ($self, $type, $name, $flag) = @_;
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ return unless $self->acl_verify ($object, 'flags');
+ my $result = $object->flag_clear ($flag, $self->{user}, $self->{host});
+ $self->error ($object->error) unless defined $result;
+ return $result;
+}
+
+# Set a flag on an object. Takes the object and the flag. Returns true on
+# success or undef and sets the internal error on failure.
+sub flag_set {
+ my ($self, $type, $name, $flag) = @_;
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ return unless $self->acl_verify ($object, 'flags');
+ my $result = $object->flag_set ($flag, $self->{user}, $self->{host});
+ $self->error ($object->error) unless defined $result;
+ return $result;
+}
+
+##############################################################################
+# ACL methods
+##############################################################################
+
+# Checks for the existence of an ACL. Returns 1 if it does, 0 if it doesn't,
+# and undef if there was an error in checking the existence of the object.
+sub acl_check {
+ my ($self, $id) = @_;
+ my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) };
+ if ($@) {
+ if ($@ =~ /^ACL .* not found/) {
+ return 0;
+ } else {
+ $self->error ($@);
+ return;
+ }
+ }
+ return 1;
+}
+
+# Create a new empty ACL in the database. Returns true on success and undef
+# on failure, setting the internal error.
+sub acl_create {
+ my ($self, $name) = @_;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->error ("$self->{user} not authorized to create ACL");
+ return;
+ }
+ my $user = $self->{user};
+ my $host = $self->{host};
+ if (defined (&Wallet::Config::verify_acl_name)) {
+ my $error = Wallet::Config::verify_acl_name ($name, $user);
+ if ($error) {
+ $self->error ("$name rejected: $error");
+ return;
+ }
+ }
+ my $schema = $self->{schema};
+ my $acl = eval { Wallet::ACL->create ($name, $schema, $user, $host) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ } else {
+ return 1;
+ }
+}
+
+# Sets the internal error variable to the correct message for permission
+# denied on an ACL.
+sub acl_error {
+ my ($self, $acl, $action) = @_;
+ my $user = $self->{user};
+ if ($action eq 'add') {
+ $action = 'add to';
+ } elsif ($action eq 'remove') {
+ $action = 'remove from';
+ } elsif ($action eq 'history') {
+ $action = 'see history of';
+ }
+ $self->error ("$self->{user} not authorized to $action ACL $acl");
+}
+
+# Display the history of an ACL or return undef and set the internal error.
+sub acl_history {
+ my ($self, $id) = @_;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->acl_error ($id, 'history');
+ return;
+ }
+ my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ my $result = $acl->history;
+ if (not defined $result) {
+ $self->error ($acl->error);
+ return;
+ }
+ return $result;
+}
+
+# Display the membership of an ACL or return undef and set the internal error.
+sub acl_show {
+ my ($self, $id) = @_;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->acl_error ($id, 'show');
+ return;
+ }
+ my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ my $result = $acl->show;
+ if (not defined $result) {
+ $self->error ($acl->error);
+ return;
+ }
+ return $result;
+}
+
+# Change the human-readable name of an ACL or return undef and set the
+# internal error.
+sub acl_rename {
+ my ($self, $id, $name) = @_;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->acl_error ($id, 'rename');
+ return;
+ }
+ my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ if ($acl->name eq 'ADMIN') {
+ $self->error ('cannot rename the ADMIN ACL');
+ return;
+ }
+ if (defined (&Wallet::Config::verify_acl_name)) {
+ my $error = Wallet::Config::verify_acl_name ($name, $self->{user});
+ if ($error) {
+ $self->error ("$name rejected: $error");
+ return;
+ }
+ }
+ unless ($acl->rename ($name)) {
+ $self->error ($acl->error);
+ return;
+ }
+ return 1;
+}
+
+# Destroy an ACL, deleting it out of the database. Returns true on success.
+# On failure, returns undef, setting the internal error.
+sub acl_destroy {
+ my ($self, $id) = @_;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->acl_error ($id, 'destroy');
+ return;
+ }
+ my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ if ($acl->name eq 'ADMIN') {
+ $self->error ('cannot destroy the ADMIN ACL');
+ return;
+ }
+ unless ($acl->destroy ($self->{user}, $self->{host})) {
+ $self->error ($acl->error);
+ return;
+ }
+ return 1;
+}
+
+# Add an ACL entry to an ACL. Returns true on success. On failure, returns
+# undef, setting the internal error.
+sub acl_add {
+ my ($self, $id, $scheme, $identifier) = @_;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->acl_error ($id, 'add');
+ return;
+ }
+ my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ unless ($acl->add ($scheme, $identifier, $self->{user}, $self->{host})) {
+ $self->error ($acl->error);
+ return;
+ }
+ return 1;
+}
+
+# Remove an ACL entry to an ACL. Returns true on success. On failure,
+# returns undef, setting the internal error.
+sub acl_remove {
+ my ($self, $id, $scheme, $identifier) = @_;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->acl_error ($id, 'remove');
+ return;
+ }
+ my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ if ($acl->name eq 'ADMIN') {
+ my @e = $acl->list;
+ if (not @e and $acl->error) {
+ $self->error ($acl->error);
+ return;
+ } elsif (@e == 1 && $e[0][0] eq $scheme && $e[0][1] eq $identifier) {
+ $self->error ('cannot remove last ADMIN ACL entry');
+ return;
+ }
+ }
+ my $user = $self->{user};
+ my $host = $self->{host};
+ unless ($acl->remove ($scheme, $identifier, $user, $host)) {
+ $self->error ($acl->error);
+ return;
+ }
+ return 1;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=head1 NAME
+
+Wallet::Server - Wallet system server implementation
+
+=for stopwords
+keytabs metadata backend HOSTNAME ACL timestamp ACL's nul Allbery
+backend-specific wallet-backend verifier
+
+=head1 SYNOPSIS
+
+ use Wallet::Server;
+ my $server = Wallet::Server->new ($user, $host);
+ $server->create ('keytab', 'host/example.com@EXAMPLE.COM');
+
+=head1 DESCRIPTION
+
+Wallet::Server is the top-level class that implements the wallet server.
+The wallet is a system for storing, generating, and retrieving secure
+information such as Kerberos keytabs. The server maintains metadata about
+the objects, checks access against ACLs, and dispatches requests for
+objects to backend implementations for that object type.
+
+Wallet::Server is normally instantiated and used by B<wallet-backend>, a
+thin wrapper around this object that determines the authenticated remote
+user and gets user input and then calls the appropriate method of this
+object.
+
+To use this object, several configuration variables must be set (at least
+the database configuration). For information on those variables and how
+to set them, see L<Wallet::Config>.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new(PRINCIPAL, HOSTNAME)
+
+Creates a new wallet server object for actions from the user PRINCIPAL
+connecting from HOSTNAME. PRINCIPAL and HOSTNAME will be used for logging
+history information for all subsequent operations. new() opens the
+database, using the database configuration as set by Wallet::Config and
+ensures that the C<ADMIN> ACL exists. That ACL will be used to authorize
+privileged operations.
+
+On any error, this method throws an exception.
+
+=back
+
+=head1 INSTANCE METHODS
+
+For all methods that can fail, the caller should call error() after a
+failure to get the error message.
+
+=over 4
+
+=item acl(TYPE, NAME, ACL [, ID])
+
+Gets or sets the ACL type ACL to ID for the object identified by TYPE and
+NAME. ACL should be one of C<get>, C<store>, C<show>, C<destroy>, or
+C<flags>. If ID is not given, returns the current setting of that ACL as
+a numeric ACL ID or undef if that ACL isn't set or on failure. To
+distinguish between an ACL that isn't set and a failure to retrieve the
+ACL, the caller should call error() after an undef return. If error()
+also returns undef, that ACL wasn't set; otherwise, error() will return
+the error message.
+
+If ID is given, sets the specified ACL to ID, which can be either the name
+of an ACL or a numeric ACL ID. To clear the ACL, pass in an empty string
+as the ID. To set or clear an ACL, the current user must be authorized by
+the ADMIN ACL. Returns true for success and false for failure.
+
+ACL settings are checked before the owner and override the owner setting.
+
+=item acl_add(ID, SCHEME, IDENTIFIER)
+
+Adds an ACL entry with scheme SCHEME and identifier IDENTIFIER to the ACL
+identified by ID. ID may be either the ACL name or the numeric ACL ID.
+SCHEME must be a valid ACL scheme for which the wallet system has an ACL
+verifier implementation. To add an entry to an ACL, the current user must
+be authorized by the ADMIN ACL. Returns true for success and false for
+failure.
+
+=item acl_create(NAME)
+
+Create a new ACL with the specified NAME, which must not be all-numeric.
+The newly created ACL will be empty. To create an ACL, the current user
+must be authorized by the ADMIN ACL. Returns true on success and false on
+failure.
+
+=item acl_destroy(ID)
+
+Destroys the ACL identified by ID, which may be either the ACL name or its
+numeric ID. This call will fail if the ACL is still referenced by any
+object. The ADMIN ACL may not be destroyed. To destroy an ACL, the
+current user must be authorized by the ADMIN ACL. Returns true on success
+and false on failure.
+
+=item acl_history(ID)
+
+Returns the history of the ACL identified by ID, which may be either the
+ACL name or its numeric ID. To see the history of an ACL, the current
+user must be authorized by the ADMIN ACL. Each change that modifies the
+ACL (not counting changes in the name of the ACL) will be represented by
+two lines. The first line will have a timestamp of the change followed by
+a description of the change, and the second line will give the user who
+made the change and the host from which the change was made. Returns
+undef on failure.
+
+=item acl_remove(ID, SCHEME, IDENTIFIER)
+
+Removes from the ACL identified by ID the entry matching SCHEME and
+IDENTIFIER. ID may be either the name of the ACL or its numeric ID. The
+last entry in the ADMIN ACL cannot be removed. To remove an entry from an
+ACL, the current user must be authorized by the ADMIN ACL. Returns true
+on success and false on failure.
+
+=item acl_rename(OLD, NEW)
+
+Renames the ACL identified by OLD to NEW. This changes the human-readable
+name, not the underlying numeric ID, so the ACL's associations with
+objects will be unchanged. The ADMIN ACL may not be renamed. OLD may be
+either the current name or the numeric ID. NEW must not be all-numeric.
+To rename an ACL, the current user must be authorized by the ADMIN ACL.
+Returns true on success and false on failure.
+
+=item acl_show(ID)
+
+Returns a human-readable description, including membership, of the ACL
+identified by ID, which may be either the ACL name or its numeric ID. To
+show an ACL, the current user must be authorized by the ADMIN ACL
+(although be aware that anyone with show access to an object can see the
+membership of ACLs associated with that object through the show() method).
+Returns the human-readable description on success and undef on failure.
+
+=item attr(TYPE, NAME, ATTRIBUTE [, VALUE ...])
+
+Sets or retrieves a given object attribute. Attributes are used to store
+backend-specific information for a particular object type and ATTRIBUTE
+must be an attribute type known to the underlying object implementation.
+
+If VALUE is not given, returns the values of that attribute, if any, as a
+list. On error, returns the empty list. To distinguish between an error
+and an empty return, call error() afterward. It is guaranteed to return
+undef unless there was an error. To retrieve an attribute setting, the
+user must be authorized by the ADMIN ACL, the show ACL if set, or the
+owner ACL if the show ACL is not set.
+
+If VALUE is given, sets the given ATTRIBUTE values to VALUE, which is one
+or more attribute values. Pass the empty string as the only VALUE to
+clear the attribute values. Returns true on success and false on failure.
+To set an attribute value, the user must be authorized by the ADMIN ACL,
+the store ACL if set, or the owner ACL if the store ACL is not set.
+
+=item autocreate(TYPE, NAME)
+
+Creates a new object of type TYPE and name NAME. TYPE must be a
+recognized type for which the wallet system has a backend implementation.
+Returns true on success and false on failure.
+
+To create an object using this method, the current user must be authorized
+by the default owner as determined by the wallet configuration. For more
+information on how to map new objects to default owners, see
+Wallet::Config(3). Wallet administrators should use the create() method
+to create objects.
+
+=item check(TYPE, NAME)
+
+Check whether an object of type TYPE and name NAME exists. Returns 1 if
+it does, 0 if it doesn't, and undef if some error occurred while checking
+for the existence of the object.
+
+=item comment(TYPE, NAME, [COMMENT])
+
+Gets or sets the comment for the object identified by TYPE and NAME. If
+COMMENT is not given, returns the current comment or undef if no comment
+is set or on an error. To distinguish between an expiration that isn't
+set and a failure to retrieve the expiration, the caller should call
+error() after an undef return. If error() also returns undef, no comment
+was set; otherwise, error() will return the error message.
+
+If COMMENT is given, sets the comment to COMMENT. Pass in the empty
+string for COMMENT to clear the comment. To set a comment, the current
+user must be the object owner or be on the ADMIN ACL. Returns true for
+success and false for failure.
+
+=item create(TYPE, NAME)
+
+Creates a new object of type TYPE and name NAME. TYPE must be a
+recognized type for which the wallet system has a backend implementation.
+Returns true on success and false on failure.
+
+To create an object using this method, the current user must be authorized
+by the ADMIN ACL. Use autocreate() to create objects based on the default
+owner as determined by the wallet configuration.
+
+=item destroy(TYPE, NAME)
+
+Destroys the object identified by TYPE and NAME. This destroys any data
+that the wallet had saved about the object, may remove the underlying
+object from other external systems, and destroys the wallet database entry
+for the object. To destroy an object, the current user must be a member
+of the ADMIN ACL, authorized by the destroy ACL, or authorized by the
+owner ACL; however, if the destroy ACL is set, the owner ACL will not be
+checked. Returns true on success and false on failure.
+
+=item dbh()
+
+Returns the database handle of a Wallet::Server object. This is used
+mostly for testing; normally, clients should perform all actions through
+the Wallet::Server object to ensure that authorization and history logging
+is done properly.
+
+=item error()
+
+Returns the error of the last failing operation or undef if no operations
+have failed. Callers should call this function to get the error message
+after an undef return from any other instance method.
+
+=item expires(TYPE, NAME [, EXPIRES])
+
+Gets or sets the expiration for the object identified by TYPE and NAME.
+If EXPIRES is not given, returns the current expiration or undef if no
+expiration is set or on an error. To distinguish between an expiration
+that isn't set and a failure to retrieve the expiration, the caller should
+call error() after an undef return. If error() also returns undef, the
+expiration wasn't set; otherwise, error() will return the error message.
+
+If EXPIRES is given, sets the expiration to EXPIRES. EXPIRES must be in
+the format C<YYYY-MM-DD +HH:MM:SS>, although the time portion may be
+omitted. Pass in the empty string for EXPIRES to clear the expiration
+date. To set an expiration, the current user must be authorized by the
+ADMIN ACL. Returns true for success and false for failure.
+
+=item flag_clear(TYPE, NAME, FLAG)
+
+Clears the flag FLAG on the object identified by TYPE and NAME. To clear
+a flag, the current user must be authorized by the ADMIN ACL or the flags
+ACL on the object.
+
+=item flag_set(TYPE, NAME, FLAG)
+
+Sets the flag FLAG on the object identified by TYPE and NAME. To set a
+flag, the current user must be authorized by the ADMIN ACL or the flags
+ACL on the object.
+
+=item get(TYPE, NAME)
+
+Returns the data associated with the object identified by TYPE and NAME.
+Depending on the object TYPE, this may generate new data and invalidate
+any existing data or it may return data previously stored or generated.
+Note that this data may be binary and may contain nul characters. To get
+an object, the current user must either be authorized by the owner ACL or
+authorized by the get ACL; however, if the get ACL is set, the owner ACL
+will not be checked. Being a member of the ADMIN ACL does not provide any
+special privileges to get objects.
+
+Returns undef on failure. The caller should be careful to distinguish
+between undef and the empty string, which is valid object data.
+
+=item history(TYPE, NAME)
+
+Returns (as a string) the human-readable history of the object identified
+by TYPE and NAME, or undef on error. To see the object history, the
+current user must be a member of the ADMIN ACL, authorized by the show
+ACL, or authorized by the owner ACL; however, if the show ACL is set, the
+owner ACL will not be checked.
+
+=item owner(TYPE, NAME [, OWNER])
+
+Gets or sets the owner for the object identified by TYPE and NAME. If
+OWNER is not given, returns the current owner as a numeric ACL ID or undef
+if no owner is set or on an error. To distinguish between an owner that
+isn't set and a failure to retrieve the owner, the caller should call
+error() after an undef return. If error() also returns undef, that ACL
+wasn't set; otherwise, error() will return the error message.
+
+If OWNER is given, sets the owner to OWNER, which may be either the name
+of an ACL or a numeric ACL ID. To set an owner, the current user must be
+authorized by the ADMIN ACL. Returns true for success and false for
+failure.
+
+The owner of an object is permitted to get, store, and show that object,
+but cannot destroy or set flags on that object without being listed on
+those ACLs as well.
+
+=item schema()
+
+Returns the DBIx::Class schema object.
+
+=item show(TYPE, NAME)
+
+Returns (as a string) a human-readable representation of the metadata
+stored for the object identified by TYPE and NAME, or undef on error.
+Included is the metadata and entries of any ACLs associated with the
+object. To show an object, the current user must be a member of the ADMIN
+ACL, authorized by the show ACL, or authorized by the owner ACL; however,
+if the show ACL is set, the owner ACL will not be checked.
+
+=item store(TYPE, NAME, DATA)
+
+Stores DATA for the object identified with TYPE and NAME for later
+retrieval with get. Not all object types support this. Note that DATA
+may be binary and may contain nul characters. To store an object, the
+current user must either be authorized by the owner ACL or authorized by
+the store ACL; however, if the store ACL is set, the owner ACL is not
+checked. Being a member of the ADMIN ACL does not provide any special
+privileges to store objects. Returns true on success and false on
+failure.
+
+=back
+
+=head1 SEE ALSO
+
+wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut