diff options
Diffstat (limited to 'perl')
| -rw-r--r-- | perl/Wallet/ACL/Krb5/Regex.pm | 132 | ||||
| -rw-r--r-- | perl/Wallet/Report.pm | 101 | ||||
| -rw-r--r-- | perl/Wallet/Schema.pm | 2 | ||||
| -rwxr-xr-x | perl/t/kadmin.t | 2 | ||||
| -rwxr-xr-x | perl/t/keytab.t | 10 | ||||
| -rwxr-xr-x | perl/t/report.t | 85 | ||||
| -rwxr-xr-x | perl/t/schema.t | 2 | ||||
| -rwxr-xr-x | perl/t/verifier.t | 20 |
8 files changed, 332 insertions, 22 deletions
diff --git a/perl/Wallet/ACL/Krb5/Regex.pm b/perl/Wallet/ACL/Krb5/Regex.pm new file mode 100644 index 0000000..52f4bf5 --- /dev/null +++ b/perl/Wallet/ACL/Krb5/Regex.pm @@ -0,0 +1,132 @@ +# 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 +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::ACL::Krb5::Regex; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Wallet::ACL::Krb5; + +@ISA = qw(Wallet::ACL::Krb5); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.01'; + +############################################################################## +# Interface +############################################################################## + +# Returns true if the Perl regular expression specified by the ACL matches +# the provided Kerberos principal. +sub check { + my ($self, $principal, $acl) = @_; + unless ($principal) { + $self->error ('no principal specified'); + return; + } + unless ($acl) { + $self->error ('no ACL specified'); + return; + } + my $regex = eval { qr/$acl/ }; + if ($@) { + $self->error ('malformed krb5-regex ACL'); + return; + } + return ($principal =~ m/$regex/) ? 1 : 0; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +ACL krb5-regex Durkacz Allbery + +=head1 NAME + +Wallet::ACL::Krb5::Regex - Regex wallet ACL verifier for Kerberos principals + +=head1 SYNOPSIS + + my $verifier = Wallet::ACL::Krb5::Regex->new; + my $status = $verifier->check ($principal, $acl); + if (not defined $status) { + die "Something failed: ", $verifier->error, "\n"; + } elsif ($status) { + print "Access granted\n"; + } else { + print "Access denied\n"; + } + +=head1 DESCRIPTION + +Wallet::ACL::Krb5::Regex is the wallet ACL verifier used to verify ACL +lines of type C<krb5-regex>. The value of such an ACL is a Perl regular +expression, and the ACL grants access to a given Kerberos principal if and +only if the regular expression matches that principal. + +=head1 METHODS + +=over 4 + +=item new() + +Creates a new ACL verifier. For this verifier, there is no setup work. + +=item check(PRINCIPAL, ACL) + +Returns true if the Perl regular expression specified by the ACL matches the +PRINCIPAL, false if not, and undef on an error (see L<"DIAGNOSTICS"> below). + +=item error() + +Returns the error if check() returned undef. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item malformed krb5-regex ACL + +The ACL parameter to check() was a malformed Perl regular expression. + +=item no principal specified + +The PRINCIPAL parameter to check() was undefined or the empty string. + +=item no ACL specified + +The ACL parameter to check() was undefined or the empty string. + +=back + +=head1 SEE ALSO + +Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::ACL::Krb5(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L<http://www.eyrie.org/~eagle/software/wallet/>. + +=head1 AUTHOR + +Ian Durkacz + +=cut diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index c743060..5a8dc52 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -15,12 +15,13 @@ require 5.006; use strict; use vars qw($VERSION); +use Wallet::ACL; use Wallet::Database; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.02'; +$VERSION = '0.03'; ############################################################################## # Constructor, destructor, and accessors @@ -128,6 +129,15 @@ sub objects_acl { return ($sql, ($acl->id) x 6); } +# 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); +} + # Returns a list of all objects stored in the wallet database in the form of # type and name pairs. On error and for an empty database, the empty list # will be returned. To distinguish between an empty list and an error, call @@ -144,7 +154,7 @@ sub objects { if (!defined $type || $type eq '') { ($sql) = $self->objects_all; } else { - if (@args != 1) { + 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); @@ -154,6 +164,8 @@ sub objects { ($sql, @search) = $self->objects_flag (@args); } elsif ($type eq 'acl') { ($sql, @search) = $self->objects_acl (@args); + } elsif ($type eq 'unused') { + ($sql) = $self->objects_unused (@args); } else { $self->error ("do not know search type: $type"); } @@ -223,6 +235,52 @@ sub acls_unused { return ($sql); } +# 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}) }; + if ($@) { + $self->error ($@); + return; + } + my @members = map { "$_->[0] $_->[1]" } $acl->list; + if (!@members && $acl->error) { + $self->error ($acl->error); + return; + } + return join ("\n", @members); +} + +# Duplicate ACL detection unfortunately needs to do something more complex +# than just return a SQL statement, so it's handled differently than other +# reports. All the work is done here and the results returned as a list of +# sets of duplicates. +sub acls_duplicate { + my ($self) = @_; + my @acls = sort map { $_->[1] } $self->acls; + return if (!@acls && $self->{error}); + return if @acls < 2; + my %result; + for my $i (0 .. ($#acls - 1)) { + my $members = $self->acl_membership ($acls[$i]); + return unless defined $members; + for my $j (($i + 1) .. $#acls) { + my $check = $self->acl_membership ($acls[$j]); + return unless defined $check; + if ($check eq $members) { + $result{$acls[$i]} ||= []; + push (@{ $result{$acls[$i]} }, $acls[$j]); + } + } + } + my @result; + for my $acl (sort keys %result) { + push (@result, [ $acl, sort @{ $result{$acl} } ]); + } + return @result; +} + # Returns a list of all ACLs stored in the wallet database as a list of pairs # of ACL IDs and ACL names, possibly limited by some criteria. On error and # for an empty database, the empty list will be returned. To distinguish @@ -238,7 +296,9 @@ sub acls { if (!defined $type || $type eq '') { ($sql) = $self->acls_all; } else { - if ($type eq 'entry') { + if ($type eq 'duplicate') { + return $self->acls_duplicate; + } elsif ($type eq 'entry') { if (@args == 0) { $self->error ('ACL searches require an argument to search'); return; @@ -416,20 +476,28 @@ between an empty report and an error. Returns a list of all ACLs matching a search type and string in the database, or all ACLs if no search information is given. There are -currently three search types. C<empty> takes no arguments and will return -only those ACLs that have no entries within them. C<entry> takes two -arguments, an entry scheme and a (possibly partial) entry identifier, and -will return any ACLs containing an entry with that scheme and with an -identifier containing that value. C<unused> returns all ACLs that are not -referenced by any object. - -The return value is a list of references to pairs of ACL ID and name. For -example, if there are two ACLs in the database, one with name C<ADMIN> and -ID 1 and one with name C<group/admins> and ID 3, acls() with no arguments -would return: +currently four search types. C<duplicate> returns sets of duplicate ACLs +(ones with exactly the same entries). C<empty> takes no arguments and +will return only those ACLs that have no entries within them. C<entry> +takes two arguments, an entry scheme and a (possibly partial) entry +identifier, and will return any ACLs containing an entry with that scheme +and with an identifier containing that value. C<unused> returns all ACLs +that are not referenced by any object. + +The return value for everything except C<duplicate> is a list of +references to pairs of ACL ID and name. For example, if there are two +ACLs in the database, one with name C<ADMIN> and ID 1 and one with name +C<group/admins> and ID 3, acls() with no arguments would return: ([ 1, 'ADMIN' ], [ 3, 'group/admins' ]) +The return value for the C<duplicate> search is sets of ACL names that are +duplicates (have the same entries). For example, if C<d1>, C<d2>, and +C<d3> are all duplicates, and C<o1> and C<o2> are also duplicates, the +result would be: + + ([ 'd1', 'd2', 'd3' ], [ 'o1', 'o2' ]) + Returns the empty list on failure. An error can be distinguished from empty search results by calling error(). error() is guaranteed to return the error message if there was an error and undef if there was no error. @@ -461,13 +529,14 @@ Returns a list of all objects matching a search type and string in the database, or all objects in the database if no search information is given. -There are four types of searches currently. C<type>, with a given type, +There are five types of searches currently. C<type>, with a given type, will return only those entries where the type matches the given type. C<owner>, with a given owner, will only return those objects owned by the given ACL name or ID. C<flag>, with a given flag name, will only return those items with a flag set to the given value. C<acl> operates like C<owner>, but will return only those objects that have the given ACL name -or ID on any of the possible ACL settings, not just owner. +or ID on any of the possible ACL settings, not just owner. C<unused> will +return all entries for which a get command has never been issued. The return value is a list of references to pairs of type and name. For example, if two objects existed in the database, both of type C<keytab> diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index 589a15d..25d48cf 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -220,6 +220,8 @@ Holds the supported ACL schemes and their corresponding Perl classes: 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 ('netdb', 'Wallet::ACL::NetDB'); insert into acl_schemes (as_name, as_class) values ('netdb-root', 'Wallet::ACL::NetDB::Root'); diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index e5fb2fa..a1f2876 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -109,4 +109,6 @@ SKIP: { like ($kadmin->error, qr%^error creating keytab for wallet/one%, ' and the right error message is set'); is ($kadmin->destroy ('wallet/one'), 1, ' and deleting it again works'); + + unlink 'krb5cc_test'; } diff --git a/perl/t/keytab.t b/perl/t/keytab.t index b16cea5..fabdc5b 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -103,8 +103,14 @@ sub enctypes { close KEYTAB; my @enctypes; - open (KLIST, '-|', 'klist', '-ke', 'keytab') - or die "cannot run klist: $!\n"; + my $pid = open (KLIST, '-|'); + if (not defined $pid) { + die "cannot fork: $!\n"; + } elsif ($pid == 0) { + open (STDERR, '>', '/dev/null') or die "cannot reopen stderr: $!\n"; + exec ('klist', '-ke', 'keytab') + or die "cannot run klist: $!\n"; + } local $_; while (<KLIST>) { next unless /^ *\d+ /; diff --git a/perl/t/report.t b/perl/t/report.t index 1dc69f7..363db20 100755 --- a/perl/t/report.t +++ b/perl/t/report.t @@ -7,7 +7,7 @@ # # See LICENSE for licensing terms. -use Test::More tests => 151; +use Test::More tests => 197; use Wallet::Admin; use Wallet::Report; @@ -49,6 +49,12 @@ is (scalar (@objects), 1, ' and now there is one object'); is ($objects[0][0], 'base', ' with the right type'); is ($objects[0][1], 'service/admin', ' and the right name'); +# That object should be unused. +@objects = $report->objects ('unused'); +is (scalar (@objects), 1, ' and that object is unused'); +is ($objects[0][0], 'base', ' with the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); + # Create another ACL. is ($server->acl_create ('first'), 1, 'ACL creation succeeds'); @acls = $report->acls; @@ -97,6 +103,14 @@ is (scalar (@lines), 1, ' and there is still owner in the report'); is ($lines[0][0], 'krb5', ' with the right scheme'); is ($lines[0][1], 'admin@EXAMPLE.COM', ' and the right identifier'); +# Both objects should now show as unused. +@objects = $report->objects ('unused'); +is (scalar (@objects), 2, 'There are now two unused objects'); +is ($objects[0][0], 'base', ' and the first has the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); +is ($objects[1][0], 'base', ' and the second has the right type'); +is ($objects[1][1], 'service/foo', ' and the right name'); + # Change the owner of the second object to an empty ACL. is ($server->owner ('base', 'service/foo', 'second'), 1, ' and changing the owner to an empty ACL works'); @@ -239,6 +253,75 @@ is (scalar (@lines), 1, 'Searching for ACL naming violations finds one'); is ($lines[0][0], 3, ' and the first has the right ID'); is ($lines[0][1], 'second', ' and the right name'); +# Set up a file bucket so that we can create an object we can retrieve. +system ('rm -rf test-files') == 0 or die "cannot remove test-files\n"; +mkdir 'test-files' or die "cannot create test-files: $!\n"; +$Wallet::Config::FILE_BUCKET = 'test-files'; + +# Create a file object and ensure that it shows up in the unused list. +is ($server->create ('file', 'test'), 1, 'Creating file:test succeeds'); +is ($server->owner ('file', 'test', 'ADMIN'), 1, + ' and setting its owner works'); +@objects = $report->objects ('unused'); +is (scalar (@objects), 4, 'There are now four unused objects'); +is ($objects[0][0], 'base', ' and the first has the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); +is ($objects[1][0], 'base', ' and the second has the right type'); +is ($objects[1][1], 'service/foo', ' and the right name'); +is ($objects[2][0], 'base', ' and the third has the right type'); +is ($objects[2][1], 'service/null', ' and the right name'); +is ($objects[3][0], 'file', ' and the fourth has the right type'); +is ($objects[3][1], 'test', ' and the right name'); + +# Store something and retrieve it, and then check that the file object fell +# off of the list. +is ($server->store ('file', 'test', 'Some data'), 1, + 'Storing data in file:test succeeds'); +is ($server->get ('file', 'test'), 'Some data', ' and retrieving it works'); +@objects = $report->objects ('unused'); +is (scalar (@objects), 3, ' and now there are three unused objects'); +is ($objects[0][0], 'base', ' and the first has the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); +is ($objects[1][0], 'base', ' and the second has the right type'); +is ($objects[1][1], 'service/foo', ' and the right name'); +is ($objects[2][0], 'base', ' and the third has the right type'); +is ($objects[2][1], 'service/null', ' and the right name'); + +# The third and fourth ACLs are both empty and should show up as duplicate. +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); +is (scalar (@{ $acls[0] }), 2, ' with two members'); +is ($acls[0][0], 'fourth', ' and the first member is correct'); +is ($acls[0][1], 'third', ' and the second member is correct'); + +# Add the same line to both ACLs. They should still show up as duplicate. +is ($server->acl_add ('fourth', 'base', 'bar'), 1, + 'Adding a line to the fourth ACL works'); +is ($server->acl_add ('third', 'base', 'bar'), 1, + ' and adding a line to the third ACL works'); +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); +is (scalar (@{ $acls[0] }), 2, ' with two members'); +is ($acls[0][0], 'fourth', ' and the first member is correct'); +is ($acls[0][1], 'third', ' and the second member is correct'); + +# Add another line to the third ACL. Now we match second. +is ($server->acl_add ('third', 'base', 'foo'), 1, + 'Adding another line to the third ACL works'); +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); +is (scalar (@{ $acls[0] }), 2, ' with two members'); +is ($acls[0][0], 'second', ' and the first member is correct'); +is ($acls[0][1], 'third', ' and the second member is correct'); + +# Add yet another line to the third ACL. Now all ACLs are distinct. +is ($server->acl_add ('third', 'base', 'baz'), 1, + 'Adding another line to the third ACL works'); +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 0, 'There are no duplicate ACLs'); +is ($report->error, undef, ' and no error'); + # Clean up. $admin->destroy; unlink 'wallet-db'; +system ('rm -r test-files') == 0 or die "cannot remove test-files\n"; diff --git a/perl/t/schema.t b/perl/t/schema.t index 7f0aea4..40759db 100755 --- a/perl/t/schema.t +++ b/perl/t/schema.t @@ -21,7 +21,7 @@ ok (defined $schema, 'Wallet::Schema creation'); ok ($schema->isa ('Wallet::Schema'), ' and class verification'); my @sql = $schema->sql; ok (@sql > 0, 'sql() returns something'); -is (scalar (@sql), 28, ' and returns the right number of statements'); +is (scalar (@sql), 29, ' and returns the right number of statements'); # Connect to a database and test create. db_setup; diff --git a/perl/t/verifier.t b/perl/t/verifier.t index 74d7ba8..f56f5fa 100755 --- a/perl/t/verifier.t +++ b/perl/t/verifier.t @@ -3,14 +3,15 @@ # Tests for the basic wallet ACL verifiers. # # Written by Russ Allbery <rra@stanford.edu> -# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. -use Test::More tests => 47; +use Test::More tests => 57; use Wallet::ACL::Base; use Wallet::ACL::Krb5; +use Wallet::ACL::Krb5::Regex; use Wallet::ACL::NetDB; use Wallet::ACL::NetDB::Root; use Wallet::Config; @@ -39,6 +40,21 @@ is ($verifier->error, 'no principal specified', ' and right error'); is ($verifier->check ('rra@stanford.edu', ''), undef, 'Empty ACL'); is ($verifier->error, 'malformed krb5 ACL', ' and right error'); +$verifier = Wallet::ACL::Krb5::Regex->new; +isa_ok ($verifier, 'Wallet::ACL::Krb5::Regex', 'krb5-regex verifier'); +is ($verifier->check ('rra@stanford.edu', '.*@stanford\.edu\z'), 1, + 'Simple check'); +is ($verifier->check ('rra@stanford.edu', '^a.*@stanford\.edu'), 0, + 'Simple failure'); +is ($verifier->error, undef, 'No error set'); +is ($verifier->check (undef, '^rra@stanford\.edu\z'), undef, + 'Undefined principal'); +is ($verifier->error, 'no principal specified', ' and right error'); +is ($verifier->check ('rra@stanford.edu', ''), undef, 'Empty ACL'); +is ($verifier->error, 'no ACL specified', ' and right error'); +is ($verifier->check ('rra@stanford.edu', '(rra'), undef, 'Malformed regex'); +is ($verifier->error, 'malformed krb5-regex ACL', ' and right error'); + # Tests for the NetDB verifiers. Skip these if we don't have a keytab or if # we can't find remctld. SKIP: { |