diff options
Diffstat (limited to 'perl/lib/Wallet')
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 |