diff options
Diffstat (limited to 'perl/Wallet')
33 files changed, 3288 insertions, 700 deletions
diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm index 44a82b2..5d9e8f2 100644 --- a/perl/Wallet/ACL.pm +++ b/perl/Wallet/ACL.pm @@ -1,7 +1,8 @@ # Wallet::ACL -- Implementation of ACLs in the wallet system. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2010, 2013 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -32,27 +33,25 @@ $VERSION = '0.07'; # and the database handle to use for future operations. If the object # doesn't exist, throws an exception. sub new { - my ($class, $id, $dbh) = @_; - my ($sql, $data, $name); + my ($class, $id, $schema) = @_; + my (%search, $data, $name); if ($id =~ /^\d+\z/) { - $sql = 'select ac_id, ac_name from acls where ac_id = ?'; + $search{ac_id} = $id; } else { - $sql = 'select ac_id, ac_name from acls where ac_name = ?'; + $search{ac_name} = $id; } eval { - ($data, $name) = $dbh->selectrow_array ($sql, undef, $id); - $dbh->commit; + $data = $schema->resultset('Acl')->find (\%search); }; if ($@) { - $dbh->rollback; die "cannot search for ACL $id: $@\n"; } elsif (not defined $data) { die "ACL $id not found\n"; } my $self = { - dbh => $dbh, - id => $data, - name => $name, + schema => $schema, + id => $data->ac_id, + name => $data->ac_name, }; bless ($self, $class); return $self; @@ -62,31 +61,40 @@ sub 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, $dbh, $user, $host, $time) = @_; + 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 $sql = 'insert into acls (ac_name) values (?)'; - $dbh->do ($sql, undef, $name); - $id = $dbh->last_insert_id (undef, undef, 'acls', 'ac_id'); + 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); - $sql = "insert into acl_history (ah_acl, ah_action, ah_by, ah_from, - ah_on) values (?, 'create', ?, ?, ?)"; - $dbh->do ($sql, undef, $id, $user, $host, $date); - $dbh->commit; + %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 ($@) { - $dbh->rollback; die "cannot create ACL $name: $@\n"; } my $self = { - dbh => $dbh, - id => $id, - name => $name, + schema => $schema, + id => $id, + name => $name, }; bless ($self, $class); return $self; @@ -126,13 +134,13 @@ sub scheme_mapping { my ($self, $scheme) = @_; my $class; eval { - my $sql = 'select as_class from acl_schemes where as_name = ?'; - ($class) = $self->{dbh}->selectrow_array ($sql, undef, $scheme); - $self->{dbh}->commit; + my %search = (as_name => $scheme); + my $scheme_rec = $self->{schema}->resultset('AclScheme') + ->find (\%search); + $class = $scheme_rec->as_class; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } if (defined $class) { @@ -155,11 +163,14 @@ sub log_acl { unless ($action =~ /^(add|remove)\z/) { die "invalid history action $action"; } - my $date = strftime ('%Y-%m-%d %T', localtime $time); - my $sql = 'insert into acl_history (ah_acl, ah_action, ah_scheme, - ah_identifier, ah_by, ah_from, ah_on) values (?, ?, ?, ?, ?, ?, ?)'; - $self->{dbh}->do ($sql, undef, $self->{id}, $action, $scheme, $identifier, - $user, $host, $date); + 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); } ############################################################################## @@ -176,13 +187,15 @@ sub rename { return; } eval { - my $sql = 'update acls set ac_name = ? where ac_id = ?'; - $self->{dbh}->do ($sql, undef, $name, $self->{id}); - $self->{dbh}->commit; + 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: $@"); - $self->{dbh}->rollback; return; } $self->{name} = $name; @@ -200,27 +213,44 @@ sub destroy { my ($self, $user, $host, $time) = @_; $time ||= time; eval { - my $sql = 'select ob_type, ob_name from objects where ob_owner = ? - or ob_acl_get = ? or ob_acl_store = ? or ob_acl_show = ? or - ob_acl_destroy = ? or ob_acl_flags = ?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (($self->{id}) x 6); - my $entry = $sth->fetchrow_arrayref; - if (defined $entry) { - die "ACL in use by $entry->[0]:$entry->[1]"; + 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; } - $sql = 'delete from acl_entries where ae_id = ?'; - $self->{dbh}->do ($sql, undef, $self->{id}); - $sql = 'delete from acls where ac_id = ?'; - $self->{dbh}->do ($sql, undef, $self->{id}); - $sql = "insert into acl_history (ah_acl, ah_action, ah_by, ah_from, - ah_on) values (?, 'destroy', ?, ?, ?)"; - $self->{dbh}->do ($sql, undef, $self->{id}, $user, $host, $time); - $self->{dbh}->commit; + + # 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 => $time); + $self->{schema}->resultset('AclHistory')->create (\%record); + $guard->commit; }; if ($@) { $self->error ("cannot destroy ACL $self->{id}: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -239,15 +269,16 @@ sub add { return; } eval { - my $sql = 'insert into acl_entries (ae_id, ae_scheme, ae_identifier) - values (?, ?, ?)'; - $self->{dbh}->do ($sql, undef, $self->{id}, $scheme, $identifier); + 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); - $self->{dbh}->commit; + $guard->commit; }; if ($@) { $self->error ("cannot add $scheme:$identifier to $self->{id}: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -260,23 +291,21 @@ sub remove { my ($self, $scheme, $identifier, $user, $host, $time) = @_; $time ||= time; eval { - my $sql = 'select * from acl_entries where ae_id = ? and ae_scheme = ? - and ae_identifier = ?'; - my ($data) = $self->{dbh}->selectrow_array ($sql, undef, $self->{id}, - $scheme, $identifier); - unless (defined $data) { + 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"; } - $sql = 'delete from acl_entries where ae_id = ? and ae_scheme = ? - and ae_identifier = ?'; - $self->{dbh}->do ($sql, undef, $self->{id}, $scheme, $identifier); + $entry->delete; $self->log_acl ('remove', $scheme, $identifier, $user, $host, $time); - $self->{dbh}->commit; + $guard->commit; }; if ($@) { my $entry = "$scheme:$identifier"; $self->error ("cannot remove $entry from $self->{id}: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -294,19 +323,17 @@ sub list { undef $self->{error}; my @entries; eval { - my $sql = 'select ae_scheme, ae_identifier from acl_entries where - ae_id = ?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{id}); - my $entry; - while (defined ($entry = $sth->fetchrow_arrayref)) { - push (@entries, [ @$entry ]); + 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 ]); } - $self->{dbh}->commit; + $guard->commit; }; if ($@) { $self->error ("cannot retrieve ACL $self->{id}: $@"); - $self->{dbh}->rollback; return; } else { return @entries; @@ -338,25 +365,27 @@ sub history { my ($self) = @_; my $output = ''; eval { - my $sql = 'select ah_action, ah_scheme, ah_identifier, ah_by, ah_from, - ah_on from acl_history where ah_acl = ? order by ah_on'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{id}); - my @data; - while (@data = $sth->fetchrow_array) { - $output .= "$data[5] "; - if ($data[0] eq 'add' or $data[0] eq 'remove') { - $output .= "$data[0] $data[1] $data[2]"; + 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[0]; + $output .= $data->ah_action; } - $output .= "\n by $data[3] from $data[4]\n"; + $output .= sprintf ("\n by %s from %s\n", $data->ah_by, + $data->ah_from); } - $self->{dbh}->commit; + $guard->commit; }; if ($@) { $self->error ("cannot read history for $self->{id}: $@"); - $self->{dbh}->rollback; return; } return $output; @@ -442,7 +471,7 @@ __END__ Wallet::ACL - Implementation of ACLs in the wallet system =for stopwords -ACL DBH metadata HOSTNAME DATETIME timestamp Allbery +ACL DBH metadata HOSTNAME DATETIME timestamp Allbery verifier verifiers =head1 SYNOPSIS @@ -484,14 +513,14 @@ references. =over 4 -=item new(ACL, DBH) +=item new(ACL, SCHEMA) Instantiate a new ACL object with the given ACL ID or name. Takes the -Wallet::Database object to use for retrieving metadata from the wallet +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, DBH, PRINCIPAL, HOSTNAME [, DATETIME]) +=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 diff --git a/perl/Wallet/ACL/Base.pm b/perl/Wallet/ACL/Base.pm index 9a8a3cb..5112c2f 100644 --- a/perl/Wallet/ACL/Base.pm +++ b/perl/Wallet/ACL/Base.pm @@ -1,7 +1,8 @@ # Wallet::ACL::Base -- Parent class for wallet ACL verifiers. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -60,7 +61,7 @@ __END__ ############################################################################## =for stopwords -ACL Allbery +ACL Allbery verifier verifiers =head1 NAME diff --git a/perl/Wallet/ACL/Krb5.pm b/perl/Wallet/ACL/Krb5.pm index 496fcf0..716a223 100644 --- a/perl/Wallet/ACL/Krb5.pm +++ b/perl/Wallet/ACL/Krb5.pm @@ -1,7 +1,8 @@ # Wallet::ACL::Krb5 -- Wallet Kerberos v5 principal ACL verifier. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -51,7 +52,7 @@ __END__ ############################################################################## =for stopwords -ACL krb5 Allbery +ACL krb5 Allbery verifier =head1 NAME diff --git a/perl/Wallet/ACL/Krb5/Regex.pm b/perl/Wallet/ACL/Krb5/Regex.pm index 52f4bf5..ce2fe48 100644 --- a/perl/Wallet/ACL/Krb5/Regex.pm +++ b/perl/Wallet/ACL/Krb5/Regex.pm @@ -1,7 +1,8 @@ # Wallet::ACL::Krb5::Regex -- Wallet Kerberos v5 principal regex ACL verifier # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -56,7 +57,7 @@ __END__ ############################################################################## =for stopwords -ACL krb5-regex Durkacz Allbery +ACL krb5-regex Durkacz Allbery verifier =head1 NAME diff --git a/perl/Wallet/ACL/LDAP/Attribute.pm b/perl/Wallet/ACL/LDAP/Attribute.pm new file mode 100644 index 0000000..802c710 --- /dev/null +++ b/perl/Wallet/ACL/LDAP/Attribute.pm @@ -0,0 +1,262 @@ +# Wallet::ACL::LDAP::Attribute -- Wallet LDAP attribute ACL verifier. +# +# Written by Russ Allbery +# Copyright 2012 +# 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; + +@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 <rra@stanford.edu> + +=cut diff --git a/perl/Wallet/ACL/NetDB.pm b/perl/Wallet/ACL/NetDB.pm index 0fb5a2c..2d35f49 100644 --- a/perl/Wallet/ACL/NetDB.pm +++ b/perl/Wallet/ACL/NetDB.pm @@ -1,7 +1,8 @@ # Wallet::ACL::NetDB -- Wallet NetDB role ACL verifier. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -136,7 +137,7 @@ __END__ ############################################################################## =for stopwords -ACL NetDB remctl DNS DHCP Allbery netdb +ACL NetDB remctl DNS DHCP Allbery netdb verifier =head1 NAME diff --git a/perl/Wallet/ACL/NetDB/Root.pm b/perl/Wallet/ACL/NetDB/Root.pm index 3aeebda..ea79d79 100644 --- a/perl/Wallet/ACL/NetDB/Root.pm +++ b/perl/Wallet/ACL/NetDB/Root.pm @@ -1,7 +1,8 @@ # Wallet::ACL::NetDB::Root -- Wallet NetDB role ACL verifier (root instances). # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -49,7 +50,7 @@ sub check { ############################################################################## =for stopwords -ACL NetDB DNS DHCP Allbery +ACL NetDB DNS DHCP Allbery verifier =head1 NAME diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index f208e13..97a2c15 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -1,7 +1,8 @@ # Wallet::Admin -- Wallet system administrative interface. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2011, 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -16,13 +17,18 @@ use strict; use vars qw($VERSION); use Wallet::ACL; -use Wallet::Database; 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.05'; +$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 @@ -33,8 +39,8 @@ $VERSION = '0.05'; # Throw an exception if anything goes wrong. sub new { my ($class) = @_; - my $dbh = Wallet::Database->connect; - my $self = { dbh => $dbh }; + my $schema = Wallet::Schema->connect; + my $self = { schema => $schema }; bless ($self, $class); return $self; } @@ -42,7 +48,13 @@ sub new { # Returns the database handle (used mostly for testing). sub dbh { my ($self) = @_; - return $self->{dbh}; + 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. @@ -60,7 +72,7 @@ sub error { # Disconnect the database handle on object destruction to avoid warnings. sub DESTROY { my ($self) = @_; - $self->{dbh}->disconnect unless $self->{dbh}->{InactiveDestroy}; + $self->{schema}->storage->dbh->disconnect; } ############################################################################## @@ -74,17 +86,50 @@ sub DESTROY { # true on success and false on failure, setting the object error. sub initialize { my ($self, $user) = @_; - my $schema = Wallet::Schema->new; - eval { $schema->create ($self->{dbh}) }; + + # 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; } - my $acl = Wallet::ACL->create ('ADMIN', $self->{dbh}, $user, 'localhost'); + $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' ]); + ($r1) = $self->{schema}->resultset('Type')->populate (\@record); + warn "default Type not installed" unless defined $r1; + return 1; } @@ -101,12 +146,63 @@ sub reinitialize { # false on failure. sub destroy { my ($self) = @_; - my $schema = Wallet::Schema->new; - eval { $schema->drop ($self->{dbh}) }; + + # 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; } @@ -121,13 +217,14 @@ sub destroy { sub register_object { my ($self, $type, $class) = @_; eval { - my $sql = 'insert into types (ty_name, ty_class) values (?, ?)'; - $self->{dbh}->do ($sql, undef, $type, $class); - $self->{dbh}->commit; + 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: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -140,13 +237,14 @@ sub register_object { sub register_verifier { my ($self, $scheme, $class) = @_; eval { - my $sql = 'insert into acl_schemes (as_name, as_class) values (?, ?)'; - $self->{dbh}->do ($sql, undef, $scheme, $class); - $self->{dbh}->commit; + 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 registery $class for $scheme: $@"); - $self->{dbh}->rollback; + $self->error ("cannot register $class for $scheme: $@"); return; } return 1; @@ -164,7 +262,7 @@ __DATA__ Wallet::Admin - Wallet system administrative interface =for stopwords -ACL hostname Allbery +ACL hostname Allbery verifier =head1 SYNOPSIS @@ -204,12 +302,12 @@ failure to get the error message. =over 4 -=item destroy() +=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() +=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 @@ -240,7 +338,7 @@ 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) +=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 @@ -249,6 +347,11 @@ 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 diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index 23a051d..af153e7 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -1,7 +1,8 @@ # Wallet::Config -- Configuration handling for the wallet server. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2010, 2013 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -27,7 +28,7 @@ Wallet::Config - Configuration handling for the wallet server 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 +rekeys WebAuth WEBAUTH keyring LDAP DN GSS-API =head1 SYNOPSIS @@ -84,6 +85,17 @@ file. =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 @@ -378,6 +390,146 @@ 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_attribute. 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_attribute { + 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 diff --git a/perl/Wallet/Database.pm b/perl/Wallet/Database.pm index 7daab9f..61de0ba 100644 --- a/perl/Wallet/Database.pm +++ b/perl/Wallet/Database.pm @@ -1,12 +1,13 @@ # Wallet::Database -- Wallet system database connection management. # -# This module is a thin wrapper around DBI to handle determination of the -# database driver and configuration settings automatically on connect. The +# 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 DBI objects in the rest of the code. +# like DBIx::Class objects in the rest of the code. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,32 +15,21 @@ # Modules and declarations ############################################################################## -# Set up the subclasses. This is required to avoid warnings under DBI 1.40 -# and later, even though we don't actually make use of any overridden -# statement handle or database handle methods. -package Wallet::Database::st; -use vars qw(@ISA); -@ISA = qw(DBI::st); - -package Wallet::Database::db; -use vars qw(@ISA); -@ISA = qw(DBI::db); - package Wallet::Database; require 5.006; use strict; use vars qw(@ISA $VERSION); -use DBI; +use Wallet::Schema; use Wallet::Config; -@ISA = qw(DBI); +@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.03'; +$VERSION = '0.04'; ############################################################################## # Core overrides @@ -65,7 +55,7 @@ sub connect { } my $user = $Wallet::Config::DB_USER; my $pass = $Wallet::Config::DB_PASSWORD; - my %attrs = (PrintError => 0, RaiseError => 1, AutoCommit => 0); + my %attrs = (PrintError => 0, RaiseError => 1); my $dbh = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) }; if ($@) { die "cannot connect to database: $@\n"; diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm index 074dd1e..bfff3ef 100644 --- a/perl/Wallet/Kadmin.pm +++ b/perl/Wallet/Kadmin.pm @@ -1,7 +1,8 @@ # Wallet::Kadmin -- Kerberos administration API for wallet keytab backend. # # Written by Jon Robertson <jonrober@stanford.edu> -# Copyright 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2009, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm index 658ac04..bb07b93 100644 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ b/perl/Wallet/Kadmin/Heimdal.pm @@ -1,7 +1,8 @@ # Wallet::Kadmin::Heimdal -- Wallet Kerberos administration API for Heimdal. # # Written by Jon Robertson <jonrober@stanford.edu> -# Copyright 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2009, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -234,7 +235,7 @@ __END__ ############################################################################## =for stopwords -keytabs keytab kadmin KDC API Allbery Heimdal +keytabs keytab kadmin KDC API Allbery Heimdal unlinked =head1 NAME diff --git a/perl/Wallet/Kadmin/MIT.pm b/perl/Wallet/Kadmin/MIT.pm index fc4d271..b633e67 100644 --- a/perl/Wallet/Kadmin/MIT.pm +++ b/perl/Wallet/Kadmin/MIT.pm @@ -3,7 +3,7 @@ # Written by Russ Allbery <rra@stanford.edu> # Pulled into a module by Jon Robertson <jonrober@stanford.edu> # Copyright 2007, 2008, 2009, 2010 -# Board of Trustees, Leland Stanford Jr. University +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -256,6 +256,7 @@ __END__ =for stopwords rekeying rekeys remctl backend keytabs keytab kadmin KDC API Allbery +unlinked =head1 NAME diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm index 5097729..dd128cc 100644 --- a/perl/Wallet/Object/Base.pm +++ b/perl/Wallet/Object/Base.pm @@ -1,7 +1,8 @@ # Wallet::Object::Base -- Parent class for any object stored in the wallet. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -17,12 +18,13 @@ 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.05'; +$VERSION = '0.06'; ############################################################################## # Constructors @@ -34,15 +36,16 @@ $VERSION = '0.05'; # 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, $dbh) = @_; - my $sql = 'select ob_name from objects where ob_type = ? and ob_name = ?'; - my $data = $dbh->selectrow_array ($sql, undef, $type, $name); - $dbh->commit; - die "cannot find ${type}:${name}\n" unless ($data and $data eq $name); + 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 = { - dbh => $dbh, - name => $name, - type => $type, + schema => $schema, + name => $name, + type => $type, }; bless ($self, $class); return $self; @@ -53,28 +56,37 @@ sub new { # 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, $dbh, $user, $host, $time) = @_; + 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 $date = strftime ('%Y-%m-%d %T', localtime $time); - my $sql = 'insert into objects (ob_type, ob_name, ob_created_by, - ob_created_from, ob_created_on) values (?, ?, ?, ?, ?)'; - $dbh->do ($sql, undef, $type, $name, $user, $host, $date); - $sql = "insert into object_history (oh_type, oh_name, oh_action, - oh_by, oh_from, oh_on) values (?, ?, 'create', ?, ?, ?)"; - $dbh->do ($sql, undef, $type, $name, $user, $host, $date); - $dbh->commit; + 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 ($@) { - $dbh->rollback; die "cannot create object ${type}:${name}: $@\n"; } my $self = { - dbh => $dbh, - name => $name, - type => $type, + schema => $schema, + name => $name, + type => $type, }; bless ($self, $class); return $self; @@ -124,30 +136,36 @@ sub log_action { # 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 $date = strftime ('%Y-%m-%d %T', localtime $time); - my $sql = 'insert into object_history (oh_type, oh_name, oh_action, - oh_by, oh_from, oh_on) values (?, ?, ?, ?, ?, ?)'; - $self->{dbh}->do ($sql, undef, $self->{type}, $self->{name}, $action, - $user, $host, $date); + 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') { - $sql = 'update objects set ob_downloaded_by = ?, - ob_downloaded_from = ?, ob_downloaded_on = ? where - ob_type = ? and ob_name = ?'; - $self->{dbh}->do ($sql, undef, $user, $host, $date, $self->{type}, - $self->{name}); + $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') { - $sql = 'update objects set ob_stored_by = ?, ob_stored_from = ?, - ob_stored_on = ? where ob_type = ? and ob_name = ?'; - $self->{dbh}->do ($sql, undef, $user, $host, $date, $self->{type}, - $self->{name}); + $object->ob_stored_by ($user); + $object->ob_stored_from ($host); + $object->ob_stored_on (strftime ('%Y-%m-%d %T', + localtime $time)); } - $self->{dbh}->commit; + $object->update; + $guard->commit; }; if ($@) { my $id = $self->{type} . ':' . $self->{name}; $self->error ("cannot update history for $id: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -169,16 +187,22 @@ sub log_set { } my %fields = map { $_ => 1 } qw(owner acl_get acl_store acl_show acl_destroy acl_flags expires - flags type_data); + comment flags type_data); unless ($fields{$field}) { die "invalid history field $field"; } - my $date = strftime ('%Y-%m-%d %T', localtime $time); - my $sql = "insert into object_history (oh_type, oh_name, oh_action, - oh_field, oh_type_field, oh_old, oh_new, oh_by, oh_from, oh_on) - values (?, ?, 'set', ?, ?, ?, ?, ?, ?, ?)"; - $self->{dbh}->do ($sql, undef, $self->{type}, $self->{name}, $field, - $type_field, $old, $new, $user, $host, $date); + + 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); } ############################################################################## @@ -200,20 +224,21 @@ sub _set_internal { $self->error ("cannot modify ${type}:${name}: object is locked"); return; } + + my $guard = $self->{schema}->txn_scope_guard; eval { - my $sql = "select ob_$attr from objects where ob_type = ? and - ob_name = ?"; - my $old = $self->{dbh}->selectrow_array ($sql, undef, $type, $name); - $sql = "update objects set ob_$attr = ? where ob_type = ? and - ob_name = ?"; - $self->{dbh}->do ($sql, undef, $value, $type, $name); + 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); - $self->{dbh}->commit; + $guard->commit; }; if ($@) { my $id = $self->{type} . ':' . $self->{name}; $self->error ("cannot set $attr on $id: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -234,14 +259,13 @@ sub _get_internal { my $type = $self->{type}; my $value; eval { - my $sql = "select $attr from objects where ob_type = ? and - ob_name = ?"; - $value = $self->{dbh}->selectrow_array ($sql, undef, $type, $name); - $self->{dbh}->commit; + my %search = (ob_type => $type, + ob_name => $name); + my $object = $self->{schema}->resultset('Object')->find (\%search); + $value = $object->get_column ($attr); }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } return $value; @@ -258,7 +282,7 @@ sub acl { my $attr = "acl_$type"; if ($id) { my $acl; - eval { $acl = Wallet::ACL->new ($id, $self->{dbh}) }; + eval { $acl = Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -291,6 +315,19 @@ sub attr_show { 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. @@ -315,7 +352,7 @@ sub owner { my ($self, $owner, $user, $host, $time) = @_; if ($owner) { my $acl; - eval { $acl = Wallet::ACL->new ($owner, $self->{dbh}) }; + eval { $acl = Wallet::ACL->new ($owner, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -338,17 +375,21 @@ sub flag_check { my ($self, $flag) = @_; my $name = $self->{name}; my $type = $self->{type}; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my $value; eval { - my $sql = 'select fl_flag from flags where fl_type = ? and fl_name = ? - and fl_flag = ?'; - $value = $dbh->selectrow_array ($sql, undef, $type, $name, $flag); - $dbh->commit; + 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}: $@"); - $dbh->rollback; return; } else { return ($value) ? 1 : 0; @@ -362,23 +403,22 @@ sub flag_clear { $time ||= time; my $name = $self->{name}; my $type = $self->{type}; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; eval { - my $sql = 'select * from flags where fl_type = ? and fl_name = ? and - fl_flag = ?'; - my ($data) = $dbh->selectrow_array ($sql, undef, $type, $name, $flag); - unless (defined $data) { + 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"; } - $sql = 'delete from flags where fl_type = ? and fl_name = ? and - fl_flag = ?'; - $dbh->do ($sql, undef, $type, $name, $flag); - $self->log_set ('flags', $flag, undef, $user, $host, $time); - $dbh->commit; + $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}: $@"); - $dbh->rollback; return; } return 1; @@ -392,20 +432,18 @@ sub flag_list { undef $self->{error}; my @flags; eval { - my $sql = 'select fl_flag from flags where fl_type = ? and - fl_name = ? order by fl_flag'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{type}, $self->{name}); - my $flag; - while (defined ($flag = $sth->fetchrow_array)) { - push (@flags, $flag); + 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); } - $self->{dbh}->commit; }; if ($@) { my $id = $self->{type} . ':' . $self->{name}; $self->error ("cannot retrieve flags for $id: $@"); - $self->{dbh}->rollback; return; } else { return @flags; @@ -419,23 +457,22 @@ sub flag_set { $time ||= time; my $name = $self->{name}; my $type = $self->{type}; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; eval { - my $sql = 'select * from flags where fl_type = ? and fl_name = ? and - fl_flag = ?'; - my ($data) = $dbh->selectrow_array ($sql, undef, $type, $name, $flag); - if (defined $data) { + 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"; } - $sql = 'insert into flags (fl_type, fl_name, fl_flag) - values (?, ?, ?)'; - $dbh->do ($sql, undef, $type, $name, $flag); - $self->log_set ('flags', undef, $flag, $user, $host, $time); - $dbh->commit; + $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}: $@"); - $dbh->rollback; return; } return 1; @@ -451,11 +488,10 @@ sub format_acl_id { my ($self, $id) = @_; my $name = $id; - my $sql = 'select ac_name from acls where ac_id = ?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($id); - if (my @ref = $sth->fetchrow_array) { - $name = $ref[0] . " ($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; @@ -468,23 +504,29 @@ sub history { my ($self) = @_; my $output = ''; eval { - my $sql = 'select oh_action, oh_field, oh_type_field, oh_old, oh_new, - oh_by, oh_from, oh_on from object_history where oh_type = ? and - oh_name = ? order by oh_on'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{type}, $self->{name}); - my @data; - while (@data = $sth->fetchrow_array) { - $output .= "$data[7] "; - my ($old, $new) = @data[3..4]; - if ($data[0] eq 'set' and $data[1] eq 'flags') { - if (defined ($data[4])) { - $output .= "set flag $data[4]"; - } elsif (defined ($data[3])) { - $output .= "clear flag $data[3]"; + 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 ($data[0] eq 'set' and $data[1] eq 'type_data') { - my $attr = $data[2]; + } 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)) { @@ -492,9 +534,8 @@ sub history { } elsif (defined ($new)) { $output .= "add $new to attribute $attr"; } - } elsif ($data[0] eq 'set' - and ($data[1] eq 'owner' or $data[1] =~ /^acl_/)) { - my $field = $data[1]; + } 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)) { @@ -504,8 +545,7 @@ sub history { } elsif (defined ($old)) { $output .= "unset $field (was $old)"; } - } elsif ($data[0] eq 'set') { - my $field = $data[1]; + } elsif ($action eq 'set') { if (defined ($old) and defined ($new)) { $output .= "set $field to $new (was $old)"; } elsif (defined ($new)) { @@ -514,16 +554,15 @@ sub history { $output .= "unset $field (was $old)"; } } else { - $output .= $data[0]; + $output .= $action; } - $output .= "\n by $data[5] from $data[6]\n"; + $output .= sprintf ("\n by %s from %s\n", $history_rs->oh_by, + $history_rs->oh_from); } - $self->{dbh}->commit; }; if ($@) { my $id = $self->{type} . ':' . $self->{name}; $self->error ("cannot read history for $id: $@"); - $self->{dbh}->rollback; return; } return $output; @@ -565,6 +604,7 @@ sub show { [ 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' ], @@ -576,15 +616,14 @@ sub show { [ ob_downloaded_on => 'Downloaded on' ]); my $fields = join (', ', map { $_->[0] } @attrs); my @data; + my $object_rs; eval { - my $sql = "select $fields from objects where ob_type = ? and - ob_name = ?"; - @data = $self->{dbh}->selectrow_array ($sql, undef, $type, $name); - $self->{dbh}->commit; + 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}: $@"); - $self->{dbh}->rollback; return; } my $output = ''; @@ -592,8 +631,19 @@ sub show { # 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. - for my $i (0 .. $#data) { - if ($attrs[$i][0] eq 'ob_created_by') { + # 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; @@ -607,15 +657,14 @@ sub show { } $output .= $attr_output; } - next unless defined $data[$i]; - if ($attrs[$i][0] =~ /^ob_(owner|acl_)/) { - my $acl = eval { Wallet::ACL->new ($data[$i], $self->{dbh}) }; + if ($field =~ /^ob_(owner|acl_)/) { + my $acl = eval { Wallet::ACL->new ($value, $self->{schema}) }; if ($acl and not $@) { - $data[$i] = $acl->name || $data[$i]; - push (@acls, [ $acl, $data[$i] ]); + $value = $acl->name || $value; + push (@acls, [ $acl, $value ]); } } - $output .= sprintf ("%15s: %s\n", $attrs[$i][1], $data[$i]); + $output .= sprintf ("%15s: %s\n", $fieldtext, $value); } if (@acls) { my %seen; @@ -639,20 +688,31 @@ sub destroy { $self->error ("cannot destroy ${type}:${name}: object is locked"); return; } + my $guard = $self->{schema}->txn_scope_guard; eval { - my $date = strftime ('%Y-%m-%d %T', localtime $time); - my $sql = 'delete from flags where fl_type = ? and fl_name = ?'; - $self->{dbh}->do ($sql, undef, $type, $name); - $sql = 'delete from objects where ob_type = ? and ob_name = ?'; - $self->{dbh}->do ($sql, undef, $type, $name); - $sql = "insert into object_history (oh_type, oh_name, oh_action, - oh_by, oh_from, oh_on) values (?, ?, 'destroy', ?, ?, ?)"; - $self->{dbh}->do ($sql, undef, $type, $name, $user, $host, $date); - $self->{dbh}->commit; + + # 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}: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -671,7 +731,7 @@ Wallet::Object::Base - Generic parent class for wallet objects =for stopwords DBH HOSTNAME DATETIME ACL backend metadata timestamp Allbery wallet-backend -backend-specific +backend-specific subclasses =head1 SYNOPSIS @@ -709,7 +769,7 @@ 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::Database object, which is stored in the object and used +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]) @@ -778,6 +838,18 @@ 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 diff --git a/perl/Wallet/Object/File.pm b/perl/Wallet/Object/File.pm index 47c8ac2..49589f1 100644 --- a/perl/Wallet/Object/File.pm +++ b/perl/Wallet/Object/File.pm @@ -1,7 +1,8 @@ # Wallet::Object::File -- File object implementation for the wallet. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -143,7 +144,7 @@ API HOSTNAME DATETIME keytab remctld backend nul Allbery wallet-backend my @name = qw(file mysql-lsdb) my @trace = ($user, $host, time); - my $object = Wallet::Object::Keytab->create (@name, $dbh, @trace); + my $object = Wallet::Object::Keytab->create (@name, $schema, @trace); unless ($object->store ("the-password\n")) { die $object->error, "\n"; } diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index b7c2805..e00747b 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -1,8 +1,8 @@ # Wallet::Object::Keytab -- Keytab object implementation for the wallet. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2008, 2009, 2010 -# Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2009, 2010, 2013 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -40,21 +40,29 @@ sub enctypes_set { my @trace = ($user, $host, $time); my $name = $self->{name}; my %enctypes = map { $_ => 1 } @$enctypes; + my $guard = $self->{schema}->txn_scope_guard; eval { - my $sql = 'select ke_enctype from keytab_enctypes where ke_name = ?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($name); - my (@current, $entry); - while (defined ($entry = $sth->fetchrow_arrayref)) { - push (@current, @$entry); + + # 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 { - $sql = 'delete from keytab_enctypes where ke_name = ? and - ke_enctype = ?'; - $self->{dbh}->do ($sql, undef, $name, $enctype); + %search = (ke_name => $name, + ke_enctype => $enctype); + $self->{schema}->resultset('KeytabEnctype')->find (\%search) + ->delete; $self->log_set ('type_data enctypes', $enctype, undef, @trace); } } @@ -64,21 +72,20 @@ sub enctypes_set { # doesn't enforce integrity constraints. We do this in sorted order # to make it easier to test. for my $enctype (sort keys %enctypes) { - $sql = 'select en_name from enctypes where en_name = ?'; - my $status = $self->{dbh}->selectrow_array ($sql, undef, $enctype); - unless ($status) { + my %search = (en_name => $enctype); + my $enctype_rs = $self->{schema}->('Enctype')->find (\%search); + unless (defined $enctype_rs) { die "unknown encryption type $enctype\n"; } - $sql = 'insert into keytab_enctypes (ke_name, ke_enctype) values - (?, ?)'; - $self->{dbh}->do ($sql, undef, $name, $enctype); + my %record = (ke_name => $name, + ke_enctype => $enctype); + $self->{schema}->resultset('Enctype')->create (\%record); $self->log_set ('type_data enctypes', undef, $enctype, @trace); } - $self->{dbh}->commit; + $guard->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } return 1; @@ -92,19 +99,16 @@ sub enctypes_list { my ($self) = @_; my @enctypes; eval { - my $sql = 'select ke_enctype from keytab_enctypes where ke_name = ? - order by ke_enctype'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{name}); - my $entry; - while (defined ($entry = $sth->fetchrow_arrayref)) { - push (@enctypes, @$entry); + 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); } - $self->{dbh}->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } return @enctypes; @@ -132,21 +136,21 @@ sub sync_set { $self->error ("unsupported synchronization target $target"); return; } else { + my $guard = $self->{schema}->txn_scope_guard; eval { - my $sql = 'select ks_target from keytab_sync where ks_name = ?'; - my $dbh = $self->{dbh}; my $name = $self->{name}; - my ($result) = $dbh->selectrow_array ($sql, undef, $name); - if ($result) { - my $sql = 'delete from keytab_sync where ks_name = ?'; - $self->{dbh}->do ($sql, undef, $name); - $self->log_set ('type_data sync', $result, undef, @trace); + 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); } - $self->{dbh}->commit; + $guard->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } } @@ -161,19 +165,16 @@ sub sync_list { my ($self) = @_; my @targets; eval { - my $sql = 'select ks_target from keytab_sync where ks_name = ? - order by ks_target'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{name}); - my $target; - while (defined ($target = $sth->fetchrow_array)) { - push (@targets, $target); + 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); } - $self->{dbh}->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } return @targets; @@ -238,21 +239,16 @@ sub attr_show { # Override new to start by creating a handle for the kadmin module we're # using. sub new { - my ($class, $type, $name, $dbh) = @_; + my ($class, $type, $name, $schema) = @_; my $self = { - dbh => $dbh, + schema => $schema, kadmin => undef, }; bless $self, $class; my $kadmin = Wallet::Kadmin->new (); $self->{kadmin} = $kadmin; - # Set a callback for things to do after a fork, specifically for the MIT - # kadmin module which forks to kadmin. - my $callback = sub { $self->{dbh}->{InactiveDestroy} = 1 }; - $kadmin->fork_callback ($callback); - - $self = $class->SUPER::new ($type, $name, $dbh); + $self = $class->SUPER::new ($type, $name, $schema); $self->{kadmin} = $kadmin; return $self; } @@ -262,24 +258,20 @@ sub new { # great here since we don't have a way to communicate the error back to the # caller. sub create { - my ($class, $type, $name, $dbh, $creator, $host, $time) = @_; + my ($class, $type, $name, $schema, $creator, $host, $time) = @_; my $self = { - dbh => $dbh, + schema => $schema, kadmin => undef, }; bless $self, $class; my $kadmin = Wallet::Kadmin->new (); $self->{kadmin} = $kadmin; - # Set a callback for things to do after a fork, specifically for the MIT - # kadmin module which forks to kadmin. - my $callback = sub { $self->{dbh}->{InactiveDestroy} = 1 }; - $kadmin->fork_callback ($callback); - if (not $kadmin->create ($name)) { die $kadmin->error, "\n"; } - $self = $class->SUPER::create ($type, $name, $dbh, $creator, $host, $time); + $self = $class->SUPER::create ($type, $name, $schema, $creator, $host, + $time); $self->{kadmin} = $kadmin; return $self; } @@ -292,16 +284,21 @@ sub destroy { $self->error ("cannot destroy $id: object is locked"); return; } + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; eval { - my $sql = 'delete from keytab_sync where ks_name = ?'; - $self->{dbh}->do ($sql, undef, $self->{name}); - $sql = 'delete from keytab_enctypes where ke_name = ?'; - $self->{dbh}->do ($sql, undef, $self->{name}); - $self->{dbh}->commit; + 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 ($@); - $self->{dbh}->rollback; return; } my $kadmin = $self->{kadmin}; @@ -347,7 +344,7 @@ __END__ =for stopwords keytab API KDC keytabs HOSTNAME DATETIME enctypes enctype DBH metadata -unmanaged kadmin Allbery +unmanaged kadmin Allbery unlinked =head1 NAME @@ -357,7 +354,7 @@ Wallet::Object::Keytab - Keytab object implementation for wallet my @name = qw(keytab host/shell.example.com); my @trace = ($user, $host, time); - my $object = Wallet::Object::Keytab->create (@name, $dbh, @trace); + my $object = Wallet::Object::Keytab->create (@name, $schema, @trace); my $keytab = $object->get (@trace); $object->destroy (@trace); diff --git a/perl/Wallet/Object/WAKeyring.pm b/perl/Wallet/Object/WAKeyring.pm new file mode 100644 index 0000000..f33497c --- /dev/null +++ b/perl/Wallet/Object/WAKeyring.pm @@ -0,0 +1,370 @@ +# Wallet::Object::WAKeyring -- WebAuth keyring object implementation. +# +# Written by Russ Allbery <rra@stanford.edu> +# 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 <rra@stanford.edu> + +=cut diff --git a/perl/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm new file mode 100644 index 0000000..5e04b4f --- /dev/null +++ b/perl/Wallet/Policy/Stanford.pm @@ -0,0 +1,413 @@ +# Wallet::Policy::Stanford -- Stanford's wallet naming and ownership policy. +# +# Written by Russ Allbery <rra@stanford.edu> +# 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/sharedapps', + '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 '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"; + } + } 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 <rra@stanford.edu> + +=cut diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index 5a8dc52..b27a998 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -1,7 +1,8 @@ # Wallet::Report -- Wallet system reporting interface. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2013 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -16,12 +17,12 @@ use strict; use vars qw($VERSION); use Wallet::ACL; -use Wallet::Database; +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.03'; +$VERSION = '0.04'; ############################################################################## # Constructor, destructor, and accessors @@ -32,8 +33,8 @@ $VERSION = '0.03'; # exception if anything goes wrong. sub new { my ($class) = @_; - my $dbh = Wallet::Database->connect; - my $self = { dbh => $dbh }; + my $schema = Wallet::Schema->connect; + my $self = { schema => $schema }; bless ($self, $class); return $self; } @@ -41,7 +42,13 @@ sub new { # Returns the database handle (used mostly for testing). sub dbh { my ($self) = @_; - return $self->{dbh}; + 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. @@ -59,7 +66,7 @@ sub error { # Disconnect the database handle on object destruction to avoid warnings. sub DESTROY { my ($self) = @_; - $self->{dbh}->disconnect unless $self->{dbh}->{InactiveDestroy}; + $self->{schema}->storage->dbh->disconnect; } ############################################################################## @@ -69,18 +76,26 @@ sub DESTROY { # Return the SQL statement to find every object in the database. sub objects_all { my ($self) = @_; - my $sql = 'select ob_type, ob_name from objects order by ob_type, - ob_name'; - return $sql; + 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 $sql = 'select ob_type, ob_name from objects where ob_type=? order - by ob_type, ob_name'; - return ($sql, $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 @@ -89,28 +104,36 @@ sub objects_type { # match any ACLs, set an error and return undef. sub objects_owner { my ($self, $owner) = @_; - my ($sth); + my @objects; + + my %search; + my %options = (order_by => [ qw/ob_type ob_name/ ], + select => [ qw/ob_type ob_name/ ]); + if (lc ($owner) eq 'null') { - my $sql = 'select ob_type, ob_name from objects where ob_owner is null - order by objects.ob_type, objects.ob_name'; - return ($sql); + %search = (ob_owner => undef); } else { - my $acl = eval { Wallet::ACL->new ($owner, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($owner, $self->{schema}) }; return unless $acl; - my $sql = 'select ob_type, ob_name from objects where ob_owner = ? - order by objects.ob_type, objects.ob_name'; - return ($sql, $acl->id); + %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 $sql = 'select ob_type, ob_name from objects left join flags on - (objects.ob_type = flags.fl_type and objects.ob_name = flags.fl_name) - where flags.fl_flag = ? order by objects.ob_type, objects.ob_name'; - return ($sql, $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 @@ -120,22 +143,35 @@ sub objects_flag { # set an error and return the empty string. sub objects_acl { my ($self, $search) = @_; - my $acl = eval { Wallet::ACL->new ($search, $self->{dbh}) }; + my @objects; + + my $schema = $self->{schema}; + my $acl = eval { Wallet::ACL->new ($search, $schema) }; return unless $acl; - my $sql = 'select ob_type, ob_name from objects where ob_owner = ? or - ob_acl_get = ? or ob_acl_store = ? or ob_acl_show = ? or - ob_acl_destroy = ? or ob_acl_flags = ? order by objects.ob_type, - objects.ob_name'; - return ($sql, ($acl->id) x 6); + + 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 $sql = 'select ob_type, ob_name from objects where ob_downloaded_on - is null order by objects.ob_type, objects.ob_name'; - return ($sql); + 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 @@ -148,46 +184,44 @@ sub objects { my ($self, $type, @args) = @_; undef $self->{error}; - # Find the SQL statement and the arguments to use. - my $sql = ''; - my @search = (); + # Get the search and options array refs from specific functions. + my ($search_ref, $options_ref); if (!defined $type || $type eq '') { - ($sql) = $self->objects_all; + ($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') { - ($sql, @search) = $self->objects_type (@args); + ($search_ref, $options_ref) = $self->objects_type (@args); } elsif ($type eq 'owner') { - ($sql, @search) = $self->objects_owner (@args); + ($search_ref, $options_ref) = $self->objects_owner (@args); } elsif ($type eq 'flag') { - ($sql, @search) = $self->objects_flag (@args); + ($search_ref, $options_ref) = $self->objects_flag (@args); } elsif ($type eq 'acl') { - ($sql, @search) = $self->objects_acl (@args); + ($search_ref, $options_ref) = $self->objects_acl (@args); } elsif ($type eq 'unused') { - ($sql) = $self->objects_unused (@args); + ($search_ref, $options_ref) = $self->objects_unused (@args); } else { $self->error ("do not know search type: $type"); } - return unless $sql; + return unless $search_ref; } - # Do the search. + # Perform the search and return on any errors. my @objects; + my $schema = $self->{schema}; eval { - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (@search); - my $object; - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@objects, [ @$object ]); + 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 ]); } - $self->{dbh}->commit; }; if ($@) { $self->error ("cannot list objects: $@"); - $self->{dbh}->rollback; return; } + return @objects; } @@ -199,17 +233,51 @@ sub objects { # database. sub acls_all { my ($self) = @_; - my $sql = 'select ac_id, ac_name from acls order by ac_id'; - return ($sql); + 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 $sql = 'select ac_id, ac_name from acls left join acl_entries - on (acls.ac_id = acl_entries.ae_id) where ae_id is null order by - ac_id'; - return ($sql); + 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 @@ -217,29 +285,76 @@ sub acls_empty { # do a substring search. sub acls_entry { my ($self, $type, $identifier) = @_; - my $sql = 'select distinct ac_id, ac_name from acl_entries left join acls - on (ae_id = ac_id) where ae_scheme = ? and ae_identifier like ? order - by ac_id'; - return ($sql, $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 $sql = 'select ac_id, ac_name from acls where not ac_id in (select - ob_owner from objects where ob_owner = ac_id)'; - for my $acl (qw/get store show destroy flags/) { - $sql .= " and not ac_id in (select ob_acl_$acl from objects where - ob_acl_$acl = ac_id)"; + 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 ($sql); + 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->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -290,11 +405,10 @@ sub acls { my ($self, $type, @args) = @_; undef $self->{error}; - # Find the SQL statement and the arguments to use. - my $sql; - my @search = (); + # Find the ACLs for any given search. + my @acls; if (!defined $type || $type eq '') { - ($sql) = $self->acls_all; + @acls = $self->acls_all; } else { if ($type eq 'duplicate') { return $self->acls_duplicate; @@ -303,34 +417,17 @@ sub acls { $self->error ('ACL searches require an argument to search'); return; } else { - ($sql, @search) = $self->acls_entry (@args); + @acls = $self->acls_entry (@args); } } elsif ($type eq 'empty') { - ($sql) = $self->acls_empty; + @acls = $self->acls_empty; } elsif ($type eq 'unused') { - ($sql) = $self->acls_unused; + @acls = $self->acls_unused; } else { $self->error ("unknown search type: $type"); return; } } - - # Do the search. - my @acls; - eval { - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (@search); - my $object; - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@acls, [ @$object ]); - } - $self->{dbh}->commit; - }; - if ($@) { - $self->error ("cannot list ACLs: $@"); - $self->{dbh}->rollback; - return; - } return @acls; } @@ -343,26 +440,32 @@ sub acls { sub owners { my ($self, $type, $name) = @_; undef $self->{error}; - my @lines; + my $schema = $self->{schema}; + + my @owners; eval { - my $sql = 'select distinct ae_scheme, ae_identifier from acl_entries, - acls, objects where ae_id = ac_id and ac_id = ob_owner and - ob_type like ? and ob_name like ? order by ae_scheme, - ae_identifier'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($type, $name); - my $object; - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@lines, [ @$object ]); + 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 ]); } - $self->{dbh}->commit; }; if ($@) { $self->error ("cannot report on owners: $@"); - $self->{dbh}->rollback; return; } - return @lines; + return @owners; } ############################################################################## diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index 25d48cf..fc63447 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -1,207 +1,97 @@ -# Wallet::Schema -- Database schema for the wallet system. +# Database schema and connector for the wallet system. # -# Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# 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. -############################################################################## -# Modules and declarations -############################################################################## - package Wallet::Schema; -require 5.006; use strict; -use vars qw(@SQL @TABLES $VERSION); +use warnings; -use DBI; +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. -$VERSION = '0.06'; +our $VERSION = '0.08'; + +__PACKAGE__->load_namespaces; +__PACKAGE__->load_components (qw/Schema::Versioned/); ############################################################################## -# Data manipulation +# Core overrides ############################################################################## -# Create a new Wallet::Schema object, parse the SQL out of the documentation, -# and store it in the object. We have to store the SQL in a static variable, -# since we can't read DATA multiple times. -sub new { +# 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 (@SQL) { - local $_; - my $found; - my $command = ''; - while (<DATA>) { - if (not $found and /^=head1 SCHEMA/) { - $found = 1; - } elsif ($found and /^=head1 /) { - last; - } elsif ($found and /^ /) { - s/^ //; - $command .= $_; - if (/;$/) { - push (@SQL, $command); - $command = ''; - } - } - } - close DATA; + 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 $self = { sql => [ @SQL ] }; - bless ($self, $class); - return $self; -} - -# Returns the SQL as a list of commands. -sub sql { - my ($self) = @_; - return @{ $self->{sql} }; -} - -############################################################################## -# Initialization and cleanup -############################################################################## - -# Given a database handle, try to create our database by running the SQL. Do -# this in a transaction regardless of the database settings and throw an -# exception if this fails. We have to do a bit of fiddling to get syntax that -# works with both MySQL and SQLite. -sub create { - my ($self, $dbh) = @_; - my $driver = $dbh->{Driver}->{Name}; - eval { - $dbh->begin_work if $dbh->{AutoCommit}; - my @sql = @{ $self->{sql} }; - for my $sql (@sql) { - if ($driver eq 'SQLite') { - $sql =~ s{auto_increment primary key} - {primary key autoincrement}; - } elsif ($driver eq 'mysql' and $sql =~ /^\s*create\s+table\s/) { - $sql =~ s/;$/ engine=InnoDB;/; - } - $dbh->do ($sql, { RaiseError => 1, PrintError => 0 }); - } - $dbh->commit; - }; - if ($@) { - $dbh->rollback; - die "$@\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; } -} - -# Given a database handle, try to remove the wallet database tables by -# reversing the SQL. Do this in a transaction regardless of the database -# settings and throw an exception if this fails. -sub drop { - my ($self, $dbh) = @_; - my @drop = map { - if (/^\s*create\s+table\s+(\S+)/i) { - "drop table if exists $1;"; - } else { - (); - } - } reverse @{ $self->{sql} }; - eval { - $dbh->begin_work if $dbh->{AutoCommit}; - for my $sql (@drop) { - $dbh->do ($sql, { RaiseError => 1, PrintError => 0 }); - } - $dbh->commit; - }; + 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 ($@) { - $dbh->rollback; - die "$@\n"; + die "cannot connect to database: $@\n"; } + return $schema; } +__END__ + +1; + ############################################################################## -# Schema +# Documentation ############################################################################## -# The following POD is also parsed by the code to extract SQL blocks. Don't -# add any verbatim blocks to this documentation in the SCHEMA section that -# aren't intended to be SQL. - -1; -__DATA__ +=for stopwords +RaiseError PrintError AutoCommit ACL verifier API APIs enums keytab backend +enctypes DBI Allbery =head1 NAME -Wallet::Schema - Database schema for the wallet system - -=for stopwords -SQL ACL API APIs enums Enums Keytab Backend keytab backend enctypes -enctype Allbery +Wallet::Schema - Database schema and connector for the wallet system =head1 SYNOPSIS use Wallet::Schema; - my $schema = Wallet::Schema->new; - my @sql = $schema->sql; - $schema->create ($dbh); + 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 Perl -object extracts the schema from the documentation and can either return it -as a list of SQL commands to run or run those commands given a connected -database handle. - -This schema attempts to be portable SQL, but it is designed for use with -MySQL and may require some modifications for other databases. +documentation you're reading explains and comments the schema. The +class runs using the DBIx::Class module. -=head1 METHODS - -=over 4 - -=item new() - -Instantiates a new Wallet::Schema object. This parses the documentation -and extracts the schema, but otherwise doesn't do anything. - -=item create(DBH) - -Given a connected database handle, runs the SQL commands necessary to -create the wallet database in an otherwise empty database. This method -will not drop any existing tables and will therefore fail if a wallet -database has already been created. On any error, this method will throw a -database exception. - -=item drop(DBH) - -Given a connected database handle, drop all of the wallet tables from that -database if any of those tables exist. This method will only remove -tables that are part of the current schema or one of the previous known -schema and won't remove other tables. On any error, this method will -throw a database exception. - -=item sql() - -Returns the schema and the population of the normalization tables as a -list of SQL commands to run to create the wallet database in an otherwise -empty database. - -=back +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 -The following are normalization tables used to constrain the values in -other tables. - -Holds the supported flag names: - - create table flag_names - (fn_name varchar(32) primary key); - insert into flag_names (fn_name) values ('locked'); - insert into flag_names (fn_name) values ('unchanging'); - Holds the supported object types and their corresponding Perl classes: create table types @@ -222,6 +112,8 @@ Holds the supported ACL schemes and their corresponding Perl classes: 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'); @@ -314,6 +206,7 @@ table: 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); @@ -332,8 +225,8 @@ object may have zero or more flags associated with it: not null references objects(ob_type), fl_name varchar(255) not null references objects(ob_name), - fl_flag varchar(32) - not null references flag_names(fn_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); @@ -419,9 +312,22 @@ 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-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/>. diff --git a/perl/Wallet/Schema/Result/Acl.pm b/perl/Wallet/Schema/Result/Acl.pm new file mode 100644 index 0000000..226738a --- /dev/null +++ b/perl/Wallet/Schema/Result/Acl.pm @@ -0,0 +1,110 @@ +# Wallet schema for an ACL. +# +# Written by Jon Robertson <jonrober@stanford.edu> +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Acl; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +ACL + +=head1 NAME + +Wallet::Schema::Result::Acl - Wallet schema for an ACL + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("acls"); + +=head1 ACCESSORS + +=head2 ac_id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + +=head2 ac_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "ac_id", + { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, + "ac_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("ac_id"); +__PACKAGE__->add_unique_constraint("ac_name", ["ac_name"]); + +__PACKAGE__->has_one( + 'acl_entries', + 'Wallet::Schema::Result::AclEntry', + { 'foreign.ae_id' => 'self.ac_id' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); +__PACKAGE__->has_many( + 'acl_history', + 'Wallet::Schema::Result::AclHistory', + { 'foreign.ah_id' => 'self.ac_id' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); + +# References for all of the various potential ACLs in owners. +__PACKAGE__->has_many( + 'acls_owner', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_owner' => 'self.ac_id' }, + ); +__PACKAGE__->has_many( + 'acls_get', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_acl_get' => 'self.ac_id' }, + ); +__PACKAGE__->has_many( + 'acls_store', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_acl_store' => 'self.ac_id' }, + ); +__PACKAGE__->has_many( + 'acls_show', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_acl_show' => 'self.ac_id' }, + ); +__PACKAGE__->has_many( + 'acls_destroy', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_acl_destroy' => 'self.ac_id' }, + ); +__PACKAGE__->has_many( + 'acls_flags', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_acl_flags' => 'self.ac_id' }, + ); + +# Override the insert method so that we can automatically create history +# items. +#sub insert { +# my ($self, @args) = @_; +# my $ret = $self->next::method (@args); +# print "ID: ".$self->ac_id."\n"; +# use Data::Dumper; print Dumper (@args); + +# return $self; +#} + +1; diff --git a/perl/Wallet/Schema/Result/AclEntry.pm b/perl/Wallet/Schema/Result/AclEntry.pm new file mode 100644 index 0000000..a33a98c --- /dev/null +++ b/perl/Wallet/Schema/Result/AclEntry.pm @@ -0,0 +1,74 @@ +# Wallet schema for an entry in an ACL. +# +# Written by Jon Robertson <jonrober@stanford.edu> +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::AclEntry; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +ACL + +=head1 NAME + +Wallet::Schema::Result::AclEntry - Wallet schema for an entry in an ACL + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("acl_entries"); + +=head1 ACCESSORS + +=head2 ae_id + + data_type: 'integer' + is_nullable: 0 + +=head2 ae_scheme + + data_type: 'varchar' + is_nullable: 0 + size: 32 + +=head2 ae_identifier + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "ae_id", + { data_type => "integer", is_nullable => 0 }, + "ae_scheme", + { data_type => "varchar", is_nullable => 0, size => 32 }, + "ae_identifier", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("ae_id", "ae_scheme", "ae_identifier"); + +__PACKAGE__->belongs_to( + 'acls', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ae_id' }, + { is_deferrable => 1, on_delete => 'CASCADE', + on_update => 'CASCADE' }, + ); + +__PACKAGE__->has_one( + 'acl_scheme', + 'Wallet::Schema::Result::AclScheme', + { 'foreign.as_name' => 'self.ae_scheme' }, + { cascade_delete => 0 }, + ); +1; diff --git a/perl/Wallet/Schema/Result/AclHistory.pm b/perl/Wallet/Schema/Result/AclHistory.pm new file mode 100644 index 0000000..d3ef901 --- /dev/null +++ b/perl/Wallet/Schema/Result/AclHistory.pm @@ -0,0 +1,112 @@ +# Wallet schema for ACL history. +# +# 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::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"); + +__PACKAGE__->might_have( + 'acls', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ah_id' }, + ); + +1; diff --git a/perl/Wallet/Schema/Result/AclScheme.pm b/perl/Wallet/Schema/Result/AclScheme.pm new file mode 100644 index 0000000..91a58b2 --- /dev/null +++ b/perl/Wallet/Schema/Result/AclScheme.pm @@ -0,0 +1,84 @@ +# Wallet schema for ACL scheme. +# +# Written by Jon Robertson <jonrober@stanford.edu> +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::AclScheme; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; +__PACKAGE__->load_components (qw//); + +=for stopwords +ACL verifier APIs + +=head1 NAME + +Wallet::Schema::Result::AclScheme - Wallet schema for ACL scheme + +=head1 DESCRIPTION + +This is a normalization table used to constrain the values in other +tables. It contains the types of ACL schemes that Wallet will +recognize, and the modules that govern each of those schemes. + +By default it contains the following entries: + + insert into acl_schemes (as_name, as_class) + values ('krb5', 'Wallet::ACL::Krb5'); + insert into acl_schemes (as_name, as_class) + values ('krb5-regex', 'Wallet::ACL::Krb5::Regex'); + insert into acl_schemes (as_name, as_class) + values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute'); + insert into acl_schemes (as_name, as_class) + values ('netdb', 'Wallet::ACL::NetDB'); + insert into acl_schemes (as_name, as_class) + values ('netdb-root', 'Wallet::ACL::NetDB::Root'); + +If you have extended the wallet to support additional ACL schemes, you +will want to add additional rows to this table mapping those schemes +to Perl classes that implement the ACL verifier APIs. + +=cut + +__PACKAGE__->table("acl_schemes"); + +=head1 ACCESSORS + +=head2 as_name + + data_type: 'varchar' + is_nullable: 0 + size: 32 + +=head2 as_class + + data_type: 'varchar' + is_nullable: 1 + size: 64 + +=cut + +__PACKAGE__->add_columns( + "as_name", + { data_type => "varchar", is_nullable => 0, size => 32 }, + "as_class", + { data_type => "varchar", is_nullable => 1, size => 64 }, +); +__PACKAGE__->set_primary_key("as_name"); + +#__PACKAGE__->resultset->populate ([ +# [ qw/as_name as_class/ ], +# [ 'krb5', 'Wallet::ACL::Krb5' ], +# [ 'krb5-regex', 'Wallet::ACL::Krb5::Regex' ], +# [ 'ldap-attr', 'Wallet::ACL::LDAP::Attribute' ], +# [ 'netdb', 'Wallet::ACL::NetDB' ], +# [ 'netdb-root', 'Wallet::ACL::NetDB::Root' ], +# ]); + +1; diff --git a/perl/Wallet/Schema/Result/Enctype.pm b/perl/Wallet/Schema/Result/Enctype.pm new file mode 100644 index 0000000..5733669 --- /dev/null +++ b/perl/Wallet/Schema/Result/Enctype.pm @@ -0,0 +1,45 @@ +# Wallet schema for Kerberos encryption type. +# +# Written by Jon Robertson <jonrober@stanford.edu> +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Enctype; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +Kerberos + +=head1 NAME + +Wallet::Schema::Result::Enctype - Wallet schema for Kerberos encryption type + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("enctypes"); + +=head1 ACCESSORS + +=head2 en_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "en_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("en_name"); + +1; diff --git a/perl/Wallet/Schema/Result/Flag.pm b/perl/Wallet/Schema/Result/Flag.pm new file mode 100644 index 0000000..e223ff8 --- /dev/null +++ b/perl/Wallet/Schema/Result/Flag.pm @@ -0,0 +1,62 @@ +# Wallet schema for object flags. +# +# Written by Jon Robertson <jonrober@stanford.edu> +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Flag; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::Flag - Wallet schema for object flags + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("flags"); + +=head1 ACCESSORS + +=head2 fl_type + + data_type: 'varchar' + is_nullable: 0 + size: 16 + +=head2 fl_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 fl_flag + + data_type: 'varchar' + is_nullable: 0 + size: 32 + +=cut + +__PACKAGE__->add_columns( + "fl_type" => + { data_type => "varchar", is_nullable => 0, size => 16 }, + "fl_name" => + { data_type => "varchar", is_nullable => 0, size => 255 }, + "fl_flag" => { + data_type => 'enum', + is_enum => 1, + extra => { list => [qw/locked unchanging/] }, + }, +); +__PACKAGE__->set_primary_key("fl_type", "fl_name", "fl_flag"); + + +1; diff --git a/perl/Wallet/Schema/Result/KeytabEnctype.pm b/perl/Wallet/Schema/Result/KeytabEnctype.pm new file mode 100644 index 0000000..daea724 --- /dev/null +++ b/perl/Wallet/Schema/Result/KeytabEnctype.pm @@ -0,0 +1,53 @@ +# Wallet schema for keytab enctype. +# +# Written by Jon Robertson <jonrober@stanford.edu> +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::KeytabEnctype; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +keytab enctype + +=head1 NAME + +Wallet::Schema::Result::KeytabEnctype - Wallet schema for keytab enctype + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("keytab_enctypes"); + +=head1 ACCESSORS + +=head2 ke_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ke_enctype + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "ke_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ke_enctype", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("ke_name", "ke_enctype"); + +1; diff --git a/perl/Wallet/Schema/Result/KeytabSync.pm b/perl/Wallet/Schema/Result/KeytabSync.pm new file mode 100644 index 0000000..ca84277 --- /dev/null +++ b/perl/Wallet/Schema/Result/KeytabSync.pm @@ -0,0 +1,53 @@ +# Wallet schema for keytab synchronization. +# +# Written by Jon Robertson <jonrober@stanford.edu> +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::KeytabSync; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +keytab + +=head1 NAME + +Wallet::Schema::Result::KeytabSync - Wallet schema for keytab synchronization + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("keytab_sync"); + +=head1 ACCESSORS + +=head2 ks_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ks_target + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "ks_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ks_target", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("ks_name", "ks_target"); + +1; diff --git a/perl/Wallet/Schema/Result/Object.pm b/perl/Wallet/Schema/Result/Object.pm new file mode 100644 index 0000000..fd64e1b --- /dev/null +++ b/perl/Wallet/Schema/Result/Object.pm @@ -0,0 +1,266 @@ +# Wallet schema for an object. +# +# Written by Jon Robertson <jonrober@stanford.edu> +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Object; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("InflateColumn::DateTime"); + +=head1 NAME + +Wallet::Schema::Result::Object - Wallet schema for an object + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("objects"); + +=head1 ACCESSORS + +=head2 ob_type + + data_type: 'varchar' + is_nullable: 0 + size: 16 + +=head2 ob_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ob_owner + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_acl_get + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_acl_store + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_acl_show + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_acl_destroy + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_acl_flags + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_expires + + data_type: 'datetime' + datetime_undef_if_invalid: 1 + is_nullable: 1 + +=head2 ob_created_by + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ob_created_from + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ob_created_on + + data_type: 'datetime' + datetime_undef_if_invalid: 1 + is_nullable: 0 + +=head2 ob_stored_by + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 ob_stored_from + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 ob_stored_on + + data_type: 'datetime' + datetime_undef_if_invalid: 1 + is_nullable: 1 + +=head2 ob_downloaded_by + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 ob_downloaded_from + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 ob_downloaded_on + + data_type: 'datetime' + datetime_undef_if_invalid: 1 + is_nullable: 1 + +=head2 ob_comment + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "ob_type", + { data_type => "varchar", is_nullable => 0, size => 16 }, + "ob_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ob_owner", + { data_type => "integer", is_nullable => 1 }, + "ob_acl_get", + { data_type => "integer", is_nullable => 1 }, + "ob_acl_store", + { data_type => "integer", is_nullable => 1 }, + "ob_acl_show", + { data_type => "integer", is_nullable => 1 }, + "ob_acl_destroy", + { data_type => "integer", is_nullable => 1 }, + "ob_acl_flags", + { data_type => "integer", is_nullable => 1 }, + "ob_expires", + { + data_type => "datetime", + datetime_undef_if_invalid => 1, + is_nullable => 1, + }, + "ob_created_by", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ob_created_from", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ob_created_on", + { + data_type => "datetime", + datetime_undef_if_invalid => 1, + is_nullable => 0, + }, + "ob_stored_by", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "ob_stored_from", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "ob_stored_on", + { + data_type => "datetime", + datetime_undef_if_invalid => 1, + is_nullable => 1, + }, + "ob_downloaded_by", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "ob_downloaded_from", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "ob_downloaded_on", + { + data_type => "datetime", + datetime_undef_if_invalid => 1, + is_nullable => 1, + }, + "ob_comment", + { data_type => "varchar", is_nullable => 1, size => 255 }, +); +__PACKAGE__->set_primary_key("ob_name", "ob_type"); + +__PACKAGE__->has_one( + 'types', + 'Wallet::Schema::Result::Type', + { 'foreign.ty_name' => 'self.ob_type' }, + ); + +__PACKAGE__->has_many( + 'flags', + 'Wallet::Schema::Result::Flag', + { 'foreign.fl_type' => 'self.ob_type', + 'foreign.fl_name' => 'self.ob_name' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); + +__PACKAGE__->has_many( + 'object_history', + 'Wallet::Schema::Result::ObjectHistory', + { 'foreign.oh_type' => 'self.ob_type', + 'foreign.oh_name' => 'self.ob_name' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); + +__PACKAGE__->has_many( + 'keytab_enctypes', + 'Wallet::Schema::Result::KeytabEnctype', + { 'foreign.ke_name' => 'self.ob_name' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); + +__PACKAGE__->has_many( + 'keytab_sync', + 'Wallet::Schema::Result::KeytabSync', + { 'foreign.ks_name' => 'self.ob_name' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); + +# References for all of the various potential ACLs. +__PACKAGE__->belongs_to( + 'acls_owner', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_owner' }, + ); +__PACKAGE__->belongs_to( + 'acls_get', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_acl_get' }, + ); +__PACKAGE__->belongs_to( + 'acls_store', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_acl_store' }, + ); +__PACKAGE__->belongs_to( + 'acls_show', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_acl_show' }, + ); +__PACKAGE__->belongs_to( + 'acls_destroy', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_acl_destroy' }, + ); +__PACKAGE__->belongs_to( + 'acls_flags', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_acl_flags' }, + ); + +1; diff --git a/perl/Wallet/Schema/Result/ObjectHistory.pm b/perl/Wallet/Schema/Result/ObjectHistory.pm new file mode 100644 index 0000000..9cbb159 --- /dev/null +++ b/perl/Wallet/Schema/Result/ObjectHistory.pm @@ -0,0 +1,135 @@ +# Wallet schema for object history. +# +# 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::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"); + +__PACKAGE__->might_have( + 'objects', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_type' => 'self.oh_type', + 'foreign.ob_name' => 'self.oh_name' }, + ); + +1; diff --git a/perl/Wallet/Schema/Result/SyncTarget.pm b/perl/Wallet/Schema/Result/SyncTarget.pm new file mode 100644 index 0000000..4300a54 --- /dev/null +++ b/perl/Wallet/Schema/Result/SyncTarget.pm @@ -0,0 +1,48 @@ +# Wallet schema for synchronization targets. +# +# Written by Jon Robertson <jonrober@stanford.edu> +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::SyncTarget; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::SyncTarget - Wallet schema for synchronization targets + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("sync_targets"); + +=head1 ACCESSORS + +=head2 st_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "st_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("st_name"); + +#__PACKAGE__->has_many( +# 'keytab_sync', +# 'Wallet::Schema::Result::KeytabSync', +# { 'foreign.ks_target' => 'self.st_name' }, +# { cascade_copy => 0, cascade_delete => 0 }, +# ); +1; diff --git a/perl/Wallet/Schema/Result/Type.pm b/perl/Wallet/Schema/Result/Type.pm new file mode 100644 index 0000000..748a8a8 --- /dev/null +++ b/perl/Wallet/Schema/Result/Type.pm @@ -0,0 +1,75 @@ +# Wallet schema for object types. +# +# Written by Jon Robertson <jonrober@stanford.edu> +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Type; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +APIs + +=head1 NAME + +Wallet::Schema::Result::Type - Wallet schema for object types + +=head1 DESCRIPTION + +This is a normalization table used to constrain the values in other +tables. It contains the types of wallet objects that are considered +valid, and the modules that govern each. + +By default it contains the following entries: + + insert into types (ty_name, ty_class) + values ('file', 'Wallet::Object::File'); + insert into types (ty_name, ty_class) + values ('keytab', 'Wallet::Object::Keytab'); + +If you have extended the wallet to support additional object types , +you will want to add additional rows to this table mapping those types +to Perl classes that implement the object APIs. + +=cut + +__PACKAGE__->table("types"); + +=head1 ACCESSORS + +=head2 ty_name + + data_type: 'varchar' + is_nullable: 0 + size: 16 + +=head2 ty_class + + data_type: 'varchar' + is_nullable: 1 + size: 64 + +=cut + +__PACKAGE__->add_columns( + "ty_name", + { data_type => "varchar", is_nullable => 0, size => 16 }, + "ty_class", + { data_type => "varchar", is_nullable => 1, size => 64 }, +); +__PACKAGE__->set_primary_key("ty_name"); + +#__PACKAGE__->has_many( +# 'objects', +# 'Wallet::Schema::Result::Object', +# { 'foreign.ob_type' => 'self.ty_name' }, +# { cascade_copy => 0, cascade_delete => 0 }, +# ); + +1; diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm index 185bf23..6d67e17 100644 --- a/perl/Wallet/Server.pm +++ b/perl/Wallet/Server.pm @@ -1,7 +1,8 @@ # Wallet::Server -- Wallet system server implementation. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2010, 2011, 2013 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -17,13 +18,12 @@ use vars qw(%MAPPING $VERSION); use Wallet::ACL; use Wallet::Config; -use Wallet::Database; 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.09'; +$VERSION = '0.11'; ############################################################################## # Utility methods @@ -37,13 +37,13 @@ $VERSION = '0.09'; # for various things. Throw an exception if anything goes wrong. sub new { my ($class, $user, $host) = @_; - my $dbh = Wallet::Database->connect; - my $acl = Wallet::ACL->new ('ADMIN', $dbh); + my $schema = Wallet::Schema->connect; + my $acl = Wallet::ACL->new ('ADMIN', $schema); my $self = { - dbh => $dbh, - user => $user, - host => $host, - admin => $acl, + schema => $schema, + user => $user, + host => $host, + admin => $acl, }; bless ($self, $class); return $self; @@ -52,7 +52,13 @@ sub new { # Returns the database handle (used mostly for testing). sub dbh { my ($self) = @_; - return $self->{dbh}; + 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. @@ -70,8 +76,9 @@ sub error { # Disconnect the database handle on object destruction to avoid warnings. sub DESTROY { my ($self) = @_; - if ($self->{dbh} and not $self->{dbh}->{InactiveDestroy}) { - $self->{dbh}->disconnect; + + if ($self->{schema}) { + $self->{schema}->storage->dbh->disconnect; } } @@ -85,13 +92,14 @@ sub type_mapping { my ($self, $type) = @_; my $class; eval { - my $sql = 'select ty_class from types where ty_name = ?'; - ($class) = $self->{dbh}->selectrow_array ($sql, undef, $type); - $self->{dbh}->commit; + 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 ($@); - $self->{dbh}->rollback; return; } if (defined $class) { @@ -116,7 +124,7 @@ sub create_check { my ($self, $type, $name) = @_; my $user = $self->{user}; my $host = $self->{host}; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; unless (defined (&Wallet::Config::default_owner)) { $self->error ("$user not authorized to create ${type}:${name}"); return; @@ -126,9 +134,9 @@ sub create_check { $self->error ("$user not authorized to create ${type}:${name}"); return; } - my $acl = eval { Wallet::ACL->new ($aname, $dbh) }; + my $acl = eval { Wallet::ACL->new ($aname, $schema) }; if ($@) { - $acl = eval { Wallet::ACL->create ($aname, $dbh, $user, $host) }; + $acl = eval { Wallet::ACL->create ($aname, $schema, $user, $host) }; if ($@) { $self->error ($@); return; @@ -179,10 +187,10 @@ sub create_object { $self->error ("unknown object type $type"); return; } - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my $user = $self->{user}; my $host = $self->{host}; - my $object = eval { $class->create ($type, $name, $dbh, $user, $host) }; + my $object = eval { $class->create ($type, $name, $schema, $user, $host) }; if ($@) { $self->error ($@); return; @@ -244,7 +252,7 @@ sub retrieve { $self->error ("unknown object type $type"); return; } - my $object = eval { $class->new ($type, $name, $self->{dbh}) }; + my $object = eval { $class->new ($type, $name, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -274,9 +282,11 @@ sub object_error { # 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_check { +sub acl_verify { my ($self, $object, $action) = @_; - unless ($action =~ /^(get|store|show|destroy|flags|setattr|getattr)\z/) { + my %actions = map { $_ => 1 } + qw(get store show destroy flags setattr getattr comment); + unless ($actions{$action}) { $self->error ("unknown action $action"); return; } @@ -288,17 +298,17 @@ sub acl_check { $id = $object->acl ('show'); } elsif ($action eq 'setattr') { $id = $object->acl ('store'); - } else { + } elsif ($action ne 'comment') { $id = $object->acl ($action); } - if (! defined ($id) and $action =~ /^(get|(get|set)attr|store|show)\z/) { + 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->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -346,7 +356,7 @@ sub attr { my $user = $self->{user}; my $host = $self->{host}; if (@values) { - return unless $self->acl_check ($object, 'setattr'); + return unless $self->acl_verify ($object, 'setattr'); if (@values == 1 and $values[0] eq '') { @values = (); } @@ -354,7 +364,7 @@ sub attr { $self->error ($object->error) unless $result; return $result; } else { - return unless $self->acl_check ($object, 'getattr'); + return unless $self->acl_verify ($object, 'getattr'); my @result = $object->attr ($attr); if (not @result and $object->error) { $self->error ($object->error); @@ -365,6 +375,26 @@ sub attr { } } +# 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) = @_; @@ -433,7 +463,7 @@ sub get { my ($self, $type, $name) = @_; my $object = $self->retrieve ($type, $name); return unless defined $object; - return unless $self->acl_check ($object, 'get'); + return unless $self->acl_verify ($object, 'get'); my $result = $object->get ($self->{user}, $self->{host}); $self->error ($object->error) unless defined $result; return $result; @@ -448,7 +478,7 @@ sub store { my ($self, $type, $name, $data) = @_; my $object = $self->retrieve ($type, $name); return unless defined $object; - return unless $self->acl_check ($object, 'store'); + return unless $self->acl_verify ($object, 'store'); if (not defined ($data)) { $self->{error} = "no data supplied to store"; return; @@ -465,7 +495,7 @@ sub show { my ($self, $type, $name) = @_; my $object = $self->retrieve ($type, $name); return unless defined $object; - return unless $self->acl_check ($object, 'show'); + return unless $self->acl_verify ($object, 'show'); my $result = $object->show; $self->error ($object->error) unless defined $result; return $result; @@ -478,7 +508,7 @@ sub history { my ($self, $type, $name) = @_; my $object = $self->retrieve ($type, $name); return unless defined $object; - return unless $self->acl_check ($object, 'show'); + return unless $self->acl_verify ($object, 'show'); my $result = $object->history; $self->error ($object->error) unless defined $result; return $result; @@ -490,7 +520,7 @@ sub destroy { my ($self, $type, $name) = @_; my $object = $self->retrieve ($type, $name); return unless defined $object; - return unless $self->acl_check ($object, 'destroy'); + return unless $self->acl_verify ($object, 'destroy'); my $result = $object->destroy ($self->{user}, $self->{host}); $self->error ($object->error) unless defined $result; return $result; @@ -506,7 +536,7 @@ sub flag_clear { my ($self, $type, $name, $flag) = @_; my $object = $self->retrieve ($type, $name); return unless defined $object; - return unless $self->acl_check ($object, 'flags'); + 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; @@ -518,7 +548,7 @@ sub flag_set { my ($self, $type, $name, $flag) = @_; my $object = $self->retrieve ($type, $name); return unless defined $object; - return unless $self->acl_check ($object, 'flags'); + 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; @@ -528,6 +558,22 @@ sub flag_set { # 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 { @@ -545,8 +591,8 @@ sub acl_create { return; } } - my $dbh = $self->{dbh}; - my $acl = eval { Wallet::ACL->create ($name, $dbh, $user, $host) }; + my $schema = $self->{schema}; + my $acl = eval { Wallet::ACL->create ($name, $schema, $user, $host) }; if ($@) { $self->error ($@); return; @@ -577,7 +623,7 @@ sub acl_history { $self->acl_error ($id, 'history'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -597,7 +643,7 @@ sub acl_show { $self->acl_error ($id, 'show'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -618,7 +664,7 @@ sub acl_rename { $self->acl_error ($id, 'rename'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -649,7 +695,7 @@ sub acl_destroy { $self->acl_error ($id, 'destroy'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -673,7 +719,7 @@ sub acl_add { $self->acl_error ($id, 'add'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -693,7 +739,7 @@ sub acl_remove { $self->acl_error ($id, 'remove'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -730,7 +776,7 @@ Wallet::Server - Wallet system server implementation =for stopwords keytabs metadata backend HOSTNAME ACL timestamp ACL's nul Allbery -backend-specific wallet-backend +backend-specific wallet-backend verifier =head1 SYNOPSIS @@ -895,6 +941,20 @@ 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 @@ -910,9 +970,10 @@ owner as determined by the wallet configuration. 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 authorized -by the ADMIN ACL or the destroy ACL on the object; the owner ACL is not -sufficient. Returns true on success and false on failure. +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() @@ -933,12 +994,12 @@ 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, that -ACL wasn't set; otherwise, error() will return the error message. +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 +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. @@ -994,6 +1055,10 @@ 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 |