diff options
Diffstat (limited to 'perl/Wallet')
35 files changed, 0 insertions, 10096 deletions
diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm deleted file mode 100644 index 808be3c..0000000 --- a/perl/Wallet/ACL.pm +++ /dev/null @@ -1,657 +0,0 @@ -# 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/Wallet/ACL/Base.pm b/perl/Wallet/ACL/Base.pm deleted file mode 100644 index b6e4ce3..0000000 --- a/perl/Wallet/ACL/Base.pm +++ /dev/null @@ -1,125 +0,0 @@ -# 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/Wallet/ACL/Krb5.pm b/perl/Wallet/ACL/Krb5.pm deleted file mode 100644 index ed0b7df..0000000 --- a/perl/Wallet/ACL/Krb5.pm +++ /dev/null @@ -1,125 +0,0 @@ -# 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/Wallet/ACL/Krb5/Regex.pm b/perl/Wallet/ACL/Krb5/Regex.pm deleted file mode 100644 index 30f5527..0000000 --- a/perl/Wallet/ACL/Krb5/Regex.pm +++ /dev/null @@ -1,133 +0,0 @@ -# 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/Wallet/ACL/LDAP/Attribute.pm b/perl/Wallet/ACL/LDAP/Attribute.pm deleted file mode 100644 index aea8a72..0000000 --- a/perl/Wallet/ACL/LDAP/Attribute.pm +++ /dev/null @@ -1,263 +0,0 @@ -# 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/Wallet/ACL/NetDB.pm b/perl/Wallet/ACL/NetDB.pm deleted file mode 100644 index b76d4ed..0000000 --- a/perl/Wallet/ACL/NetDB.pm +++ /dev/null @@ -1,267 +0,0 @@ -# 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/Wallet/ACL/NetDB/Root.pm b/perl/Wallet/ACL/NetDB/Root.pm deleted file mode 100644 index 6c95c6e..0000000 --- a/perl/Wallet/ACL/NetDB/Root.pm +++ /dev/null @@ -1,128 +0,0 @@ -# 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/Wallet/Admin.pm b/perl/Wallet/Admin.pm deleted file mode 100644 index 3a05284..0000000 --- a/perl/Wallet/Admin.pm +++ /dev/null @@ -1,379 +0,0 @@ -# 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/Wallet/Config.pm b/perl/Wallet/Config.pm deleted file mode 100644 index 5b0ab1c..0000000 --- a/perl/Wallet/Config.pm +++ /dev/null @@ -1,826 +0,0 @@ -# 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/Wallet/Database.pm b/perl/Wallet/Database.pm deleted file mode 100644 index 031be9e..0000000 --- a/perl/Wallet/Database.pm +++ /dev/null @@ -1,123 +0,0 @@ -# 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/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm deleted file mode 100644 index 4ea7920..0000000 --- a/perl/Wallet/Kadmin.pm +++ /dev/null @@ -1,240 +0,0 @@ -# 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/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm deleted file mode 100644 index 42de8e0..0000000 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ /dev/null @@ -1,314 +0,0 @@ -# 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/Wallet/Kadmin/MIT.pm b/perl/Wallet/Kadmin/MIT.pm deleted file mode 100644 index 1ae01bf..0000000 --- a/perl/Wallet/Kadmin/MIT.pm +++ /dev/null @@ -1,323 +0,0 @@ -# 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/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm deleted file mode 100644 index 8debac9..0000000 --- a/perl/Wallet/Object/Base.pm +++ /dev/null @@ -1,1015 +0,0 @@ -# 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/Wallet/Object/Duo.pm b/perl/Wallet/Object/Duo.pm deleted file mode 100644 index e5773c8..0000000 --- a/perl/Wallet/Object/Duo.pm +++ /dev/null @@ -1,331 +0,0 @@ -# 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/Wallet/Object/File.pm b/perl/Wallet/Object/File.pm deleted file mode 100644 index 4afef04..0000000 --- a/perl/Wallet/Object/File.pm +++ /dev/null @@ -1,242 +0,0 @@ -# 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/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm deleted file mode 100644 index 24c3302..0000000 --- a/perl/Wallet/Object/Keytab.pm +++ /dev/null @@ -1,513 +0,0 @@ -# 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/Wallet/Object/WAKeyring.pm b/perl/Wallet/Object/WAKeyring.pm deleted file mode 100644 index f8bd0f7..0000000 --- a/perl/Wallet/Object/WAKeyring.pm +++ /dev/null @@ -1,370 +0,0 @@ -# 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/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm deleted file mode 100644 index 5ac29e0..0000000 --- a/perl/Wallet/Policy/Stanford.pm +++ /dev/null @@ -1,422 +0,0 @@ -# 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/Wallet/Report.pm b/perl/Wallet/Report.pm deleted file mode 100644 index 1085546..0000000 --- a/perl/Wallet/Report.pm +++ /dev/null @@ -1,680 +0,0 @@ -# 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/Wallet/Schema.pm b/perl/Wallet/Schema.pm deleted file mode 100644 index 74b4c99..0000000 --- a/perl/Wallet/Schema.pm +++ /dev/null @@ -1,354 +0,0 @@ -# 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/Wallet/Schema/Result/Acl.pm b/perl/Wallet/Schema/Result/Acl.pm deleted file mode 100644 index 226738a..0000000 --- a/perl/Wallet/Schema/Result/Acl.pm +++ /dev/null @@ -1,110 +0,0 @@ -# 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/Wallet/Schema/Result/AclEntry.pm b/perl/Wallet/Schema/Result/AclEntry.pm deleted file mode 100644 index a33a98c..0000000 --- a/perl/Wallet/Schema/Result/AclEntry.pm +++ /dev/null @@ -1,74 +0,0 @@ -# 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/Wallet/Schema/Result/AclHistory.pm b/perl/Wallet/Schema/Result/AclHistory.pm deleted file mode 100644 index 11593b7..0000000 --- a/perl/Wallet/Schema/Result/AclHistory.pm +++ /dev/null @@ -1,113 +0,0 @@ -# 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/Wallet/Schema/Result/AclScheme.pm b/perl/Wallet/Schema/Result/AclScheme.pm deleted file mode 100644 index 91a58b2..0000000 --- a/perl/Wallet/Schema/Result/AclScheme.pm +++ /dev/null @@ -1,84 +0,0 @@ -# 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/Wallet/Schema/Result/Duo.pm b/perl/Wallet/Schema/Result/Duo.pm deleted file mode 100644 index 80a71dc..0000000 --- a/perl/Wallet/Schema/Result/Duo.pm +++ /dev/null @@ -1,53 +0,0 @@ -# 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/Wallet/Schema/Result/Enctype.pm b/perl/Wallet/Schema/Result/Enctype.pm deleted file mode 100644 index 5733669..0000000 --- a/perl/Wallet/Schema/Result/Enctype.pm +++ /dev/null @@ -1,45 +0,0 @@ -# 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/Wallet/Schema/Result/Flag.pm b/perl/Wallet/Schema/Result/Flag.pm deleted file mode 100644 index e223ff8..0000000 --- a/perl/Wallet/Schema/Result/Flag.pm +++ /dev/null @@ -1,62 +0,0 @@ -# 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/Wallet/Schema/Result/KeytabEnctype.pm b/perl/Wallet/Schema/Result/KeytabEnctype.pm deleted file mode 100644 index daea724..0000000 --- a/perl/Wallet/Schema/Result/KeytabEnctype.pm +++ /dev/null @@ -1,53 +0,0 @@ -# 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/Wallet/Schema/Result/KeytabSync.pm b/perl/Wallet/Schema/Result/KeytabSync.pm deleted file mode 100644 index ca84277..0000000 --- a/perl/Wallet/Schema/Result/KeytabSync.pm +++ /dev/null @@ -1,53 +0,0 @@ -# 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/Wallet/Schema/Result/Object.pm b/perl/Wallet/Schema/Result/Object.pm deleted file mode 100644 index fd64e1b..0000000 --- a/perl/Wallet/Schema/Result/Object.pm +++ /dev/null @@ -1,266 +0,0 @@ -# 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/Wallet/Schema/Result/ObjectHistory.pm b/perl/Wallet/Schema/Result/ObjectHistory.pm deleted file mode 100644 index 5e9c8bd..0000000 --- a/perl/Wallet/Schema/Result/ObjectHistory.pm +++ /dev/null @@ -1,135 +0,0 @@ -# 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/Wallet/Schema/Result/SyncTarget.pm b/perl/Wallet/Schema/Result/SyncTarget.pm deleted file mode 100644 index 4300a54..0000000 --- a/perl/Wallet/Schema/Result/SyncTarget.pm +++ /dev/null @@ -1,48 +0,0 @@ -# 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/Wallet/Schema/Result/Type.pm b/perl/Wallet/Schema/Result/Type.pm deleted file mode 100644 index 748a8a8..0000000 --- a/perl/Wallet/Schema/Result/Type.pm +++ /dev/null @@ -1,75 +0,0 @@ -# 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/Wallet/Server.pm b/perl/Wallet/Server.pm deleted file mode 100644 index 3266928..0000000 --- a/perl/Wallet/Server.pm +++ /dev/null @@ -1,1095 +0,0 @@ -# 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 |