aboutsummaryrefslogtreecommitdiff
path: root/perl/lib/Wallet/Object
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/Wallet/Object
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/Wallet/Object')
-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
5 files changed, 2471 insertions, 0 deletions
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