From 574a9c0456c182831b3d01a4d7ee0c737b91b107 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 9 Jun 2009 14:39:39 -0700 Subject: Remove Subversion Id strings --- perl/t/acl.t | 1 - perl/t/admin.t | 1 - perl/t/config.t | 1 - perl/t/data/keytab-fake | 1 - perl/t/data/keytab.conf | 2 -- perl/t/data/netdb-fake | 1 - perl/t/data/netdb.conf | 2 -- perl/t/file.t | 1 - perl/t/init.t | 1 - perl/t/keytab.t | 1 - perl/t/lib/Util.pm | 1 - perl/t/object.t | 1 - perl/t/pod.t | 1 - perl/t/schema.t | 1 - perl/t/server.t | 1 - perl/t/verifier-netdb.t | 1 - perl/t/verifier.t | 1 - 17 files changed, 19 deletions(-) (limited to 'perl/t') diff --git a/perl/t/acl.t b/perl/t/acl.t index e46b7f8..95aa763 100755 --- a/perl/t/acl.t +++ b/perl/t/acl.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/api.t -- Tests for the wallet ACL API. # diff --git a/perl/t/admin.t b/perl/t/admin.t index 4b8302d..7a8b8ae 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/admin.t -- Tests for wallet administrative interface. # diff --git a/perl/t/config.t b/perl/t/config.t index 0d159dc..d60d7e7 100755 --- a/perl/t/config.t +++ b/perl/t/config.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/config.t -- Tests for the wallet server configuration. # diff --git a/perl/t/data/keytab-fake b/perl/t/data/keytab-fake index df21294..0ecf264 100755 --- a/perl/t/data/keytab-fake +++ b/perl/t/data/keytab-fake @@ -1,5 +1,4 @@ #!/bin/sh -# $Id$ # # keytab-fake -- Fake keytab-backend implementation. # diff --git a/perl/t/data/keytab.conf b/perl/t/data/keytab.conf index eb105e2..484443f 100644 --- a/perl/t/data/keytab.conf +++ b/perl/t/data/keytab.conf @@ -1,5 +1,3 @@ -# $Id$ -# # This is the remctl configuration used for testing the keytab backend's # ability to retrieve existing keytabs through remctl. Currently the only # supported and used command is keytab retrieve. The ACL is written on diff --git a/perl/t/data/netdb-fake b/perl/t/data/netdb-fake index 56744a7..ae5be18 100755 --- a/perl/t/data/netdb-fake +++ b/perl/t/data/netdb-fake @@ -1,5 +1,4 @@ #!/bin/sh -# $Id$ # # netdb-fake -- Fake NetDB remctl interface. # diff --git a/perl/t/data/netdb.conf b/perl/t/data/netdb.conf index e7908ed..f08bfaa 100644 --- a/perl/t/data/netdb.conf +++ b/perl/t/data/netdb.conf @@ -1,5 +1,3 @@ -# $Id$ -# # This is the remctl configuration used for testing the NetDB ACL verifier. # The ACL is written on the fly by the test program. diff --git a/perl/t/file.t b/perl/t/file.t index 8eaa0f1..7ab5d75 100755 --- a/perl/t/file.t +++ b/perl/t/file.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/file.t -- Tests for the file object implementation. # diff --git a/perl/t/init.t b/perl/t/init.t index 70085c9..d0fae9f 100755 --- a/perl/t/init.t +++ b/perl/t/init.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/init.t -- Tests for database initialization. # diff --git a/perl/t/keytab.t b/perl/t/keytab.t index c1348d4..1803e53 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/keytab.t -- Tests for the keytab object implementation. # diff --git a/perl/t/lib/Util.pm b/perl/t/lib/Util.pm index a1bacbd..ac0f530 100644 --- a/perl/t/lib/Util.pm +++ b/perl/t/lib/Util.pm @@ -1,5 +1,4 @@ # Util -- Utility class for wallet tests. -# $Id$ # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/object.t b/perl/t/object.t index 94fe22b..a40a412 100755 --- a/perl/t/object.t +++ b/perl/t/object.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/object.t -- Tests for the basic object implementation. # diff --git a/perl/t/pod.t b/perl/t/pod.t index da4d0d3..e9aa0a8 100755 --- a/perl/t/pod.t +++ b/perl/t/pod.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -# $Id$ # # t/pod.t -- Test POD formatting for the wallet Perl modules. # diff --git a/perl/t/schema.t b/perl/t/schema.t index c7e9133..01d5dac 100755 --- a/perl/t/schema.t +++ b/perl/t/schema.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/schema.t -- Tests for the wallet schema class. # diff --git a/perl/t/server.t b/perl/t/server.t index 08edd56..d4fd068 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/server.t -- Tests for the wallet server API. # diff --git a/perl/t/verifier-netdb.t b/perl/t/verifier-netdb.t index 6a77e3c..dcbbdd8 100755 --- a/perl/t/verifier-netdb.t +++ b/perl/t/verifier-netdb.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/verifier-netdb.t -- Tests for the NetDB wallet ACL verifiers. # diff --git a/perl/t/verifier.t b/perl/t/verifier.t index 96e641d..3243d9c 100755 --- a/perl/t/verifier.t +++ b/perl/t/verifier.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/verifier.t -- Tests for the basic wallet ACL verifiers. # -- cgit v1.2.3 From c2cde5918af1882ee63324fd9e09f07c8e6e5cc9 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 9 Jun 2009 16:39:08 -0700 Subject: Add owners report Add a new report owners command to wallet-admin and corresponding report_owners() method to Wallet::Admin, which returns all ACL lines on owner ACLs for matching objects. --- NEWS | 4 ++++ perl/Wallet/Admin.pm | 47 ++++++++++++++++++++++++++++++++++++++++-- perl/t/admin.t | 55 +++++++++++++++++++++++++++++++++++++++++++++++-- server/wallet-admin | 39 ++++++++++++++++++++++++++++++++++- tests/server/admin-t.in | 45 +++++++++++++++++++++++++++++++--------- 5 files changed, 175 insertions(+), 15 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index e16c630..ab0828b 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,10 @@ wallet 0.10 (unreleased) Fix logging in wallet-backend and the remctl configuration to not log the data passed to store. + Add a new report owners command to wallet-admin and corresponding + report_owners() method to Wallet::Admin, which returns all ACL lines + on owner ACLs for matching objects. + wallet 0.9 (2008-04-24) The wallet command-line client now reads the data for store from a diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index 3a2f687..c11c3d4 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -1,7 +1,7 @@ # Wallet::Admin -- Wallet system administrative interface. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -22,7 +22,7 @@ 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.02'; +$VERSION = '0.03'; ############################################################################## # Constructor, destructor, and accessors @@ -171,6 +171,38 @@ sub list_acls { } } +# Returns a report of all ACL lines contained in owner ACLs for matching +# objects. Objects are specified by type and name, which may be SQL wildcard +# expressions. Each list member will be a pair of ACL scheme and ACL +# identifier, with duplicates removed. On error and for no matching entries, +# the empty list will be returned. To distinguish between an empty return and +# an error, call error(), which will return undef if there was no error. +sub report_owners { + my ($self, $type, $name) = @_; + undef $self->{error}; + my @lines; + 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 ]); + } + $self->{dbh}->commit; + }; + if ($@) { + $self->error ("cannot report on owners: $@"); + $self->{dbh}->rollback; + return; + } else { + return @lines; + } +} + ############################################################################## # Object registration ############################################################################## @@ -335,6 +367,17 @@ 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 report_owners(TYPE, NAME) + +Returns a list of all ACL lines contained in owner ACLs for objects +matching TYPE and NAME, which are interpreted as SQL patterns using C<%> +as a wildcard. The return value is a list of references to pairs of +schema and identifier, with duplicates removed. + +Returns the empty list on failure. To distinguish between this and no +matches, the caller should call error(). error() is guaranteed to return +the error message if there was an error and undef if there was no error. + =back =head1 SEE ALSO diff --git a/perl/t/admin.t b/perl/t/admin.t index 7a8b8ae..8804f34 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -3,11 +3,11 @@ # t/admin.t -- Tests for wallet administrative interface. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. -use Test::More tests => 29; +use Test::More tests => 57; use Wallet::Admin; use Wallet::Schema; @@ -73,6 +73,57 @@ is ($acls[0][1], 'ADMIN', ' and the first name is still the same'); is ($acls[1][0], 3, ' but the second ID has changed'); is ($acls[1][1], 'second', ' and the second name is correct'); +# Currently, we have no owners, so we should get an empty owner report. +my @lines = $admin->report_owners ('%', '%'); +is (scalar (@lines), 0, 'Owner report is currently empty'); +is ($admin->error, undef, ' and there is no error'); + +# Set an owner and make sure we now see something in the report. +is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, + 'Setting an owner works'); +@lines = $admin->report_owners ('%', '%'); +is (scalar (@lines), 1, ' and now there is one owner in the report'); +is ($lines[0][0], 'krb5', ' with the right scheme'); +is ($lines[0][1], 'admin@EXAMPLE.COM', ' and the right identifier'); +@lines = $admin->report_owners ('keytab', '%'); +is (scalar (@lines), 0, 'Owners of keytabs is empty'); +is ($admin->error, undef, ' with no error'); +@lines = $admin->report_owners ('base', 'foo/%'); +is (scalar (@lines), 0, 'Owners of base foo/* objects is empty'); +is ($admin->error, undef, ' with no error'); + +# Create a second object with the same owner. +is ($server->create ('base', 'service/foo'), 1, + 'Creating base:service/foo succeeds'); +is ($server->owner ('base', 'service/foo', 'ADMIN'), 1, + ' and setting the owner to the same value works'); +@lines = $admin->report_owners ('base', 'service/%'); +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'); + +# 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'); +@lines = $admin->report_owners ('base', '%'); +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'); + +# Add a few things to the second ACL to see what happens. +is ($server->acl_add ('second', 'base', 'foo'), 1, + 'Adding an ACL line to the new ACL works'); +is ($server->acl_add ('second', 'base', 'bar'), 1, + ' and adding another ACL line to the new ACL works'); +@lines = $admin->report_owners ('base', '%'); +is (scalar (@lines), 3, ' and now there are three owners in the report'); +is ($lines[0][0], 'base', ' first has the right scheme'); +is ($lines[0][1], 'bar', ' and the right identifier'); +is ($lines[1][0], 'base', ' second has the right scheme'); +is ($lines[1][1], 'foo', ' and the right identifier'); +is ($lines[2][0], 'krb5', ' third has the right scheme'); +is ($lines[2][1], 'admin@EXAMPLE.COM', ' and the right identifier'); + # Clean up. is ($admin->destroy, 1, 'Destruction succeeds'); unlink 'wallet-db'; diff --git a/server/wallet-admin b/server/wallet-admin index 0daa986..b5674c5 100755 --- a/server/wallet-admin +++ b/server/wallet-admin @@ -3,7 +3,7 @@ # wallet-admin -- Wallet server administrative commands. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -64,6 +64,22 @@ sub command { } else { die "only objects or acls are supported for list\n"; } + } elsif ($command eq 'report') { + die "too few arguments to report\n" if @args < 1; + my $report = shift @args; + if ($report eq 'owners') { + die "too many arguments to report owners\n" if @args > 2; + die "too few arguments to report owners\n" if @args < 2; + my @lines = $admin->report_owners (@args); + if (!@lines and $admin->error) { + die $admin->error, "\n"; + } + for my $line (@lines) { + print join (' ', @$line), "\n"; + } + } else { + die "unknown report type $report\n"; + } } elsif ($command eq 'register') { die "too many arguments to register\n" if @args > 3; die "too few arguments to register\n" if @args < 3; @@ -168,6 +184,27 @@ default as part of database initialization, so this command is used primarily to register local implementations of additional object types or ACL schemes. +=item report [ ... ] + +Runs a wallet report. The currently supported report types are: + +=over 4 + +=item report owners + +Returns a list of all ACL lines in owner ACLs for all objects matching +both and . These can be the type or name of +objects or they can be patterns using C<%> as the wildcard character +following the normal rules of SQL patterns. + +The output will be one line per ACL line in the form: + + + +with duplicates suppressed. + +=back + =back =head1 SEE ALSO diff --git a/tests/server/admin-t.in b/tests/server/admin-t.in index 44ea1fe..3e84022 100644 --- a/tests/server/admin-t.in +++ b/tests/server/admin-t.in @@ -3,12 +3,12 @@ # Tests for the wallet-admin dispatch code. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. use strict; -use Test::More tests => 54; +use Test::More tests => 64; # Create a dummy class for Wallet::Admin that prints what method was called # with its arguments and returns data for testing. @@ -71,6 +71,13 @@ sub register_verifier { return 1; } +sub report_owners { + shift; + print "report_owners @_\n"; + return if ($error or $empty); + return ([ krb5 => 'admin@EXAMPLE.COM' ]); +} + # Back to the main package and the actual test suite. Lie about whether the # Wallet::Admin package has already been loaded. package main; @@ -98,10 +105,11 @@ is ($err, "unknown command foo\n", 'Unknown command'); is ($out, "new\n", ' and nothing ran'); # Check too few and too many arguments for every command. -my %commands = (destroy => [0, 0], - initialize => [1, 1], - list => [1, 1], - register => [3, 3]); +my %commands = (destroy => [0, 0], + initialize => [1, 1], + list => [1, 1], + register => [3, 3], + report => [1, -1]); for my $command (sort keys %commands) { my ($min, $max) = @{ $commands{$command} }; if ($min > 0) { @@ -110,10 +118,12 @@ for my $command (sort keys %commands) { "Too few arguments for $command"); is ($out, "new\n", ' and nothing ran'); } - ($out, $err) = run_admin ($command, ('foo') x ($max + 1)); - is ($err, "too many arguments to $command\n", - "Too many arguments for $command"); - is ($out, "new\n", ' and nothing ran'); + if ($max >= 0) { + ($out, $err) = run_admin ($command, ('foo') x ($max + 1)); + is ($err, "too many arguments to $command\n", + "Too many arguments for $command"); + is ($out, "new\n", ' and nothing ran'); + } } # Test destroy. @@ -179,6 +189,15 @@ is ($err, '', 'Register succeeds for verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and returns the right outout'); +# Test report. +($out, $err) = run_admin ('report', 'foo'); +is ($err, "unknown report type foo\n", 'Report requires a known report'); +is ($out, "new\n", ' and nothing was run'); +($out, $err) = run_admin ('report', 'owners', '%', '%'); +is ($err, '', 'Report succeeds for owners'); +is ($out, "new\nreport_owners % %\nkrb5 admin\@EXAMPLE.COM\n", + ' and returns the right output'); + # Test error handling. $Wallet::Admin::error = 1; ($out, $err) = run_admin ('destroy'); @@ -204,6 +223,9 @@ is ($out, "new\nregister_object foo Foo::Object\n", is ($err, "some error\n", 'Error handling succeeds for register verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and calls the right methods'); +($out, $err) = run_admin ('report', 'owners', 'foo', 'bar'); +is ($err, "some error\n", 'Error handling succeeds for report owners'); +is ($out, "new\nreport_owners foo bar\n", ' and calls the right methods'); # Test empty lists. $Wallet::Admin::error = 0; @@ -214,3 +236,6 @@ is ($out, "new\nlist_objects\n", ' and calls the right methods'); ($out, $err) = run_admin ('list', 'acls'); is ($err, '', 'list acls runs with an empty list and no errors'); is ($out, "new\nlist_acls\n", ' and calls the right methods'); +($out, $err) = run_admin ('report', 'owners', 'foo', 'bar'); +is ($err, '', 'report owners runs with an empty list and no errors'); +is ($out, "new\nreport_owners foo bar\n", ' and calls the right methods'); -- cgit v1.2.3 From 2c5bd71125d411639b4a61116957879eebae21ad Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 3 Dec 2009 08:52:19 -0800 Subject: Improved wallet-admin list command with searches wallet-admin's list command now has additional searches added for objects and acls that match certain specifiers. For objects these include searching for objects owned by a specific ACL, objects owned by no one, objects of a specific type, objects with a specific flag, and objects for which a specific ACL has any privileges at all. For acls, this includes the ability to search for any ACL with an entry with given type and identifier. --- perl/Wallet/Admin.pm | 167 ++++++++++++++++++++++++++++++++++++++++++++++++--- perl/t/admin.t | 55 ++++++++++++++--- server/wallet-admin | 8 +-- 3 files changed, 206 insertions(+), 24 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index c11c3d4..91f1bfb 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -22,7 +22,7 @@ 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 @@ -114,20 +114,132 @@ sub destroy { # Reporting ############################################################################## +# Given an ACL name, translate it to the ID for that ACL and return it. +# Often this is unneeded and could be done with a join, but by doing it in a +# separate step, we can give an error for the specific case of someone +# searching for a non-existant ACL. +sub acl_name_to_id { + my ($self, $acl) = @_; + my ($id); + eval { + my $sql = 'select ac_id from acls where ac_name=?'; + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute ($acl); + while (defined (my $row = $sth->fetchrow_hashref)) { + $id = $row->{'ac_id'}; + } + $self->{dbh}->commit; + }; + + if (!defined $id || $id !~ /^\d+$/) { + $self->error ("could not find the acl $acl"); + return ''; + } + return $id; +} + +# Return the SQL statement to find every object in the database. +sub list_objects_all { + my ($self) = @_; + my $sql = 'select ob_type, ob_name from objects order by ob_type, + ob_name'; + return $sql; +} + +# Return the SQL statement and the search field required to find all objects +# matching a specific type. +sub list_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); +} + +# Return the SQL statement and search field required to find all objects +# owned by a given ACL. If the requested owner is 'null', then we ignore +# this and do a different search for IS NULL. If the requested owner does +# not actually match any ACLs, set an error and return the empty string. +sub list_objects_owner { + my ($self, $owner) = @_; + my ($sth); + if ($owner =~ /^null$/i) { + my $sql = 'select ob_type, ob_name from objects where ob_owner is null + order by objects.ob_type, objects.ob_name'; + return ($sql); + } else { + my $id = $self->acl_name_to_id ($owner); + return '' unless $id; + my $sql = 'select ob_type, ob_name from objects where ob_owner=? + order by objects.ob_type, objects.ob_name'; + return ($sql, $id); + } +} + +# Return the SQL statement and search field required to find all objects +# that have a specific flag set. +sub list_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); +} + +# Return the SQL statement and search field required to find all objects +# that a given ACL has any permissions on. This expands from +# list_objects_owner in that it will also match any records that have the ACL +# set for get, store, show, destroy, or flags. If the requested owner does +# not actually match any ACLs, set an error and return the empty string. +sub list_objects_acl { + my ($self, $acl) = @_; + + my $id = $self->acl_name_to_id ($acl); + return '' unless $id; + + 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, $id, $id, $id, $id, $id, $id); +} + # Returns a list of all objects stored in the wallet database in the form of # type and name pairs. On error and for an empty database, the empty list # will be returned. To distinguish between an empty list and an error, call -# error(), which will return undef if there was no error. +# error(), which will return undef if there was no error. Farms out specific +# statement to another subroutine for specific search types, but each case +# should return ob_type and ob_name in that order. sub list_objects { - my ($self) = @_; + my ($self, $type, @args) = @_; undef $self->{error}; + + # Find the SQL statement and the arguments to use. + my $sql = ''; + my @search = (); + if (!defined $type || $type eq '') { + ($sql) = $self->list_objects_all (); + } else { + if (@args != 1) { + $self->error ("object searches require an argument to search"); + } elsif ($type eq 'type') { + ($sql, @search) = $self->list_objects_type (@args); + } elsif ($type eq 'owner') { + ($sql, @search) = $self->list_objects_owner (@args); + } elsif ($type eq 'flag') { + ($sql, @search) = $self->list_objects_flag (@args); + } elsif ($type eq 'acl') { + ($sql, @search) = $self->list_objects_acl (@args); + } else { + $self->error ("do not know search type: $type"); + } + return unless $sql; + } + my @objects; eval { - my $sql = 'select ob_type, ob_name from objects order by ob_type, - ob_name'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute; my $object; + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute (@search); while (defined ($object = $sth->fetchrow_arrayref)) { push (@objects, [ @$object ]); } @@ -142,6 +254,25 @@ sub list_objects { } } +# Returns the SQL statement required to find and return all ACLs in the db. +sub list_acls_all { + my ($self) = @_; + my $sql = 'select ac_id, ac_name from acls order by ac_id'; + return ($sql); +} + +# Returns the SQL statement and the field required to search the ACLs and +# return only those entries which contain a entries with identifiers +# matching a particular given string. +sub list_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'; + $identifier = '%'.$identifier.'%'; + return ($sql, $type, $identifier); +} + # Returns a list of all ACLs stored in the wallet database as a list of pairs # of ACL IDs and ACL names. On error and for an empty database, the empty # list will be returned; however, this is unlikely since any valid database @@ -149,13 +280,29 @@ sub list_objects { # list and an error, call error(), which will return undef if there was no # error. sub list_acls { - my ($self) = @_; + my ($self, $type, @args) = @_; undef $self->{error}; + + # Find the SQL statement and the arguments to use. + my $sql = ''; + my @search = (); + if (!defined $type || $type eq '') { + ($sql) = $self->list_acls_all (); + } else { + if (@args == 0) { + $self->error ("acl searches require an argument to search"); + } elsif ($type eq 'entry') { + ($sql, @search) = $self->list_acls_entry (@args); + } else { + $self->error ("do not know search type: $type"); + } + return unless $sql; + } + my @acls; eval { - my $sql = 'select ac_id, ac_name from acls order by ac_id'; my $sth = $self->{dbh}->prepare ($sql); - $sth->execute; + $sth->execute (@search); my $object; while (defined ($object = $sth->fetchrow_arrayref)) { push (@acls, [ @$object ]); diff --git a/perl/t/admin.t b/perl/t/admin.t index 8804f34..77c786d 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -7,7 +7,7 @@ # # See LICENSE for licensing terms. -use Test::More tests => 57; +use Test::More tests => 77; use Wallet::Admin; use Wallet::Schema; @@ -54,15 +54,6 @@ is ($objects[0][1], 'service/admin', ' and the right name'); is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), 1, 'Registering Wallet::ACL::Base works'); -# Create another ACL. -is ($server->acl_create ('first'), 1, 'ACL creation succeeds'); -@acls = $admin->list_acls; -is (scalar (@acls), 2, ' and now there are two ACLs'); -is ($acls[0][0], 1, ' and the first ID is correct'); -is ($acls[0][1], 'ADMIN', ' and the first name is correct'); -is ($acls[1][0], 2, ' and the second ID is correct'); -is ($acls[1][1], 'first', ' and the second name is correct'); - # Delete that ACL and create another. is ($server->acl_create ('second'), 1, 'Second ACL creation succeeds'); is ($server->acl_destroy ('first'), 1, ' and deletion of the first succeeds'); @@ -124,6 +115,50 @@ is ($lines[1][1], 'foo', ' and the right identifier'); is ($lines[2][0], 'krb5', ' third has the right scheme'); is ($lines[2][1], 'admin@EXAMPLE.COM', ' and the right identifier'); +# Test ownership and other ACL values. Change one keytab to be not owned by +# ADMIN, but have group permission on it. We'll need a third object neither +# owned by ADMIN or with any permissions from it. +is ($server->create ('base', 'service/null'), 1, + 'Creating base:service/null succeeds'); +is ($server->acl ('base', 'service/foo', 'get', 'ADMIN'), 1, + 'Changing the get ACL for the search also does'); +@lines = $admin->list_objects ('owner', 'ADMIN'); +is (scalar (@lines), 1, 'Searching for objects owned by ADMIN finds one'); +is ($lines[0][0], 'base', ' and it has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +@lines = $admin->list_objects ('owner', 'null'); +is (scalar (@lines), 1, 'Searching for objects with no set ownerfinds one'); +is ($lines[0][0], 'base', ' and it has the right type'); +is ($lines[0][1], 'service/null', ' and the right name'); +@lines = $admin->list_objects ('acl', 'ADMIN'); +is (scalar (@lines), 2, 'ADMIN has any rights at all on two objects'); +is ($lines[0][0], 'base', ' and the first has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +is ($lines[1][0], 'base', ' and the second has the right type'); +is ($lines[1][1], 'service/foo', ' and the right name'); + +# Listing objects of a specific type. +@lines = $admin->list_objects ('type', 'base'); +is (scalar (@lines), 3, 'Searching for all objects of type base finds three'); +is ($lines[0][0], 'base', ' and the first has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +is ($lines[1][0], 'base', ' and the second has the right type'); +is ($lines[1][1], 'service/foo', ' and the right name'); +is ($lines[2][0], 'base', ' and the third has the right type'); +is ($lines[2][1], 'service/null', ' and the right name'); +@lines = $admin->list_objects ('type', 'keytab'); +is (scalar (@lines), 0, 'Searching for all objects of type keytab finds none'); + +# Test setting a flag, searching for objects with it, and then clearing it. +is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, + 'Setting a flag works'); +@lines = $admin->list_objects ('flag', 'unchanging'); +is (scalar (@lines), 1, 'Searching for all objects with that flag finds one'); +is ($lines[0][0], 'base', ' and it has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, + 'Clearing the flag works'); + # Clean up. is ($admin->destroy, 1, 'Destruction succeeds'); unlink 'wallet-db'; diff --git a/server/wallet-admin b/server/wallet-admin index b5674c5..01fea5c 100755 --- a/server/wallet-admin +++ b/server/wallet-admin @@ -42,11 +42,11 @@ sub command { unless $args[0] =~ /^[^\@\s]+\@\S+$/; $admin->initialize (@args) or die $admin->error, "\n"; } elsif ($command eq 'list') { - die "too many arguments to list\n" if @args > 1; + die "too many arguments to list\n" if @args > 4; die "too few arguments to list\n" if @args < 1; - my ($type) = @args; + my ($type, $subtype, @search) = @args; if ($type eq 'objects') { - my @objects = $admin->list_objects; + my @objects = $admin->list_objects ($subtype, @search); if (!@objects and $admin->error) { die $admin->error, "\n"; } @@ -54,7 +54,7 @@ sub command { print join (' ', @$object), "\n"; } } elsif ($type eq 'acls') { - my @acls = $admin->list_acls; + my @acls = $admin->list_acls ($subtype, @search); if (!@acls and $admin->error) { die $admin->error, "\n"; } -- cgit v1.2.3 From e0f69c0b3f41684079762f843c37888d1017d576 Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 17 Dec 2009 11:26:28 -0800 Subject: Added keytab testing cases for Heimdal KDC Added cases to handle the Wallet::Object::Keytab module using a Heimdal KDC as well as an MIT KDC. In most cases this is transparent, but some tests are skipped for Heimdal, and the commands run to test that the created principals and keytabs are correct are different for Heimdal. The code now branches based on the value of $Wallet::Config::KEYTAB_KRBTYPE. --- perl/t/data/README | 1 + perl/t/keytab.t | 139 ++++++++++++++++++++++++++++++++++++----------------- 2 files changed, 95 insertions(+), 45 deletions(-) (limited to 'perl/t') diff --git a/perl/t/data/README b/perl/t/data/README index 4abbaeb..d250d33 100644 --- a/perl/t/data/README +++ b/perl/t/data/README @@ -21,6 +21,7 @@ following files: test.keytab Keytab for an authorized user test.principal Principal of the authorized user test.realm Kerberos realm in which to do testing + test.krbtype Type of Kerberos server (Heimdal or MIT) This realm will also need to be configured in your local krb5.conf, including the admin_server for the realm. diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 1803e53..8a11ad4 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -8,7 +8,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 223; +use Test::More tests => 225; use Wallet::Admin; use Wallet::Config; @@ -56,10 +56,17 @@ sub system_quiet { # been set up. sub create { my ($principal) = @_; - my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', - '-t', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - '-q', "addprinc -clearpolicy -randkey $principal"); + if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', + '-t', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + '-q', "addprinc -clearpolicy -randkey $principal"); + } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, + '-K', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + 'add', $principal); + } system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args); } @@ -67,20 +74,37 @@ sub create { # been set up. sub destroy { my ($principal) = @_; - my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', - '-t', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - '-q', "delprinc -force $principal"); + my (@args); + if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', + '-t', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + '-q', "delprinc -force $principal"); + } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, + '-K', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + 'delete', $principal); + } system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args); } -# Check whether a principal exists. +# Check whether a principal exists. kvno works for MIT, but isn't in the +# Heimdal dist. sub created { my ($principal) = @_; $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - local $ENV{KRB5CCNAME} = 'krb5cc_temp'; - getcreds ('t/data/test.keytab', $Wallet::Config::KEYTAB_PRINCIPAL); - return (system_quiet ('kvno', $principal) == 0); + if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + local $ENV{KRB5CCNAME} = 'krb5cc_temp'; + getcreds ('t/data/test.keytab', $Wallet::Config::KEYTAB_PRINCIPAL); + return (system_quiet ('kvno', $principal) == 0); + } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, + '-K', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + 'get', $principal); + return (system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args) == 0); + } } # Given keytab data and the principal, write it to a file and try @@ -101,24 +125,41 @@ sub valid { # Given keytab data, write it to a file and try to determine the enctypes of # the keys present in that file. Returns the enctypes as a list, with UNKNOWN # for encryption types that weren't recognized. This is an ugly way of doing -# this. +# this for MIT. Heimdal is much more straightforward, but MIT ktutil doesn't +# have the needed abilities. sub enctypes { my ($keytab) = @_; open (KEYTAB, '>', 'keytab') or die "cannot create keytab: $!\n"; print KEYTAB $keytab; close KEYTAB; - open (KLIST, '-|', 'klist', '-ke', 'keytab') - or die "cannot run klist: $!\n"; + my @enctypes; - local $_; - while () { - next unless /^ *\d+ /; - my ($string) = /\((.*)\)\s*$/; - next unless $string; - $enctype = $enctype{lc $string} || 'UNKNOWN'; - push (@enctypes, $enctype); + if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + open (KLIST, '-|', 'klist', '-ke', 'keytab') + or die "cannot run klist: $!\n"; + local $_; + while () { + next unless /^ *\d+ /; + my ($string) = /\((.*)\)\s*$/; + next unless $string; + $enctype = $enctype{lc $string} || 'UNKNOWN'; + push (@enctypes, $enctype); + } + close KLIST; + } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { + open (KTUTIL, '-|', 'ktutil', '-k', 'keytab', 'list') + or die "cannot run ktutil: $!\n"; + local $_; + while () { + next unless /^ *\d+ /; + my ($string) = /^\s*\d+\s+(\S+)/; + next unless $string; + #$enctype = $enctype{lc $string} || 'UNKNOWN'; + #push (@enctypes, $enctype); + push (@enctypes, $string); + } + close KTUTIL; } - close KLIST; unlink 'keytab'; return sort @enctypes; } @@ -173,6 +214,7 @@ SKIP: { $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); $Wallet::Config::KEYTAB_TMP = '.'; my $realm = $Wallet::Config::KEYTAB_REALM; @@ -258,12 +300,17 @@ EOO is ($object->error, 'KEYTAB_TMP configuration variable not set', ' with the right error'); $Wallet::Config::KEYTAB_TMP = '.'; - $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; - $data = $object->get (@trace); - is ($data, undef, 'Cope with a failure to run kadmin'); - like ($object->error, qr{^cannot run /some/nonexistent/file: }, - ' with the right error'); - $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; + SKIP: { + skip ' no kadmin program test for Heimdal', 2 + if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; + + $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; + $data = $object->get (@trace); + is ($data, undef, 'Cope with a failure to run kadmin'); + like ($object->error, qr{^cannot run /some/nonexistent/file: }, + ' with the right error'); + $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; + } destroy ('wallet/one'); $data = $object->get (@trace); is ($data, undef, 'Getting a keytab for a nonexistent principal fails'); @@ -278,12 +325,19 @@ EOO }; ok (defined ($object), 'Creating good principal succeeds'); ok (created ('wallet/one'), ' and the principal was created'); - $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; - is ($object->destroy (@trace), undef, - ' and destroying it with bad kadmin fails'); - like ($object->error, qr{^cannot run /some/nonexistent/file: }, - ' with the right error'); - $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; + + SKIP: { + skip ' no kadmin program test for Heimdal', 2 + if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; + + $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; + is ($object->destroy (@trace), undef, + ' and destroying it with bad kadmin fails'); + like ($object->error, qr{^cannot run /some/nonexistent/file: }, + ' with the right error'); + $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; + } + is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); is ($object->destroy (@trace), undef, ' and destroying it fails'); is ($object->error, "cannot destroy keytab:wallet/one: object is locked", @@ -341,14 +395,6 @@ EOO is ($@, "keytab object implementation not configured\n", ' with the right error'); $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); - $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) - }; - is ($object, undef, 'Cope with a failure to run kadmin'); - like ($@, qr{^cannot run /some/nonexistent/file: }, - ' with the right error'); - $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; } # Tests for unchanging support. Skip these if we don't have a keytab or if we @@ -669,7 +715,8 @@ EOO # Tests for enctype restriction. SKIP: { - skip 'no keytab configuration', 36 unless -f 't/data/test.keytab'; + skip 'no keytab configuration', 36 unless (-f 't/data/test.keytab' + && $Wallet::Config::KEYTAB_KRBTYPE eq 'MIT'); # Set up our configuration. $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; @@ -765,6 +812,7 @@ EOO ok (defined ($keytab), ' and retrieving the keytab still works'); @values = enctypes ($keytab); is ("@values", $enctypes[0], ' and it has the right enctype'); + ok (defined ($one), ' and recreating it succeeds'); is ($one->attr ('enctypes', [ $enctypes[1] ], @trace), 1, 'Setting a different single enctype works'); @values = $one->attr ('enctypes'); @@ -773,6 +821,7 @@ EOO ok (defined ($keytab), ' and retrieving the keytab still works'); @values = enctypes ($keytab); is ("@values", $enctypes[1], ' and it has the right enctype'); + ok (defined ($one), ' and recreating it succeeds'); is ($one->attr ('enctypes', [ @enctypes[0..1] ], @trace), 1, 'Setting two enctypes works'); @values = $one->attr ('enctypes'); -- cgit v1.2.3 From fc1dd4f5988c4ae932e26e92f0e7935e0fcaf2eb Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 17 Dec 2009 11:26:28 -0800 Subject: Added keytab testing cases for Heimdal KDC Added cases to handle the Wallet::Object::Keytab module using a Heimdal KDC as well as an MIT KDC. In most cases this is transparent, but some tests are skipped for Heimdal, and the commands run to test that the created principals and keytabs are correct are different for Heimdal. The code now branches based on the value of $Wallet::Config::KEYTAB_KRBTYPE. --- perl/t/keytab.t | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'perl/t') diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 8a11ad4..5c9ee68 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -8,7 +8,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 225; +use Test::More tests => 221; use Wallet::Admin; use Wallet::Config; @@ -154,8 +154,6 @@ sub enctypes { next unless /^ *\d+ /; my ($string) = /^\s*\d+\s+(\S+)/; next unless $string; - #$enctype = $enctype{lc $string} || 'UNKNOWN'; - #push (@enctypes, $enctype); push (@enctypes, $string); } close KTUTIL; -- cgit v1.2.3 From 99e39ac2639d99acdfd74acc05c25b5a95189860 Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 7 Jan 2010 09:33:50 -0800 Subject: Added ACL name to object history entries When listing an object history, ACLs were only shown as the ACL id. This changes that behavior to show the ACL name as well as ID. Where before it might say "set owner to 1", now it would say "set owner to ADMIN (1)". --- perl/Wallet/Object/Base.pm | 28 ++++++++++++++++++++++++++++ perl/t/server.t | 34 +++++++++++++++++----------------- 2 files changed, 45 insertions(+), 17 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm index 0f40028..f2568eb 100644 --- a/perl/Wallet/Object/Base.pm +++ b/perl/Wallet/Object/Base.pm @@ -445,6 +445,22 @@ sub flag_set { # History ############################################################################## +# Expand a given ACL id to add its name, for readability. Returns the +# original id alone if there was a problem finding the name. +sub format_acl_id { + my ($self, $id) = @_; + my $name = $id; + + my $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)"; + } + + return $name; +} + # Return the formatted history for a given object or undef on error. # Currently always returns the complete history, but eventually will need to # provide some way of showing only recent entries. @@ -476,6 +492,18 @@ 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]; + $old = $self->format_acl_id ($old) if defined ($old); + $new = $self->format_acl_id ($new) if defined ($new); + if (defined ($old) and defined ($new)) { + $output .= "set $field to $new (was $old)"; + } elsif (defined ($new)) { + $output .= "set $field to $new"; + } elsif (defined ($old)) { + $output .= "unset $field (was $old)"; + } } elsif ($data[0] eq 'set') { my $field = $data[1]; if (defined ($old) and defined ($new)) { diff --git a/perl/t/server.t b/perl/t/server.t index d4fd068..090387b 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -397,31 +397,31 @@ DATE set expires to $now by $admin from $host DATE unset expires (was $now) by $admin from $host -DATE set acl_get to 1 +DATE set acl_get to ADMIN (1) by $admin from $host -DATE unset acl_get (was 1) +DATE unset acl_get (was ADMIN (1)) by $admin from $host -DATE set acl_store to 1 +DATE set acl_store to ADMIN (1) by $admin from $host -DATE unset acl_store (was 1) +DATE unset acl_store (was ADMIN (1)) by $admin from $host -DATE set owner to 1 +DATE set owner to ADMIN (1) by $admin from $host -DATE set acl_get to 5 +DATE set acl_get to empty (5) by $admin from $host -DATE set acl_store to 5 +DATE set acl_store to empty (5) by $admin from $host -DATE unset acl_store (was 5) +DATE unset acl_store (was empty (5)) by $admin from $host -DATE unset owner (was 1) +DATE unset owner (was ADMIN (1)) by $admin from $host -DATE set owner to 1 +DATE set owner to ADMIN (1) by $admin from $host DATE set flag locked by $admin from $host DATE clear flag locked by $admin from $host -DATE unset owner (was 1) +DATE unset owner (was ADMIN (1)) by $admin from $host DATE set flag unchanging by $admin from $host @@ -527,7 +527,7 @@ is ($show, $expected, ' and show an object we own'); $history = <<"EOO"; DATE create by $admin from $host -DATE set owner to 2 +DATE set owner to user1 (2) by $admin from $host EOO $seen = $server->history ('base', 'service/user1'); @@ -608,13 +608,13 @@ is ($show, $expected, ' and show an object we jointly own'); $history = <<"EOO"; DATE create by $admin from $host -DATE set owner to 4 +DATE set owner to both (4) by $admin from $host -DATE set acl_show to 2 +DATE set acl_show to user1 (2) by $admin from $host -DATE set acl_destroy to 3 +DATE set acl_destroy to user2 (3) by $admin from $host -DATE set acl_flags to 2 +DATE set acl_flags to user1 (2) by $admin from $host DATE set flag unchanging by $user1 from $host @@ -679,7 +679,7 @@ is ($show, $expected, ' and show an object we own'); $history = <<"EOO"; DATE create by $admin from $host -DATE set owner to 3 +DATE set owner to user2 (3) by $admin from $host EOO $seen = $server->history ('base', 'service/user2'); -- cgit v1.2.3 From d684049761db4eb88cd936c530196ea89a524c07 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 19 Jan 2010 22:48:01 -0800 Subject: Coding style fixes for Perl wallet code Strip trailing whitespace, convert tabs to spaces, add newlines to exceptions, and remove a few stray blank lines and a few other minor coding style oddities. Make the SQL style consistent. --- perl/Wallet/Admin.pm | 105 +++++++++++++++---------------- perl/Wallet/Kadmin.pm | 10 +-- perl/Wallet/Kadmin/Heimdal.pm | 102 ++++++++++++++---------------- perl/Wallet/Kadmin/MIT.pm | 32 +++++----- perl/Wallet/Object/Base.pm | 12 ++-- perl/Wallet/Object/Keytab.pm | 13 ++-- perl/t/admin.t | 4 +- perl/t/keytab.t | 140 ++++++++++++++++++++---------------------- 8 files changed, 198 insertions(+), 220 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index 0e437ec..701c813 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -114,23 +114,22 @@ sub destroy { # Reporting ############################################################################## -# Given an ACL name, translate it to the ID for that ACL and return it. +# Given an ACL name, translate it to the ID for that ACL and return it. # Often this is unneeded and could be done with a join, but by doing it in a -# separate step, we can give an error for the specific case of someone +# separate step, we can give an error for the specific case of someone # searching for a non-existant ACL. sub acl_name_to_id { my ($self, $acl) = @_; my ($id); eval { - my $sql = 'select ac_id from acls where ac_name=?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($acl); - while (defined (my $row = $sth->fetchrow_hashref)) { - $id = $row->{'ac_id'}; - } - $self->{dbh}->commit; + my $sql = 'select ac_id from acls where ac_name = ?'; + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute ($acl); + while (defined (my $row = $sth->fetchrow_hashref)) { + $id = $row->{ac_id}; + } + $self->{dbh}->commit; }; - if (!defined $id || $id !~ /^\d+$/) { $self->error ("could not find the acl $acl"); return ''; @@ -155,7 +154,7 @@ sub list_objects_type { return ($sql, $type); } -# Return the SQL statement and search field required to find all objects +# Return the SQL statement and search field required to find all objects # owned by a given ACL. If the requested owner is 'null', then we ignore # this and do a different search for IS NULL. If the requested owner does # not actually match any ACLs, set an error and return the empty string. @@ -163,15 +162,15 @@ sub list_objects_owner { my ($self, $owner) = @_; my ($sth); if ($owner =~ /^null$/i) { - my $sql = 'select ob_type, ob_name from objects where ob_owner is 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); + return ($sql); } else { - my $id = $self->acl_name_to_id ($owner); - return '' unless $id; - my $sql = 'select ob_type, ob_name from objects where ob_owner=? + my $id = $self->acl_name_to_id ($owner); + return '' unless $id; + my $sql = 'select ob_type, ob_name from objects where ob_owner = ? order by objects.ob_type, objects.ob_name'; - return ($sql, $id); + return ($sql, $id); } } @@ -180,26 +179,24 @@ sub list_objects_owner { sub list_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'; + (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); } -# Return the SQL statement and search field required to find all objects +# Return the SQL statement and search field required to find all objects # that a given ACL has any permissions on. This expands from # list_objects_owner in that it will also match any records that have the ACL # set for get, store, show, destroy, or flags. If the requested owner does # not actually match any ACLs, set an error and return the empty string. sub list_objects_acl { my ($self, $acl) = @_; - my $id = $self->acl_name_to_id ($acl); return '' unless $id; - - 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'; + 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, $id, $id, $id, $id, $id, $id); } @@ -217,29 +214,29 @@ sub list_objects { my $sql = ''; my @search = (); if (!defined $type || $type eq '') { - ($sql) = $self->list_objects_all (); + ($sql) = $self->list_objects_all (); } else { - if (@args != 1) { - $self->error ("object searches require an argument to search"); - } elsif ($type eq 'type') { - ($sql, @search) = $self->list_objects_type (@args); - } elsif ($type eq 'owner') { - ($sql, @search) = $self->list_objects_owner (@args); - } elsif ($type eq 'flag') { - ($sql, @search) = $self->list_objects_flag (@args); - } elsif ($type eq 'acl') { - ($sql, @search) = $self->list_objects_acl (@args); - } else { - $self->error ("do not know search type: $type"); - } - return unless $sql; + if (@args != 1) { + $self->error ("object searches require an argument to search"); + } elsif ($type eq 'type') { + ($sql, @search) = $self->list_objects_type (@args); + } elsif ($type eq 'owner') { + ($sql, @search) = $self->list_objects_owner (@args); + } elsif ($type eq 'flag') { + ($sql, @search) = $self->list_objects_flag (@args); + } elsif ($type eq 'acl') { + ($sql, @search) = $self->list_objects_acl (@args); + } else { + $self->error ("do not know search type: $type"); + } + return unless $sql; } my @objects; eval { my $object; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (@search); + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute (@search); while (defined ($object = $sth->fetchrow_arrayref)) { push (@objects, [ @$object ]); } @@ -265,19 +262,19 @@ sub list_acls_all { # the db. sub list_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;'; + 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'; return ($sql); } # Returns the SQL statement and the field required to search the ACLs and -# return only those entries which contain a entries with identifiers +# return only those entries which contain a entries with identifiers # matching a particular given string. sub list_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'; + 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'; $identifier = '%'.$identifier.'%'; return ($sql, $type, $identifier); } @@ -299,11 +296,11 @@ sub list_acls { ($sql) = $self->list_acls_all (); } else { if ($type eq 'entry') { - if (@args == 0) { - $self->error ("acl searches require an argument to search"); - } else { - ($sql, @search) = $self->list_acls_entry (@args); - } + if (@args == 0) { + $self->error ("acl searches require an argument to search"); + } else { + ($sql, @search) = $self->list_acls_entry (@args); + } } elsif ($type eq 'empty') { ($sql) = $self->list_acls_empty (); } else { diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm index 33c84a1..200136c 100644 --- a/perl/Wallet/Kadmin.pm +++ b/perl/Wallet/Kadmin.pm @@ -27,8 +27,8 @@ $VERSION = '0.02'; ############################################################################## # Validate a principal with a submodule's validator. We can also do this via -# creating an object with new and then running valid_principal from that, -# but there are times we might wish to run it without going through the +# creating an object with new and then running valid_principal from that, +# but there are times we might wish to run it without going through the # object creation. sub valid_principal { my ($class, $principal) = @_; @@ -48,10 +48,10 @@ sub new { my ($class) = @_; my ($kadmin); if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - require Wallet::Kadmin::MIT; + require Wallet::Kadmin::MIT; $kadmin = Wallet::Kadmin::MIT->new (); } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - require Wallet::Kadmin::Heimdal; + require Wallet::Kadmin::Heimdal; $kadmin = Wallet::Kadmin::Heimdal->new (); } else { die "keytab krb server type not set to a valid value\n"; @@ -82,7 +82,7 @@ Wallet::Kadmin - Kadmin module wrapper for wallet keytabs =head1 DESCRIPTION Wallet::Kadmin is a wrapper to modules that provide an interface for keytab -integration with the wallet. Each module is meant to interface with a +integration with the wallet. Each module is meant to interface with a specific type of Kerberos implementation, such as MIT Kerberos or Heimdal Kerberos, and provide a standndard set of API calls used to interact with that implementation's kadmind. diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm index e4d175b..a8859bf 100644 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ b/perl/Wallet/Kadmin/Heimdal.pm @@ -15,8 +15,7 @@ require 5.006; use strict; use vars qw($VERSION); -use Heimdal::Kadm5 qw (KRB5_KDB_DISALLOW_ALL_TIX); - +use Heimdal::Kadm5 qw(KRB5_KDB_DISALLOW_ALL_TIX); use Wallet::Config (); # This version should be increased on any code change to this module. Always @@ -37,7 +36,7 @@ sub valid_principal { return scalar ($principal =~ m,^[\w-]+(/[\w_.-]+)?\z,); } -# Create a Heimdal::Kadm5 client object and return it. It should load +# Create a Heimdal::Kadm5 client object and return it. It should load # configuration from Wallet::Config. sub kadmin_client { unless (defined ($Wallet::Config::KEYTAB_PRINCIPAL) @@ -45,15 +44,13 @@ sub kadmin_client { and defined ($Wallet::Config::KEYTAB_REALM)) { die "keytab object implementation not configured\n"; } - my $server = $Wallet::Config::KEYTAB_HOST || 'localhost'; - my $client = Heimdal::Kadm5::Client->new( - RaiseErrors => 1, - Server => $server, - Principal => $Wallet::Config::KEYTAB_PRINCIPAL, - Realm => $Wallet::Config::KEYTAB_REALM, - Keytab => $Wallet::Config::KEYTAB_FILE, - ); + my @options = (RaiseErrors => 1, + Server => $server, + Principal => $Wallet::Config::KEYTAB_PRINCIPAL, + Realm => $Wallet::Config::KEYTAB_REALM, + Keytab => $Wallet::Config::KEYTAB_FILE); + my $client = Heimdal::Kadm5::Client->new (@options); return $client; } @@ -70,16 +67,8 @@ sub exists { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; } my $kadmin = $self->{client}; - my $princdata = eval { $kadmin->getPrincipal ($principal) }; - - if ($@) { - die $@; - return 0; - } elsif ($princdata) { - return 1; - } else { - return 0; - } + my $princdata = $kadmin->getPrincipal ($principal); + return $princdata ? 1 : 0; } # Create a principal in Kerberos. Since this is only called by create, it @@ -95,7 +84,7 @@ sub addprinc { if ($Wallet::Config::KEYTAB_REALM) { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; } - die "error adding principal $principal: $@" if $@; + die "error adding principal $principal: $@\n" if $@; return 1 if $exists; # The way Heimdal::Kadm5 works, we create a principal object, create the @@ -106,20 +95,19 @@ sub addprinc { my $kadmin = $self->{client}; my $princdata = $kadmin->makePrincipal ($principal); - # Disable the principal before creating, until we've randomized the + # Disable the principal before creating, until we've randomized the # password. my $attrs = $princdata->getAttributes; $attrs |= KRB5_KDB_DISALLOW_ALL_TIX; $princdata->setAttributes ($attrs); my $password = 'inactive'; - my $retval = eval { $kadmin->createPrincipal ($princdata, $password, 0) }; - die "error adding principal $principal: $@" if $@; - $retval = eval { $kadmin->randKeyPrincipal ($principal) }; - die "error adding principal $principal: $@" if $@; - $retval = eval { $kadmin->enablePrincipal ($principal) }; + eval { + $kadmin->createPrincipal ($princdata, $password, 0); + $kadmin->randKeyPrincipal ($principal); + $kadmin->enablePrincipal ($principal); + }; die "error adding principal $principal: $@" if $@; - return 1; } @@ -130,7 +118,7 @@ sub addprinc { sub ktadd { my ($self, $principal, $file, @enctypes) = @_; unless ($self->valid_principal ($principal)) { - die ("invalid principal name: $principal"); + die "invalid principal name: $principal\n"; } if ($Wallet::Config::KEYTAB_REALM) { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; @@ -138,35 +126,35 @@ sub ktadd { # The way Heimdal works, you can only remove enctypes from a principal, # not add them back in. So we need to run randkeyPrincipal first each - # time to restore all possible enctypes and then whittle them back down + # time to restore all possible enctypes and then whittle them back down # to those we have been asked for this time. my $kadmin = $self->{client}; eval { $kadmin->randKeyPrincipal ($principal) }; - die "error creating keytab for $principal: could not reinit enctypes: $@" + die "error creating keytab for $principal: could not reinit enctypes: $@\n" if $@; my $princdata = eval { $kadmin->getPrincipal ($principal) }; if ($@) { - die "error creating keytab for $principal: $@"; + die "error creating keytab for $principal: $@\n"; } elsif (!$princdata) { - die "error creating keytab for $principal: principal does not exist"; + die "error creating keytab for $principal: principal does not exist\n"; } # Now actually remove any non-requested enctypes, if we requested any. if (@enctypes) { - my (%wanted); - my $alltypes = $princdata->getKeytypes (); - foreach (@enctypes) { $wanted{$_} = 1 } - foreach my $key (@{$alltypes}) { - my $keytype = ${$key}[0]; - next if exists $wanted{$keytype}; - eval { $princdata->delKeytypes ($keytype) }; - die "error removing keytype $keytype from the keytab: $@" if $@; - } - eval { $kadmin->modifyPrincipal ($princdata) }; + my (%wanted); + my $alltypes = $princdata->getKeytypes (); + foreach (@enctypes) { $wanted{$_} = 1 } + foreach my $key (@{$alltypes}) { + my $keytype = ${$key}[0]; + next if exists $wanted{$keytype}; + eval { $princdata->delKeytypes ($keytype) }; + die "error removing keytype $keytype from the keytab: $@\n" if $@; + } + eval { $kadmin->modifyPrincipal ($princdata) }; } eval { $kadmin->extractKeytab ($princdata, $file) }; - die "error creating keytab for principal: $@" if $@; + die "error creating keytab for principal: $@\n" if $@; return 1; } @@ -177,7 +165,7 @@ sub ktadd { sub delprinc { my ($self, $principal) = @_; unless ($self->valid_principal ($principal)) { - die ("invalid principal name: $principal"); + die "invalid principal name: $principal\n"; } my $exists = eval { $self->exists ($principal) }; die $@ if $@; @@ -190,7 +178,7 @@ sub delprinc { my $kadmin = $self->{client}; my $retval = eval { $kadmin->deletePrincipal ($principal) }; - die "error deleting $principal: $@" if $@; + die "error deleting $principal: $@\n" if $@; return 1; } @@ -199,12 +187,12 @@ sub delprinc { ############################################################################## # Create a new MIT kadmin object. Very empty for the moment, but later it -# will probably fill out if we go to using a module rather than calling +# will probably fill out if we go to using a module rather than calling # kadmin directly. sub new { my ($class) = @_; my $self = { - client => kadmin_client (), + client => kadmin_client (), }; bless ($self, $class); return $self; @@ -235,7 +223,7 @@ Wallet::Kadmin::MIT is an interface for keytab integration with the wallet, specifically for using kadmin to create, delete, and add enctypes to keytabs. It implments the wallet kadmin API and provides the necessary glue to MIT Kerberos installs for each of these functions, while allowing the wallet -to keep the details of what type of Kerberos installation is being used +to keep the details of what type of Kerberos installation is being used abstracted. A keytab is an on-disk store for the key or keys for a Kerberos principal. @@ -254,15 +242,15 @@ information about how to set wallet configuration. =item addprinc(PRINCIPAL) -Adds a new principal with a given name. The principal is created with a -random password, and any other flags set by Wallet::Config. Returns true on +Adds a new principal with a given name. The principal is created with a +random password, and any other flags set by Wallet::Config. Returns true on success, or throws an error if there was a failure in adding the principal. -If the principal already exists, return true as we are bringing our +If the principal already exists, return true as we are bringing our expectations in line with reality. =item addprinc(PRINCIPAL) -Removes a principal with the given name. Returns true on success, or throws +Removes a principal with the given name. Returns true on success, or throws an error if there was a failure in removing the principal. If the principal does not exist, return true as we are bringing our expectations in line with reality. @@ -270,8 +258,8 @@ reality. =item ktadd(PRINCIPAL, FILE, ENCTYPES) Creates a new keytab for the given principal, as the given file, limited to -the enctypes supplied. The enctype values must be enctype strings recognized -by Kerberos (strings like C or C). An error is +the enctypes supplied. The enctype values must be enctype strings recognized +by Kerberos (strings like C or C). An error is thrown on failure or if the creation fails, otherwise true is returned. =back @@ -279,7 +267,7 @@ thrown on failure or if the creation fails, otherwise true is returned. =head1 LIMITATIONS Currently, this implementation calls an external B program rather - than using a native Perl module and therefore requires B be + than using a native Perl module and therefore requires B be installed and parses its output. It may miss some error conditions if the output of B ever changes. diff --git a/perl/Wallet/Kadmin/MIT.pm b/perl/Wallet/Kadmin/MIT.pm index b7d4913..7bbb248 100644 --- a/perl/Wallet/Kadmin/MIT.pm +++ b/perl/Wallet/Kadmin/MIT.pm @@ -130,7 +130,7 @@ sub addprinc { sub ktadd { my ($self, $principal, $file, @enctypes) = @_; unless ($self->valid_principal ($principal)) { - die ("invalid principal name: $principal"); + die "invalid principal name: $principal\n"; } if ($Wallet::Config::KEYTAB_REALM) { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; @@ -143,7 +143,7 @@ sub ktadd { my $output = eval { $self->kadmin ("$command $principal") }; die ($@) if ($@); if ($output =~ /^(?:kadmin|ktadd): (.*)/m) { - die ("error creating keytab for $principal: $1"); + die "error creating keytab for $principal: $1\n"; } return 1; } @@ -154,7 +154,7 @@ sub ktadd { sub delprinc { my ($self, $principal) = @_; unless ($self->valid_principal ($principal)) { - die ("invalid principal name: $principal"); + die "invalid principal name: $principal\n"; } my $exists = eval { $self->exists ($principal) }; die $@ if $@; @@ -167,7 +167,7 @@ sub delprinc { my $output = eval { $self->kadmin ("delprinc -force $principal") }; die $@ if $@; if ($output =~ /^delete_principal: (.*)/m) { - die ("error deleting $principal: $1"); + die "error deleting $principal: $1\n"; } return 1; } @@ -177,12 +177,11 @@ sub delprinc { ############################################################################## # Create a new MIT kadmin object. Very empty for the moment, but later it -# will probably fill out if we go to using a module rather than calling +# will probably fill out if we go to using a module rather than calling # kadmin directly. sub new { my ($class) = @_; - my $self = { - }; + my $self = {}; bless ($self, $class); return $self; } @@ -212,7 +211,7 @@ Wallet::Kadmin::MIT is an interface for keytab integration with the wallet, specifically for using kadmin to create, delete, and add enctypes to keytabs. It implments the wallet kadmin API and provides the necessary glue to MIT Kerberos installs for each of these functions, while allowing the wallet -to keep the details of what type of Kerberos installation is being used +to keep the details of what type of Kerberos installation is being used abstracted. A keytab is an on-disk store for the key or keys for a Kerberos principal. @@ -231,15 +230,15 @@ information about how to set wallet configuration. =item addprinc(PRINCIPAL) -Adds a new principal with a given name. The principal is created with a -random password, and any other flags set by Wallet::Config. Returns true on +Adds a new principal with a given name. The principal is created with a +random password, and any other flags set by Wallet::Config. Returns true on success, or throws an error if there was a failure in adding the principal. -If the principal already exists, return true as we are bringing our +If the principal already exists, return true as we are bringing our expectations in line with reality. =item addprinc(PRINCIPAL) -Removes a principal with the given name. Returns true on success, or throws +Removes a principal with the given name. Returns true on success, or throws an error if there was a failure in removing the principal. If the principal does not exist, return true as we are bringing our expectations in line with reality. @@ -247,8 +246,8 @@ reality. =item ktadd(PRINCIPAL, FILE, ENCTYPES) Creates a new keytab for the given principal, as the given file, limited to -the enctypes supplied. The enctype values must be enctype strings recognized -by Kerberos (strings like C or C). An error is +the enctypes supplied. The enctype values must be enctype strings recognized +by Kerberos (strings like C or C). An error is thrown on failure or if the creation fails, otherwise true is returned. =back @@ -256,7 +255,7 @@ thrown on failure or if the creation fails, otherwise true is returned. =head1 LIMITATIONS Currently, this implementation calls an external B program rather - than using a native Perl module and therefore requires B be +than using a native Perl module and therefore requires B be installed and parses its output. It may miss some error conditions if the output of B ever changes. @@ -269,7 +268,6 @@ from L. =head1 AUTHORS -Russ Allbery -Jon Robertson +Russ Allbery and Jon Robertson . =cut diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm index f2568eb..fea0320 100644 --- a/perl/Wallet/Object/Base.pm +++ b/perl/Wallet/Object/Base.pm @@ -445,7 +445,7 @@ sub flag_set { # History ############################################################################## -# Expand a given ACL id to add its name, for readability. Returns the +# Expand a given ACL id to add its name, for readability. Returns the # original id alone if there was a problem finding the name. sub format_acl_id { my ($self, $id) = @_; @@ -455,7 +455,7 @@ sub format_acl_id { my $sth = $self->{dbh}->prepare ($sql); $sth->execute ($id); if (my @ref = $sth->fetchrow_array) { - $name = $ref[0] . " ($id)"; + $name = $ref[0] . " ($id)"; } return $name; @@ -492,11 +492,11 @@ 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_/)) { + } elsif ($data[0] eq 'set' + and ($data[1] eq 'owner' or $data[1] =~ /^acl_/)) { my $field = $data[1]; - $old = $self->format_acl_id ($old) if defined ($old); - $new = $self->format_acl_id ($new) if defined ($new); + $old = $self->format_acl_id ($old) if defined ($old); + $new = $self->format_acl_id ($new) if defined ($new); if (defined ($old) and defined ($new)) { $output .= "set $field to $new (was $old)"; } elsif (defined ($new)) { diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index b1c9d6d..a361599 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -1,7 +1,7 @@ # Wallet::Object::Keytab -- Keytab object implementation for the wallet. # # Written by Russ Allbery -# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2009 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -477,15 +477,14 @@ sub new { # caller. sub create { my ($class, $type, $name, $dbh, $creator, $host, $time) = @_; - my $self = { - dbh => $dbh, - kadmin => undef, + my $self = { + dbh => $dbh, + kadmin => undef, }; bless $self, $class; my $kadmin = Wallet::Kadmin->new (); $self->{kadmin} = $kadmin; $kadmin->addprinc ($name); - $self = $class->SUPER::create ($type, $name, $dbh, $creator, $host, $time); $self->{kadmin} = $kadmin; return $self; @@ -556,8 +555,8 @@ sub get { my $kadmin = $self->{kadmin}; my $retval = eval { $kadmin->ktadd ($self->{name}, $file, @enctypes) }; if ($@) { - $self->error ($@); - return; + $self->error ($@); + return; } return unless $retval; local *KEYTAB; diff --git a/perl/t/admin.t b/perl/t/admin.t index 77c786d..e963857 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -120,7 +120,7 @@ is ($lines[2][1], 'admin@EXAMPLE.COM', ' and the right identifier'); # owned by ADMIN or with any permissions from it. is ($server->create ('base', 'service/null'), 1, 'Creating base:service/null succeeds'); -is ($server->acl ('base', 'service/foo', 'get', 'ADMIN'), 1, +is ($server->acl ('base', 'service/foo', 'get', 'ADMIN'), 1, 'Changing the get ACL for the search also does'); @lines = $admin->list_objects ('owner', 'ADMIN'); is (scalar (@lines), 1, 'Searching for objects owned by ADMIN finds one'); @@ -150,7 +150,7 @@ is ($lines[2][1], 'service/null', ' and the right name'); is (scalar (@lines), 0, 'Searching for all objects of type keytab finds none'); # Test setting a flag, searching for objects with it, and then clearing it. -is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, +is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, 'Setting a flag works'); @lines = $admin->list_objects ('flag', 'unchanging'); is (scalar (@lines), 1, 'Searching for all objects with that flag finds one'); diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 5c9ee68..3cd77d8 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -8,7 +8,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 221; +use Test::More tests => 219; use Wallet::Admin; use Wallet::Config; @@ -57,15 +57,15 @@ sub system_quiet { sub create { my ($principal) = @_; if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', - '-t', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - '-q', "addprinc -clearpolicy -randkey $principal"); + my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', + '-t', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + '-q', "addprinc -clearpolicy -randkey $principal"); } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, - '-K', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - 'add', $principal); + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, + '-K', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + 'add', $principal); } system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args); } @@ -76,15 +76,15 @@ sub destroy { my ($principal) = @_; my (@args); if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', - '-t', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - '-q', "delprinc -force $principal"); + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', + '-t', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + '-q', "delprinc -force $principal"); } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, - '-K', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - 'delete', $principal); + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, + '-K', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + 'delete', $principal); } system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args); } @@ -95,15 +95,15 @@ sub created { my ($principal) = @_; $principal .= '@' . $Wallet::Config::KEYTAB_REALM; if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - local $ENV{KRB5CCNAME} = 'krb5cc_temp'; - getcreds ('t/data/test.keytab', $Wallet::Config::KEYTAB_PRINCIPAL); - return (system_quiet ('kvno', $principal) == 0); + local $ENV{KRB5CCNAME} = 'krb5cc_temp'; + getcreds ('t/data/test.keytab', $Wallet::Config::KEYTAB_PRINCIPAL); + return (system_quiet ('kvno', $principal) == 0); } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, - '-K', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - 'get', $principal); - return (system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args) == 0); + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, + '-K', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + 'get', $principal); + return (system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args) == 0); } } @@ -135,28 +135,28 @@ sub enctypes { my @enctypes; if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - open (KLIST, '-|', 'klist', '-ke', 'keytab') - or die "cannot run klist: $!\n"; - local $_; - while () { - next unless /^ *\d+ /; - my ($string) = /\((.*)\)\s*$/; - next unless $string; - $enctype = $enctype{lc $string} || 'UNKNOWN'; - push (@enctypes, $enctype); - } - close KLIST; + open (KLIST, '-|', 'klist', '-ke', 'keytab') + or die "cannot run klist: $!\n"; + local $_; + while () { + next unless /^ *\d+ /; + my ($string) = /\((.*)\)\s*$/; + next unless $string; + $enctype = $enctype{lc $string} || 'UNKNOWN'; + push (@enctypes, $enctype); + } + close KLIST; } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - open (KTUTIL, '-|', 'ktutil', '-k', 'keytab', 'list') - or die "cannot run ktutil: $!\n"; - local $_; - while () { - next unless /^ *\d+ /; - my ($string) = /^\s*\d+\s+(\S+)/; - next unless $string; - push (@enctypes, $string); - } - close KTUTIL; + open (KTUTIL, '-|', 'ktutil', '-k', 'keytab', 'list') + or die "cannot run ktutil: $!\n"; + local $_; + while () { + next unless /^ *\d+ /; + my ($string) = /^\s*\d+\s+(\S+)/; + next unless $string; + push (@enctypes, $string); + } + close KTUTIL; } unlink 'keytab'; return sort @enctypes; @@ -298,16 +298,15 @@ EOO is ($object->error, 'KEYTAB_TMP configuration variable not set', ' with the right error'); $Wallet::Config::KEYTAB_TMP = '.'; - SKIP: { - skip ' no kadmin program test for Heimdal', 2 - if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; - - $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; - $data = $object->get (@trace); - is ($data, undef, 'Cope with a failure to run kadmin'); - like ($object->error, qr{^cannot run /some/nonexistent/file: }, - ' with the right error'); - $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; + SKIP: { + skip 'no kadmin program test for Heimdal', 2 + if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; + $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; + $data = $object->get (@trace); + is ($data, undef, 'Cope with a failure to run kadmin'); + like ($object->error, qr{^cannot run /some/nonexistent/file: }, + ' with the right error'); + $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; } destroy ('wallet/one'); $data = $object->get (@trace); @@ -323,19 +322,16 @@ EOO }; ok (defined ($object), 'Creating good principal succeeds'); ok (created ('wallet/one'), ' and the principal was created'); - - SKIP: { - skip ' no kadmin program test for Heimdal', 2 - if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; - - $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; - is ($object->destroy (@trace), undef, - ' and destroying it with bad kadmin fails'); - like ($object->error, qr{^cannot run /some/nonexistent/file: }, - ' with the right error'); - $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; + SKIP: { + skip 'no kadmin program test for Heimdal', 2 + if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; + $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; + is ($object->destroy (@trace), undef, + ' and destroying it with bad kadmin fails'); + like ($object->error, qr{^cannot run /some/nonexistent/file: }, + ' with the right error'); + $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; } - is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); is ($object->destroy (@trace), undef, ' and destroying it fails'); is ($object->error, "cannot destroy keytab:wallet/one: object is locked", @@ -713,8 +709,10 @@ EOO # Tests for enctype restriction. SKIP: { - skip 'no keytab configuration', 36 unless (-f 't/data/test.keytab' - && $Wallet::Config::KEYTAB_KRBTYPE eq 'MIT'); + unless (-f 't/data/test.keytab' + && $Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + skip 'no keytab configuration', 36; + } # Set up our configuration. $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; @@ -810,7 +808,6 @@ EOO ok (defined ($keytab), ' and retrieving the keytab still works'); @values = enctypes ($keytab); is ("@values", $enctypes[0], ' and it has the right enctype'); - ok (defined ($one), ' and recreating it succeeds'); is ($one->attr ('enctypes', [ $enctypes[1] ], @trace), 1, 'Setting a different single enctype works'); @values = $one->attr ('enctypes'); @@ -819,7 +816,6 @@ EOO ok (defined ($keytab), ' and retrieving the keytab still works'); @values = enctypes ($keytab); is ("@values", $enctypes[1], ' and it has the right enctype'); - ok (defined ($one), ' and recreating it succeeds'); is ($one->attr ('enctypes', [ @enctypes[0..1] ], @trace), 1, 'Setting two enctypes works'); @values = $one->attr ('enctypes'); -- cgit v1.2.3 From aca12f7b67b987c4392d85b4aa9d2dc1861b7556 Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 21 Jan 2010 19:06:54 -0800 Subject: Replaced perl/t/admin.t tests removed earlier Several tests were removed in an earlier edit that should not have been. As far as I can tell, they were removed completely by accident. These missing tests were causing the test suite to fail. --- perl/t/admin.t | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'perl/t') diff --git a/perl/t/admin.t b/perl/t/admin.t index e963857..f94b39b 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -7,7 +7,7 @@ # # See LICENSE for licensing terms. -use Test::More tests => 77; +use Test::More tests => 83; use Wallet::Admin; use Wallet::Schema; @@ -54,6 +54,15 @@ is ($objects[0][1], 'service/admin', ' and the right name'); is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), 1, 'Registering Wallet::ACL::Base works'); +# Create another ACL. +is ($server->acl_create ('first'), 1, 'ACL creation succeeds'); +@acls = $admin->list_acls; +is (scalar (@acls), 2, ' and now there are two ACLs'); +is ($acls[0][0], 1, ' and the first ID is correct'); +is ($acls[0][1], 'ADMIN', ' and the first name is correct'); +is ($acls[1][0], 2, ' and the second ID is correct'); +is ($acls[1][1], 'first', ' and the second name is correct'); + # Delete that ACL and create another. is ($server->acl_create ('second'), 1, 'Second ACL creation succeeds'); is ($server->acl_destroy ('first'), 1, ' and deletion of the first succeeds'); -- cgit v1.2.3 From 42ff8edd0059988c5fa9af98ead4c19b3b52b37a Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 21 Jan 2010 19:24:59 -0800 Subject: Added new ACL format to the object tests Added the new ACL format to perl/t/object.t's idea of what an object's history was meant to be. This involved switching from acl id to acl name plus id -- ie: '1' to 'ADMIN (1)'. --- perl/t/object.t | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) (limited to 'perl/t') diff --git a/perl/t/object.t b/perl/t/object.t index a40a412..46e67e5 100755 --- a/perl/t/object.t +++ b/perl/t/object.t @@ -255,11 +255,11 @@ ok (defined ($object), 'Recreating the object succeeds'); $output = <<"EOO"; $date create by $user from $host -$date set owner to 1 +$date set owner to ADMIN (1) by $user from $host -$date unset owner (was 1) +$date unset owner (was ADMIN (1)) by $user from $host -$date set owner to 1 +$date set owner to ADMIN (1) by $user from $host $date set expires to $now by $user from $host @@ -267,35 +267,35 @@ $date unset expires (was $now) by $user from $host $date set expires to $now by $user from $host -$date set acl_get to 1 +$date set acl_get to ADMIN (1) by $user from $host -$date unset acl_get (was 1) +$date unset acl_get (was ADMIN (1)) by $user from $host -$date set acl_get to 1 +$date set acl_get to ADMIN (1) by $user from $host -$date set acl_store to 1 +$date set acl_store to ADMIN (1) by $user from $host -$date unset acl_store (was 1) +$date unset acl_store (was ADMIN (1)) by $user from $host -$date set acl_store to 1 +$date set acl_store to ADMIN (1) by $user from $host -$date set acl_show to 1 +$date set acl_show to ADMIN (1) by $user from $host -$date unset acl_show (was 1) +$date unset acl_show (was ADMIN (1)) by $user from $host -$date set acl_show to 1 +$date set acl_show to ADMIN (1) by $user from $host -$date set acl_destroy to 1 +$date set acl_destroy to ADMIN (1) by $user from $host -$date unset acl_destroy (was 1) +$date unset acl_destroy (was ADMIN (1)) by $user from $host -$date set acl_destroy to 1 +$date set acl_destroy to ADMIN (1) by $user from $host -$date set acl_flags to 1 +$date set acl_flags to ADMIN (1) by $user from $host -$date unset acl_flags (was 1) +$date unset acl_flags (was ADMIN (1)) by $user from $host -$date set acl_flags to 1 +$date set acl_flags to ADMIN (1) by $user from $host $date set flag locked by $user from $host -- cgit v1.2.3 From 854063db2095fac8079260b414714d239221fdff Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 21 Jan 2010 20:53:20 -0800 Subject: Removed valid_principal as a Kadmin API function valid_principal has been removed from Wallet::Kadmin and Wallet::Kadmin::Heimdal. An accessor for it in Wallet::Object::Keytab has also been removed, as have the tests in perl/t/keytab.t for the function. It still remains within Wallet::Kadmin::MIT and is used there, but only as a private method for flagging what the kadmin command-line interface cannot handle. --- perl/Wallet/Kadmin.pm | 26 +------------------------- perl/Wallet/Kadmin/Heimdal.pm | 21 +-------------------- perl/Wallet/Object/Keytab.pm | 9 +-------- perl/t/keytab.t | 28 +++++++++++++--------------- 4 files changed, 16 insertions(+), 68 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm index 0a9bd43..95859a9 100644 --- a/perl/Wallet/Kadmin.pm +++ b/perl/Wallet/Kadmin.pm @@ -20,27 +20,12 @@ use Wallet::Config (); # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.02'; +$VERSION = '0.03'; ############################################################################## # Public methods ############################################################################## -# Validate a principal with a submodule's validator. We can also do this via -# creating an object with new and then running valid_principal from that, -# but there are times we might wish to run it without going through the -# object creation. -sub valid_principal { - my ($class, $principal) = @_; - if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - require Wallet::Kadmin::MIT; - return Wallet::Kadmin::MIT->valid_principal ($principal); - } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - require Wallet::Kadmin::Heimdal; - return Wallet::Kadmin::Heimdal->valid_principal ($principal); - } -} - # Create a new kadmin object, by finding the type requested in the wallet # config and passing off to the proper module. Returns the object directly # from the specific Wallet::Kadmin::* module. @@ -111,15 +96,6 @@ Finds the proper Kerberos implementation and calls the new() constructor for that implementation's module, returning the result. If the implementation is not recognized or set, die with an error message. -=item valid_principal(PRINCIPAL) - -Finds the proper Kerberos implementation and calls its own valid_principal -method, returning the result. This tells whether a principal is valid for -that implementation. This can be achieved by using new() and then directly -calling valid_principal on the returned object -- this method is a shortcut -in case we want to check validity without creating the object and worrying -about proper setup. - =back =head1 SEE ALSO diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm index a8859bf..a05362e 100644 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ b/perl/Wallet/Kadmin/Heimdal.pm @@ -21,21 +21,12 @@ use Wallet::Config (); # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.01'; +$VERSION = '0.02'; ############################################################################## # kadmin Interaction ############################################################################## -# Make sure that principals are well-formed and don't contain characters that -# will cause us problems when talking to kadmin. Takes a principal and -# returns true if it's okay, false otherwise. Note that we do not permit -# realm information here. -sub valid_principal { - my ($self, $principal) = @_; - return scalar ($principal =~ m,^[\w-]+(/[\w_.-]+)?\z,); -} - # Create a Heimdal::Kadm5 client object and return it. It should load # configuration from Wallet::Config. sub kadmin_client { @@ -62,7 +53,6 @@ sub kadmin_client { # so, false otherwise. Throws an exception if an error. sub exists { my ($self, $principal) = @_; - return unless $self->valid_principal ($principal); if ($Wallet::Config::KEYTAB_REALM) { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; } @@ -76,9 +66,6 @@ sub exists { # undef. sub addprinc { my ($self, $principal) = @_; - unless ($self->valid_principal ($principal)) { - die "invalid principal name $principal\n"; - } my $exists = eval { $self->exists ($principal) }; if ($Wallet::Config::KEYTAB_REALM) { @@ -117,9 +104,6 @@ sub addprinc { # error. sub ktadd { my ($self, $principal, $file, @enctypes) = @_; - unless ($self->valid_principal ($principal)) { - die "invalid principal name: $principal\n"; - } if ($Wallet::Config::KEYTAB_REALM) { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; } @@ -164,9 +148,6 @@ sub ktadd { # exist, return success; we're bringing reality in line with our expectations. sub delprinc { my ($self, $principal) = @_; - unless ($self->valid_principal ($principal)) { - die "invalid principal name: $principal\n"; - } my $exists = eval { $self->exists ($principal) }; die $@ if $@; if (not $exists) { diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index a361599..092e973 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -24,7 +24,7 @@ use Wallet::Kadmin; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.06'; +$VERSION = '0.07'; ############################################################################## # AFS kaserver synchronization @@ -490,13 +490,6 @@ sub create { return $self; } -# Provides wrapper to individual Kadmin class's valid_principal. Here only -# to help expose for testing. -sub valid_principal { - my ($self, $principal) = @_; - return Wallet::Kadmin->valid_principal ($principal); -} - # Override destroy to delete the principal out of Kerberos as well. sub destroy { my ($self, $user, $host, $time) = @_; diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 3cd77d8..7745290 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -8,7 +8,8 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 219; +use Test::More tests => 208 +; use Wallet::Admin; use Wallet::Config; @@ -192,18 +193,6 @@ my $dbh = $admin->dbh; my $history = ''; my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); -# Do some white-box testing of the principal validation regex. -for my $bad (qw{service\* = host/foo+bar host/foo/bar /bar bar/ - rcmd.foo}) { - ok (! Wallet::Object::Keytab->valid_principal ($bad), - "Invalid principal name $bad"); -} -for my $good (qw{service service/foo bar foo/bar host/example.org - aservice/foo}) { - ok (Wallet::Object::Keytab->valid_principal ($good), - "Valid principal name $good"); -} - # Basic keytab creation and manipulation tests. SKIP: { skip 'no keytab configuration', 49 unless -f 't/data/test.keytab'; @@ -228,12 +217,21 @@ SKIP: { Wallet::Object::Keytab->create ('keytab', "wallet\nf", $dbh, @trace) }; is ($object, undef, 'Creating malformed principal fails'); - is ($@, "invalid principal name wallet\nf\n", ' with the right error'); + if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + is ($@, "invalid principal name wallet\nf\n", ' with the right error'); + } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { + like ($@, qr/^error adding principal wallet\nf/, + ' with the right error'); + } $object = eval { Wallet::Object::Keytab->create ('keytab', '', $dbh, @trace) }; is ($object, undef, 'Creating empty principal fails'); - is ($@, "invalid principal name \n", ' with the right error'); + if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + is ($@, "invalid principal name \n", ' with the right error'); + } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { + like ($@, qr/^error adding principal \@/, ' with the right error'); + } $object = eval { Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) }; -- cgit v1.2.3 From 9347a25fdb92bae16a205da218fa153279765fbc Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 21 Jan 2010 22:24:43 -0800 Subject: Added test for Wallet::Kadmin basic function Created perl/t/kadmin.t, which performs tests against the Wallet::Kadmin basic API. We only test that Wallet::Kadmin->new () works for both MIT and Heimdal (though doesn't make a connection), and the MIT valid_principal private method. --- perl/t/kadmin.t | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100755 perl/t/kadmin.t (limited to 'perl/t') diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t new file mode 100755 index 0000000..7423ed1 --- /dev/null +++ b/perl/t/kadmin.t @@ -0,0 +1,53 @@ +#!/usr/bin/perl -w +# +# t/kadmin.t -- Tests for the kadmin object implementation. +# +# Written by Jon Robertson +# Copyright 2009 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 15; + +use Wallet::Admin; +use Wallet::Config; +use Wallet::Kadmin; +use Wallet::Kadmin::Heimdal; +use Wallet::Kadmin::MIT; + +use lib 't/lib'; +use Util; + +# We test a Wallet::Kadmin::* module's actual workings in the keytab.t tests. +# The only things we want to test here are that each module is found, that +# Wallet::Kadmin itself delegates to them, and that the private MIT principal +# validation works as it should. +for my $bad (qw{service\* = host/foo+bar host/foo/bar /bar bar/ + rcmd.foo}) { + ok (! Wallet::Kadmin::MIT->valid_principal ($bad), + "Invalid principal name $bad"); +} +for my $good (qw{service service/foo bar foo/bar host/example.org + aservice/foo}) { + ok (Wallet::Kadmin::MIT->valid_principal ($good), + "Valid principal name $good"); +} + +# Test creating an MIT object. We don't care about anything but correctly +# creating it -- testing operations is for the keytab tests. +$Wallet::Config::KEYTAB_KRBTYPE = 'MIT'; +my $kadmin = Wallet::Kadmin->new (); +ok (defined ($kadmin), 'MIT kadmin object created'); + +# Test creating a Heimdal object. For us to test a working Heimdal object, +# we need a properly configured Heimdal KDC. So instead, we deliberately +# connect without configuration to get the error. That at least tests that +# we can find the Heimdal module and it dies how it should. +undef $Wallet::Config::KEYTAB_PRINCIPAL; +undef $Wallet::Config::KEYTAB_FILE; +undef $Wallet::Config::KEYTAB_REALM; +undef $kadmin; +$Wallet::Config::KEYTAB_KRBTYPE = 'Heimdal'; +$kadmin = eval { Wallet::Kadmin->new () }; +is ($kadmin, undef, 'Heimdal fails properly.'); -- cgit v1.2.3 From dad764bc84d371ffc775e66b942ecbbc59f05c8e Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Tue, 26 Jan 2010 14:45:40 -0800 Subject: Added way to clean things during a fork for kadmin The MIT kadmin module currently directly runs the MIT kadmin program. Some data needs to be cleaned during the forks for this. This provides a callback that can be registered and is called during the fork process, currently just to mark database handles inactive. It was added to both the MIT and Heimdal modules, though it's only a stub in the Heimdal module. Heimdal is not forking kadmin, but the stub is there in order to allow the caller to not care which module is being used and just always register the callbacks. --- perl/Wallet/Kadmin/Heimdal.pm | 5 +++++ perl/Wallet/Kadmin/MIT.pm | 12 +++++++----- perl/Wallet/Object/Keytab.pm | 13 ++++++++++++- perl/t/kadmin.t | 11 ++++++++--- 4 files changed, 32 insertions(+), 9 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm index 9c2805b..b0010a5 100644 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ b/perl/Wallet/Kadmin/Heimdal.pm @@ -39,6 +39,11 @@ sub error { return $self->{error}; } +# Set a callback to be called for forked kadmin processes. This does nothing +# for Heimdal, as we're not forking anything, but remains for compatibility +# with the MIT kadmin module. +sub fork_callback { } + ############################################################################## # kadmin Interaction ############################################################################## diff --git a/perl/Wallet/Kadmin/MIT.pm b/perl/Wallet/Kadmin/MIT.pm index 2e9b0b4..c3ad901 100644 --- a/perl/Wallet/Kadmin/MIT.pm +++ b/perl/Wallet/Kadmin/MIT.pm @@ -39,6 +39,12 @@ sub error { return $self->{error}; } +# Set a callback to be called for forked kadmin processes. +sub fork_callback { + my ($self, $callback) = @_; + $self->{fork_callback} = $callback; +} + ############################################################################## # kadmin Interaction ############################################################################## @@ -73,11 +79,7 @@ sub kadmin { $self->error ("cannot fork: $!"); return; } elsif ($pid == 0) { - # TODO - How should I handle the db handle? - # Don't use die here; it will get trapped as an exception. Also be - # careful about our database handles. (We still lose if there's some - # other database handle open we don't know about.) - #$object->{dbh}->{InactiveDestroy} = 1; + $self->{fork_callback} (); unless (open (STDERR, '>&STDOUT')) { warn "wallet: cannot dup stdout: $!\n"; exit 1; diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index 6733cf0..22598f1 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -466,6 +466,11 @@ sub new { 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->{kadmin} = $kadmin; return $self; @@ -484,8 +489,14 @@ sub create { 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->addprinc ($name)) { - die $kadmin->error; + die $kadmin->error, "\n"; } $self = $class->SUPER::create ($type, $name, $dbh, $creator, $host, $time); $self->{kadmin} = $kadmin; diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index 7423ed1..8ecc2c1 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -8,7 +8,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 15; +use Test::More tests => 17; use Wallet::Admin; use Wallet::Config; @@ -34,11 +34,16 @@ for my $good (qw{service service/foo bar foo/bar host/example.org "Valid principal name $good"); } -# Test creating an MIT object. We don't care about anything but correctly -# creating it -- testing operations is for the keytab tests. +# Test creating an MIT object and seeing if the callback works. $Wallet::Config::KEYTAB_KRBTYPE = 'MIT'; my $kadmin = Wallet::Kadmin->new (); ok (defined ($kadmin), 'MIT kadmin object created'); +my $callback = sub { return 1 }; +$kadmin->fork_callback ($callback); +is ($kadmin->{fork_callback} (), 1, ' and callback works.'); +my $callback = sub { return 2 }; +$kadmin->fork_callback ($callback); +is ($kadmin->{fork_callback} (), 2, ' and changing it works.'); # Test creating a Heimdal object. For us to test a working Heimdal object, # we need a properly configured Heimdal KDC. So instead, we deliberately -- cgit v1.2.3 From 8d4899825cf723ef6a975306f146a06388ed4547 Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Tue, 26 Jan 2010 15:16:36 -0800 Subject: Skip tests in kadmin.t if module requirements are missing Made kadmin.t skip loading the Wallet::Kadmin::Heimdal module if its requirement, Heimdal::Kadm5, is not installed on the system. --- perl/t/kadmin.t | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) (limited to 'perl/t') diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index 8ecc2c1..96b249b 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -13,9 +13,17 @@ use Test::More tests => 17; use Wallet::Admin; use Wallet::Config; use Wallet::Kadmin; -use Wallet::Kadmin::Heimdal; use Wallet::Kadmin::MIT; +# Only load Wallet::Kadmin::Heimdal if a required module is found. +my $heimdal_kadm5 = 0; +eval 'use Heimdal::Kadm5'; +if (!$@) { + print "No error...\n"; + $heimdal_kadm5 = 1; + require Wallet::Kadmin::Heimdal; +} + use lib 't/lib'; use Util; @@ -41,7 +49,7 @@ ok (defined ($kadmin), 'MIT kadmin object created'); my $callback = sub { return 1 }; $kadmin->fork_callback ($callback); is ($kadmin->{fork_callback} (), 1, ' and callback works.'); -my $callback = sub { return 2 }; +$callback = sub { return 2 }; $kadmin->fork_callback ($callback); is ($kadmin->{fork_callback} (), 2, ' and changing it works.'); @@ -49,10 +57,13 @@ is ($kadmin->{fork_callback} (), 2, ' and changing it works.'); # we need a properly configured Heimdal KDC. So instead, we deliberately # connect without configuration to get the error. That at least tests that # we can find the Heimdal module and it dies how it should. -undef $Wallet::Config::KEYTAB_PRINCIPAL; -undef $Wallet::Config::KEYTAB_FILE; -undef $Wallet::Config::KEYTAB_REALM; -undef $kadmin; -$Wallet::Config::KEYTAB_KRBTYPE = 'Heimdal'; -$kadmin = eval { Wallet::Kadmin->new () }; -is ($kadmin, undef, 'Heimdal fails properly.'); +SKIP: { + skip 'Heimdal::Kadm5 not installed', 1 unless $heimdal_kadm5; + undef $Wallet::Config::KEYTAB_PRINCIPAL; + undef $Wallet::Config::KEYTAB_FILE; + undef $Wallet::Config::KEYTAB_REALM; + undef $kadmin; + $Wallet::Config::KEYTAB_KRBTYPE = 'Heimdal'; + $kadmin = eval { Wallet::Kadmin->new () }; + is ($kadmin, undef, 'Heimdal fails properly.'); +} -- cgit v1.2.3 From 04b875599b1d4559dbcd356726035416081c6b48 Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 28 Jan 2010 00:07:16 -0800 Subject: Improved and fixed tests related to Pod and KDC type Added a fix to the Pod tests to change the order of the arguments in a skip statement to the correct order. Also added tests for the KEYTAB_KRBTYPE value in the keytab tests, and changed the Wallet::Kadmin module to standardize the errors returned with no keytab set and add new error for keytab set but not a valid value. --- perl/Wallet/Kadmin.pm | 5 ++++- perl/t/keytab.t | 23 ++++++++++++++++++++--- tests/server/pod-t.in | 2 +- 3 files changed, 25 insertions(+), 5 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm index 95859a9..501bc37 100644 --- a/perl/Wallet/Kadmin.pm +++ b/perl/Wallet/Kadmin.pm @@ -32,7 +32,10 @@ $VERSION = '0.03'; sub new { my ($class) = @_; my ($kadmin); - if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + if (!defined $Wallet::Config::KEYTAB_KRBTYPE + || !$Wallet::Config::KEYTAB_KRBTYPE) { + die "keytab object implementation not configured\n"; + } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { require Wallet::Kadmin::MIT; $kadmin = Wallet::Kadmin::MIT->new (); } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 7745290..ab5b19d 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -8,7 +8,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 208 +use Test::More tests => 212 ; use Wallet::Admin; @@ -387,6 +387,21 @@ EOO is ($@, "keytab object implementation not configured\n", ' with the right error'); $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + undef $Wallet::Config::KEYTAB_KRBTYPE; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + }; + is ($object, undef, ' and another'); + is ($@, "keytab object implementation not configured\n", + ' with the right error'); + $Wallet::Config::KEYTAB_KRBTYPE = 'Active Directory'; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + }; + is ($object, undef, ' and one set to an invalid value'); + is ($@, "keytab krb server type not set to a valid value\n", + ' with the right error'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); } # Tests for unchanging support. Skip these if we don't have a keytab or if we @@ -403,6 +418,7 @@ SKIP: { $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); $Wallet::Config::KEYTAB_TMP = '.'; my $realm = $Wallet::Config::KEYTAB_REALM; my $principal = $Wallet::Config::KEYTAB_PRINCIPAL; @@ -581,6 +597,7 @@ EOO $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); $Wallet::Config::KEYTAB_TMP = '.'; $Wallet::Config::KEYTAB_AFS_KASETKEY = '../kasetkey/kasetkey'; my $realm = $Wallet::Config::KEYTAB_REALM; @@ -707,8 +724,7 @@ EOO # Tests for enctype restriction. SKIP: { - unless (-f 't/data/test.keytab' - && $Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + unless (-f 't/data/test.keytab') { skip 'no keytab configuration', 36; } @@ -716,6 +732,7 @@ SKIP: { $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); $Wallet::Config::KEYTAB_TMP = '.'; my $realm = $Wallet::Config::KEYTAB_REALM; my $principal = $Wallet::Config::KEYTAB_PRINCIPAL; diff --git a/tests/server/pod-t.in b/tests/server/pod-t.in index 4973d23..4575ecb 100644 --- a/tests/server/pod-t.in +++ b/tests/server/pod-t.in @@ -15,7 +15,7 @@ plan tests => $total; eval 'use Test::Pod 1.00'; SKIP: { - skip $total, 'Test::Pod 1.00 required for testing POD' if $@; + skip 'Test::Pod 1.00 required for testing POD', $total if $@; for my $file (@files) { pod_file_ok ("@abs_top_srcdir@/server/$file", "server/$file"); } -- cgit v1.2.3 From 346660359be7666e8629c14b2d12cebf794f6f26 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Mon, 8 Feb 2010 15:47:04 -0800 Subject: Coding style and whitespace fixes Combine a long series of eval blocks into a single block and a single error check. Remove trailing whitespace, and in some cases remove trailing () on method calls where the parens aren't useful. --- perl/Wallet/Admin.pm | 28 +++++++++--------- perl/Wallet/Kadmin.pm | 7 ++--- perl/Wallet/Kadmin/Heimdal.pm | 68 +++++++++++++++---------------------------- perl/Wallet/Object/Keytab.pm | 2 +- perl/t/kadmin.t | 6 ++-- perl/t/keytab.t | 2 +- server/wallet-admin | 6 ++-- 7 files changed, 49 insertions(+), 70 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index c86cbba..ff87b94 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -477,11 +477,11 @@ actions on the object it returns. =item list_acls(TYPE, SEARCH) -Returns a list of all ACLs matching a search type and string in the -database, or all ACLs if no search information is given. 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 "ADMIN" and ID 1 and one -with name "group/admins" and ID 3, list_acls() with no arguments would +Returns a list of all ACLs matching a search type and string in the +database, or all ACLs if no search information is given. 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 "ADMIN" and ID 1 and one +with name "group/admins" and ID 3, list_acls() with no arguments would return: ([ 1, 'ADMIN' ], [ 3, 'group/admins' ]) @@ -492,18 +492,18 @@ database with no ACLs by calling error(). error() is guaranteed to return the error message if there was an error and undef if there was no error. There are currently two search types. 'empty' takes no arguments, and will -return only those acls that have no entries within them. 'entry' takes two -arguments -- an entry scheme and an entry identifier -- and will return +return only those acls that have no entries within them. 'entry' takes two +arguments -- an entry scheme and an entry identifier -- and will return any ACLs with an entry that matches the given scheme and contains the given identifier. =item list_objects(TYPE, SEARCH) -Returns a list of all objects matching a search type and string in the -database, or all objects in the database if no search information is -given. 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 -"keytab" and with values "host/example.com" and "foo", list_objects() +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. 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 +"keytab" and with values "host/example.com" and "foo", list_objects() with no arguments would return: ([ 'keytab', 'host/example.com' ], [ 'keytab', 'foo' ]) @@ -516,8 +516,8 @@ if there was no error. There are four types of searches currently. 'type' (with a given type) will return only those entries where the type matches the given type. 'owner', with a given owner, will only return those objects owned by the -given acl name. 'flag', with a given flag name, will only return those -items with a flag set to the given value. 'acl' operates like 'owner', +given acl name. 'flag', with a given flag name, will only return those +items with a flag set to the given value. 'acl' operates like 'owner', but will return only those objects that have the given acl name on any of the possible acl settings, not just owner. diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm index 501bc37..b3a630e 100644 --- a/perl/Wallet/Kadmin.pm +++ b/perl/Wallet/Kadmin.pm @@ -32,15 +32,14 @@ $VERSION = '0.03'; sub new { my ($class) = @_; my ($kadmin); - if (!defined $Wallet::Config::KEYTAB_KRBTYPE - || !$Wallet::Config::KEYTAB_KRBTYPE) { + if (not $Wallet::Config::KEYTAB_KRBTYPE) { die "keytab object implementation not configured\n"; } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { require Wallet::Kadmin::MIT; - $kadmin = Wallet::Kadmin::MIT->new (); + $kadmin = Wallet::Kadmin::MIT->new; } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { require Wallet::Kadmin::Heimdal; - $kadmin = Wallet::Kadmin::Heimdal->new (); + $kadmin = Wallet::Kadmin::Heimdal->new; } else { die "keytab krb server type not set to a valid value\n"; } diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm index b0010a5..d046162 100644 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ b/perl/Wallet/Kadmin/Heimdal.pm @@ -98,40 +98,27 @@ sub addprinc { my $exists = eval { $self->exists ($principal) }; if ($@) { $self->error ("error adding principal $principal: $@"); - return undef; + return; } return 1 if $exists; # The way Heimdal::Kadm5 works, we create a principal object, create the # actual principal set inactive, then randomize it and activate it. + # # TODO - Paranoia makes me want to set the password to something random # on creation even if it is inactive until after randomized by # module. my $kadmin = $self->{client}; - my $princdata = eval { $kadmin->makePrincipal ($principal) }; - if ($@) { - $self->error ("error adding principal $principal: $@"); - return; - } - - # Disable the principal before creating, until we've randomized the - # password. - my $attrs = eval { $princdata->getAttributes }; - if ($@) { - $self->error ("error adding principal $principal: $@"); - return; + eval { + my $princdata = $kadmin->makePrincipal ($principal); + my $attrs = $princdata->getAttributes; + $attrs |= KRB5_KDB_DISALLOW_ALL_TIX; + $princdata->setAttributes ($attrs); + my $password = 'inactive'; + $kadmin->createPrincipal ($princdata, $password, 0); + $kadmin->randKeyPrincipal ($principal); + $kadmin->enablePrincipal ($principal); } - $attrs |= KRB5_KDB_DISALLOW_ALL_TIX; - eval { $princdata->setAttributes ($attrs) }; - if ($@) { - $self->error ("error adding principal $principal: $@"); - return; - } - - my $password = 'inactive'; - my $test = eval { $kadmin->createPrincipal ($princdata, $password, 0) }; - eval { $kadmin->randKeyPrincipal ($principal) } unless $@; - eval { $kadmin->enablePrincipal ($principal) } unless $@; if ($@) { $self->error ("error adding principal $principal: $@"); return; @@ -156,8 +143,8 @@ sub ktadd { my $kadmin = $self->{client}; eval { $kadmin->randKeyPrincipal ($principal) }; if ($@) { - $self->error ("error creating keytab for $principal: could not " - ."reinit enctypes: $@"); + $self->error ("error creating keytab for $principal: could not" + . " reinit enctypes: $@"); return; } my $princdata = eval { $kadmin->getPrincipal ($principal) }; @@ -165,23 +152,22 @@ sub ktadd { $self->error ("error creating keytab for $principal: $@"); return; } elsif (!$princdata) { - $self->error ("error creating keytab for $principal: principal does " - ."not exist"); + $self->error ("error creating keytab for $principal: principal does" + . " not exist"); return; } # Now actually remove any non-requested enctypes, if we requested any. if (@enctypes) { - my (%wanted); - my $alltypes = $princdata->getKeytypes (); - foreach (@enctypes) { $wanted{$_} = 1 } - foreach my $key (@{$alltypes}) { - my $keytype = ${$key}[0]; + my $alltypes = $princdata->getKeytypes; + my %wanted = map { $_ => 1 } @enctypes; + for my $key (@{ $alltypes }) { + my $keytype = $key->[0]; next if exists $wanted{$keytype}; eval { $princdata->delKeytypes ($keytype) }; if ($@) { - $self->error ("error removing keytype $keytype from the ". - "keytab: $@"); + $self->error ("error removing keytype $keytype from the" + . " keytab: $@"); return; } } @@ -192,12 +178,12 @@ sub ktadd { } } + # Create the keytab. eval { $kadmin->extractKeytab ($princdata, $file) }; if ($@) { $self->error ("error creating keytab for principal: $@"); return; } - return 1; } @@ -226,20 +212,14 @@ sub delprinc { return 1; } -############################################################################## -# Documentation -############################################################################## - -# Create a new MIT kadmin object. Very empty for the moment, but later it -# will probably fill out if we go to using a module rather than calling -# kadmin directly. +# Create a new Heimdal kadmin object. sub new { my ($class) = @_; my $self = { client => undef, }; bless ($self, $class); - $self->{client} = kadmin_client (); + $self->{client} = $self->kadmin_client; return $self; } diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index 22598f1..9fece80 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -497,7 +497,7 @@ sub create { if (not $kadmin->addprinc ($name)) { die $kadmin->error, "\n"; - } + } $self = $class->SUPER::create ($type, $name, $dbh, $creator, $host, $time); $self->{kadmin} = $kadmin; return $self; diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index 96b249b..18d452e 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -29,7 +29,7 @@ use Util; # We test a Wallet::Kadmin::* module's actual workings in the keytab.t tests. # The only things we want to test here are that each module is found, that -# Wallet::Kadmin itself delegates to them, and that the private MIT principal +# Wallet::Kadmin itself delegates to them, and that the private MIT principal # validation works as it should. for my $bad (qw{service\* = host/foo+bar host/foo/bar /bar bar/ rcmd.foo}) { @@ -44,7 +44,7 @@ for my $good (qw{service service/foo bar foo/bar host/example.org # Test creating an MIT object and seeing if the callback works. $Wallet::Config::KEYTAB_KRBTYPE = 'MIT'; -my $kadmin = Wallet::Kadmin->new (); +my $kadmin = Wallet::Kadmin->new; ok (defined ($kadmin), 'MIT kadmin object created'); my $callback = sub { return 1 }; $kadmin->fork_callback ($callback); @@ -64,6 +64,6 @@ SKIP: { undef $Wallet::Config::KEYTAB_REALM; undef $kadmin; $Wallet::Config::KEYTAB_KRBTYPE = 'Heimdal'; - $kadmin = eval { Wallet::Kadmin->new () }; + $kadmin = eval { Wallet::Kadmin->new }; is ($kadmin, undef, 'Heimdal fails properly.'); } diff --git a/perl/t/keytab.t b/perl/t/keytab.t index ab5b19d..d1d5ba6 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -220,7 +220,7 @@ SKIP: { if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { is ($@, "invalid principal name wallet\nf\n", ' with the right error'); } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - like ($@, qr/^error adding principal wallet\nf/, + like ($@, qr/^error adding principal wallet\nf/, ' with the right error'); } $object = eval { diff --git a/server/wallet-admin b/server/wallet-admin index 761288d..cd775b6 100755 --- a/server/wallet-admin +++ b/server/wallet-admin @@ -158,7 +158,7 @@ used, the database may also have to be created in advance. =item list (acls | objects) [ [ ... ] ] -Returns a list of ACLs or objects in the database. ACLs will be listed +Returns a list of ACLs or objects in the database. ACLs will be listed in the form: (ACL ID: ) @@ -210,8 +210,8 @@ can be housekept. =item list acls entry -Returns all ACLs containing an entry with given schema and identifier. -The schema is used for an exact search, while the identifier given will +Returns all ACLs containing an entry with given schema and identifier. +The schema is used for an exact search, while the identifier given will match any identifier containing that text, for flexibility. =back -- cgit v1.2.3 From b6cf2f78636970900015e74b03160e7280164e47 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Mon, 8 Feb 2010 19:40:17 -0800 Subject: Use kvno or kgetcred to check principal existance Don't use kadmin to check for principal existence. We want to verify that we can get tickets, not just look at kadmin. Use whatever is found on the user's PATH, not something based on the Kerberos type, since our userspace may not match the server implementation. --- perl/t/keytab.t | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) (limited to 'perl/t') diff --git a/perl/t/keytab.t b/perl/t/keytab.t index d1d5ba6..5488e28 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -90,21 +90,22 @@ sub destroy { system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args); } -# Check whether a principal exists. kvno works for MIT, but isn't in the -# Heimdal dist. +# Check whether a principal exists. MIT uses kvno and Heimdal uses kgetcred. +# Note that the Kerberos type may be different than our local userspace, so +# don't use the Kerberos type to decide here. Instead, check for which +# program is available on the path. sub created { my ($principal) = @_; $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - local $ENV{KRB5CCNAME} = 'krb5cc_temp'; - getcreds ('t/data/test.keytab', $Wallet::Config::KEYTAB_PRINCIPAL); + local $ENV{KRB5CCNAME} = 'krb5cc_temp'; + getcreds ('t/data/test.keytab', $Wallet::Config::KEYTAB_PRINCIPAL); + if (grep { -x "$_/kvno" } split (':', $ENV{PATH})) { return (system_quiet ('kvno', $principal) == 0); - } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, - '-K', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - 'get', $principal); - return (system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args) == 0); + } elsif (grep { -x "$_/kgetcred" } split (':', $ENV{PATH})) { + return (system_quiet ('kgetcred', $principal) == 0); + } else { + warn "# No kvno or kgetcred found\n"; + return; } } -- cgit v1.2.3 From a96f4abbbe8176101584e414be5139e244377025 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Mon, 8 Feb 2010 19:46:54 -0800 Subject: Use Wallet::Kadmin to do kadmin operations in the keytab test Now that we have Wallet::Kadmin, use it, rather than running the kadmin client program. We may not have the same kadmin client program as the server that we're testing against. --- perl/t/keytab.t | 36 ++++++++---------------------------- 1 file changed, 8 insertions(+), 28 deletions(-) (limited to 'perl/t') diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 5488e28..25e946c 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -3,16 +3,17 @@ # t/keytab.t -- Tests for the keytab object implementation. # # Written by Russ Allbery -# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2009, 2010 +# Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 212 -; +use Test::More tests => 212; use Wallet::Admin; use Wallet::Config; +use Wallet::Kadmin; use Wallet::Object::Keytab; use lib 't/lib'; @@ -57,37 +58,16 @@ sub system_quiet { # been set up. sub create { my ($principal) = @_; - if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', - '-t', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - '-q', "addprinc -clearpolicy -randkey $principal"); - } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, - '-K', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - 'add', $principal); - } - system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args); + my $kadmin = Wallet::Kadmin->new; + return $kadmin->addprinc ($principal); } # Destroy a principal out of Kerberos. Only usable once the configuration has # been set up. sub destroy { my ($principal) = @_; - my (@args); - if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', - '-t', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - '-q', "delprinc -force $principal"); - } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, - '-K', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - 'delete', $principal); - } - system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args); + my $kadmin = Wallet::Kadmin->new; + return $kadmin->delprinc ($principal); } # Check whether a principal exists. MIT uses kvno and Heimdal uses kgetcred. -- cgit v1.2.3 From c2422d4f762b5db774c6e0fef2cb2de916904f0e Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Mon, 8 Feb 2010 19:59:26 -0800 Subject: Redo how we find enctypes in the keytab test suite We may have a different userspace than the Kerberos type, so always try klist -ke first and then fall back on ktutil if it fails. Also display the error message in a few more places if things fail, discovered as useful when debugging other problems. --- perl/t/keytab.t | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) (limited to 'perl/t') diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 25e946c..c3e89d5 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -116,19 +116,22 @@ sub enctypes { close KEYTAB; my @enctypes; - if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - open (KLIST, '-|', 'klist', '-ke', 'keytab') - or die "cannot run klist: $!\n"; - local $_; - while () { - next unless /^ *\d+ /; - my ($string) = /\((.*)\)\s*$/; - next unless $string; - $enctype = $enctype{lc $string} || 'UNKNOWN'; - push (@enctypes, $enctype); - } - close KLIST; - } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { + open (KLIST, '-|', 'klist', '-ke', 'keytab') + or die "cannot run klist: $!\n"; + local $_; + while () { + next unless /^ *\d+ /; + my ($string) = /\((.*)\)\s*$/; + next unless $string; + $enctype = $enctype{lc $string} || 'UNKNOWN'; + push (@enctypes, $enctype); + } + close KLIST; + + # If that failed, we may have a Heimdal user space instead, so try ktutil. + # If we try this directly, it will just hang with MIT ktutil. + if ($? != 0) { + @enctypes = (); open (KTUTIL, '-|', 'ktutil', '-k', 'keytab', 'list') or die "cannot run ktutil: $!\n"; local $_; @@ -227,9 +230,14 @@ SKIP: { $object = eval { Wallet::Object::Keytab->create ('keytab', 'wallet/two', $dbh, @trace) }; - ok (defined ($object), 'Creating an existing principal succeeds'); + if (defined ($object)) { + ok (defined ($object), 'Creating an existing principal succeeds'); + } else { + is ($@, '', 'Creating an existing principal succeeds'); + } ok ($object->isa ('Wallet::Object::Keytab'), ' and is the right class'); is ($object->destroy (@trace), 1, ' and destroying it succeeds'); + is ($object->error, undef, ' with no error message'); ok (! created ('wallet/two'), ' and now it does not exist'); my @name = qw(keytab wallet-test/one); $object = eval { Wallet::Object::Keytab->create (@name, $dbh, @trace) }; -- cgit v1.2.3 From 954151bb1aeb8920b0077692db1705c39ff76eda Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Mon, 8 Feb 2010 20:08:32 -0800 Subject: Additional cleanup of the keytab test suite Map the AES enctype to the full enctype name, which will work for both MIT and Heimdal. Fix the test count. Really test rollback from invalid enctypes (what we did before made no sense). Skip tests that will just fail if the enctype stuff is not working, since otherwise it confuses matters. --- perl/t/keytab.t | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) (limited to 'perl/t') diff --git a/perl/t/keytab.t b/perl/t/keytab.t index c3e89d5..93df51c 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -9,7 +9,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 212; +use Test::More tests => 213; use Wallet::Admin; use Wallet::Config; @@ -26,7 +26,7 @@ my %enctype = ('triple des cbc mode with hmac/sha1' => 'des3-cbc-sha1', 'des cbc mode with crc-32' => 'des-cbc-crc', 'des cbc mode with rsa-md5' => 'des-cbc-md5', - 'aes-256 cts mode with 96-bit sha-1 hmac' => 'aes256-cts', + 'aes-256 cts mode with 96-bit sha-1 hmac' => 'aes256-cts-hmac-sha1-96', 'arcfour with hmac/md5' => 'rc4-hmac'); # Some global defaults to use. @@ -788,8 +788,7 @@ EOO 'Setting an unrecognized enctype fails'); is ($one->error, 'unknown encryption type foo-bar', ' with the right error message'); - @values = enctypes ($keytab); - is ("@values", "@enctypes", ' and we did rollback properly'); + is ($one->show, $expected, ' and we did rollback properly'); $history .= <<"EOO"; $date get by $user from $host @@ -810,8 +809,12 @@ EOO is ("@values", $enctypes[0], ' and we get back the right value'); $keytab = $one->get (@trace); ok (defined ($keytab), ' and retrieving the keytab still works'); - @values = enctypes ($keytab); - is ("@values", $enctypes[0], ' and it has the right enctype'); + if (defined ($keytab)) { + @values = enctypes ($keytab); + is ("@values", $enctypes[0], ' and it has the right enctype'); + } else { + ok (0, ' and it has the right keytab'); + } is ($one->attr ('enctypes', [ $enctypes[1] ], @trace), 1, 'Setting a different single enctype works'); @values = $one->attr ('enctypes'); -- cgit v1.2.3 From 59455fd5e6a47a66a2a84779f42928fd66ec9747 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 9 Feb 2010 13:06:31 -0800 Subject: Remove kaserver synchronization support from the wallet backend Remove kaserver synchronization support. It is no longer tested, and retaining the code was increasing the complexity of wallet, and some specific requirements (such as different realm names between kaserver and Kerberos v5 and the kvno handling) were Stanford-specific. Rather than using this support, AFS sites running kaserver will probably find deploying Heimdal with its internal kaserver compatibility is probably an easier transition approach. --- NEWS | 8 + perl/Wallet/Config.pm | 83 +--------- perl/Wallet/Object/Keytab.pm | 349 +++++++------------------------------------ perl/Wallet/Schema.pm | 10 +- perl/t/config.t | 6 +- perl/t/keytab.t | 217 ++------------------------- perl/t/schema.t | 2 +- 7 files changed, 86 insertions(+), 589 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index 04942ea..3185db3 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,14 @@ wallet 0.10 (unreleased) + Remove kaserver synchronization support. It is no longer tested, and + retaining the code was increasing the complexity of wallet, and some + specific requirements (such as different realm names between kaserver + and Kerberos v5 and the kvno handling) were Stanford-specific. Rather + than using this support, AFS sites running kaserver will probably find + deploying Heimdal with its internal kaserver compatibility is probably + an easier transition approach. + Correctly handle storing of data that begins with a dash and don't parse it as an argument to wallet-backend. diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index 3f52cf0..7198c07 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -1,7 +1,7 @@ # Wallet::Config -- Configuration handling for the wallet server. # # Written by Russ Allbery -# 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. @@ -14,7 +14,7 @@ use vars qw($PATH $VERSION); # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.03'; +$VERSION = '0.04'; # Path to the config file to load. $PATH = $ENV{WALLET_CONFIG} || '/etc/wallet/wallet.conf'; @@ -351,85 +351,6 @@ our $KEYTAB_REMCTL_PORT; =back -=head2 Synchronization with AFS kaserver - -The keytab backend optionally supports synchronizing keys between the -Kerberos v5 realm and a Kerberos v4 realm using kaserver. This -synchronization is done using B and is controlled by the C -attribute on keytab objects. To configure that support, set the following -variables. - -=over 4 - -=item KEYTAB_AFS_ADMIN - -The Kerberos v4 principal to use for authentication to the AFS kaserver. If -this principal is not in the default local Kerberos v4 realm, it must be -fully qualified. A srvtab for this principal must be stored in the path set -in $KEYTAB_AFS_SRVTAB. This principal must have the ADMIN flag set in the -AFS kaserver so that it can create and remove principals. This variable -must be set to use the kaserver synchronization support. - -=cut - -our $KEYTAB_AFS_ADMIN; - -=item KEYTAB_AFS_DESTROY - -If this variable, which is false by default, is set to a true value, each -time a keytab object that is not configured to be synchronized with the AFS -kaserver, the corresponding Kerberos v4 principal will be deleted from the -AFS kaserver. Use this with caution; it will cause the AFS kaserver realm -to be slowly stripped of principals. This is intended for use with -migration from Kerberos v4 to Kerberos v5, where the old principals should -be deleted out of Kerberos v4 whenever not requested from the wallet to aid -in tracking down and removing any systems with lingering Kerberos v4 -dependencies. - -Be aware that multiple Kerberos v5 principals map to the same Kerberos v4 -principal since in Kerberos v4 the domain name is stripped from the -principal for machine principals. If you create a keytab named -host/foo.example.com and mark it synchronized, and then create another -keytab named host/foo.example.net and don't mark it synchronized, -downloading the second will destroy the Kerberos v4 principal of the first -if this variable is set. - -=cut - -our $KEYTAB_AFS_DESTROY; - -=item KEYTAB_AFS_KASETKEY - -The path to the B command-line client. The default value is -C, which will cause the wallet to search for B on its -default PATH. - -=cut - -our $KEYTAB_AFS_KASETKEY = 'kasetkey'; - -=item KEYTAB_AFS_REALM - -The name of the Kerberos v4 realm with which to synchronize keys. This is a -realm, not a cell, so it should be in all uppercase. If this variable is -not set, the default is the realm determined from the local cell name. - -=cut - -our $KEYTAB_AFS_REALM; - -=item KEYTAB_AFS_SRVTAB - -The path to a srvtab used to authenticate to the AFS kaserver. This srvtab -should be for the principal set in $KEYTAB_AFS_ADMIN. This variable must be -set to use the kaserver synchronization support. - -=cut - -our $KEYTAB_AFS_SRVTAB; - -=back - =head1 NETDB ACL CONFIGURATION These configuration variables are only needed if you intend to use the diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index 9fece80..b604907 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -1,7 +1,8 @@ # Wallet::Object::Keytab -- Keytab object implementation for the wallet. # # Written by Russ Allbery -# Copyright 2007, 2008, 2009 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2009, 2010 +# Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -24,230 +25,7 @@ use Wallet::Kadmin; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.07'; - -############################################################################## -# AFS kaserver synchronization -############################################################################## - -# Given a Kerberos v5 principal name, convert it to a Kerberos v4 principal -# name. Returns undef if it can't convert the name for some reason (right -# now, only if the principal has more than two parts). Note that this mapping -# does not guarantee a unique result; multiple hosts in different domains can -# be mapped to the same Kerberos v4 principal name using this function. -sub kaserver_name { - my ($self, $k5) = @_; - my %host = map { $_ => 1 } qw(host ident imap pop smtp); - $k5 =~ s/\@.*//; - my @parts = split ('/', $k5); - if (@parts > 2) { - return; - } elsif (@parts == 2 and $host{$parts[0]}) { - $parts[1] =~ s/\..*//; - $parts[0] = 'rcmd' if $parts[0] eq 'host'; - } - my $k4 = join ('.', @parts); - if ($Wallet::Config::KEYTAB_AFS_REALM) { - $k4 .= '@' . $Wallet::Config::KEYTAB_AFS_REALM; - } - return $k4; -} - -# Run kasetkey with the given arguments. Returns true on success and false on -# failure. On failure, sets the internal error to the error from kasetkey. -sub kaserver_kasetkey { - my ($self, @args) = @_; - my $admin = $Wallet::Config::KEYTAB_AFS_ADMIN; - my $admin_srvtab = $Wallet::Config::KEYTAB_AFS_SRVTAB; - my $kasetkey = $Wallet::Config::KEYTAB_AFS_KASETKEY; - unless ($kasetkey and $admin and $admin_srvtab) { - $self->error ('kaserver synchronization not configured'); - return; - } - my $pid = open (KASETKEY, '-|'); - if (not defined $pid) { - $self->error ("cannot fork: $!"); - return; - } elsif ($pid == 0) { - # Don't use die here; it will get trapped as an exception. Also be - # careful about our database handles. (We still lose if there's some - # other database handle open we don't know about.) - $self->{dbh}->{InactiveDestroy} = 1; - unless (open (STDERR, '>&STDOUT')) { - warn "cannot redirect stderr: $!\n"; - exit 1; - } - unless (exec ($kasetkey, '-k', $admin_srvtab, '-a', $admin, @args)) { - warn "cannot exec $kasetkey: $!\n"; - exit 1; - } - } else { - local $/; - my $output = ; - close KASETKEY; - if ($? != 0) { - $output =~ s/\s+\z//; - $output =~ s/\n/, /g; - $output = ': ' . $output if $output; - $self->error ("cannot synchronize key with kaserver$output"); - return; - } - } - return 1; -} - -# Given a keytab file name, the Kerberos v5 principal that's stored in that -# keytab, a srvtab file name, and the corresponding Kerberos v4 principal, -# write out a srvtab file containing the DES key in that keytab. Fails if -# there is no DES key in the keytab. -sub kaserver_srvtab { - my ($self, $keytab, $k5, $srvtab, $k4) = @_; - - # Gah. Someday I will write Perl bindings for Kerberos that are less - # broken. - eval { require Authen::Krb5 }; - if ($@) { - $self->error ("kaserver synchronization support not available: $@"); - return; - } - eval { Authen::Krb5::init_context() }; - if ($@ and not $@ =~ /^Authen::Krb5 already initialized/) { - $self->error ('Kerberos initialization failed'); - return; - } - undef $@; - - # Do the interface dance. We call kt_read_service_key with 0 for the kvno - # to get any kvno, which works with MIT Kerberos at least. Assume a DES - # enctype of 1. This code won't work with any enctype other than - # des-cbc-crc. - my $princ = Authen::Krb5::parse_name ($k5); - unless (defined $princ) { - my $error = Authen::Krb5::error(); - $self->error ("cannot parse $k5: $error"); - return; - } - my $key = Authen::Krb5::kt_read_service_key ($keytab, $princ, 0, 1); - unless (defined $key) { - my $error = Authen::Krb5::error(); - $self->error ("cannot find des-cbc-crc key in $keytab: $error"); - return; - } - unless (open (SRVTAB, '>', $srvtab)) { - $self->error ("cannot create $srvtab: $!"); - return; - } - - # srvtab format is nul-terminated name, nul-terminated instance, - # nul-terminated realm, single character kvno (which we always set to 0), - # and DES keyblock. - my ($principal, $realm) = split ('@', $k4); - $realm ||= ''; - my ($name, $inst) = split (/\./, $principal, 2); - $inst ||= ''; - my $data = join ("\0", $name, $inst, $realm); - $data .= "\0\0" . $key->contents; - print SRVTAB $data; - unless (close SRVTAB) { - unlink $srvtab; - $self->error ("cannot write to $srvtab: $!"); - return; - } - return 1; -} - -# Given a principal name and a path to the keytab, synchronizes the key with a -# principal in an AFS kaserver. Returns true on success and false on failure. -# On failure, sets the internal error. -sub kaserver_sync { - my ($self, $principal, $keytab) = @_; - if ($Wallet::Config::KEYTAB_REALM) { - $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - } - my $k4 = $self->kaserver_name ($principal); - if (not defined $k4) { - $self->error ("cannot convert $principal to Kerberos v4"); - return; - } - my $srvtab = $Wallet::Config::KEYTAB_TMP . "/srvtab.$$"; - unless ($self->kaserver_srvtab ($keytab, $principal, $srvtab, $k4)) { - return; - } - unless ($self->kaserver_kasetkey ('-c', $srvtab, '-s', $k4)) { - unlink $srvtab; - return; - } - unlink $srvtab; - return 1; -} - -# Given a principal name, destroy the corresponding principal in the AFS -# kaserver. Returns true on success and false on failure, setting the object -# error if it fails. -sub kaserver_destroy { - my ($self, $principal) = @_; - my $k4 = $self->kaserver_name ($principal); - if (not defined $k4) { - $self->error ("cannot convert $principal to Kerberos v4"); - return; - } - return $self->kaserver_kasetkey ('-D', $k4); -} - -# Set the kaserver sync attribute. Called by attr(). Returns true on success -# and false on failure, setting the object error if it fails. -sub kaserver_set { - my ($self, $user, $host, $time) = @_; - $time ||= time; - my @trace = ($user, $host, $time); - my $name = $self->{name}; - eval { - my $sql = "select ks_name from keytab_sync where ks_name = ? and - ks_target = 'kaserver'"; - my $result = $self->{dbh}->selectrow_array ($sql, undef, $name); - if ($result) { - die "kaserver synchronization already set\n"; - } - $sql = "insert into keytab_sync (ks_name, ks_target) - values (?, 'kaserver')"; - $self->{dbh}->do ($sql, undef, $name); - $self->log_set ('type_data sync', undef, 'kaserver', @trace); - $self->{dbh}->commit; - }; - if ($@) { - $self->error ($@); - $self->{dbh}->rollback; - return; - } - return 1; -} - -# Clear the kaserver sync attribute. Called by attr(). Returns true on -# success and false on failure, setting the object error if it fails. -sub kaserver_clear { - my ($self, $user, $host, $time) = @_; - $time ||= time; - my @trace = ($user, $host, $time); - my $name = $self->{name}; - eval { - my $sql = "select ks_name from keytab_sync where ks_name = ? and - ks_target = 'kaserver'"; - my $result = $self->{dbh}->selectrow_array ($sql, undef, $name); - unless ($result) { - die "kaserver synchronization not set\n"; - } - $sql = 'delete from keytab_sync where ks_name = ?'; - $self->{dbh}->do ($sql, undef, $name); - $self->log_set ('type_data sync', 'kaserver', undef, @trace); - $self->{dbh}->commit; - }; - if ($@) { - $self->error ($@); - $self->{dbh}->rollback; - return; - } - return 1; -} +$VERSION = '0.08'; ############################################################################## # Enctype restriction @@ -379,9 +157,14 @@ sub keytab_retrieve { # Core methods ############################################################################## -# Override attr to support setting the enctypes and sync attributes. +# Override attr to support setting the enctypes and sync attributes. Note +# that the sync attribute has no supported targets at present and hence will +# always return an error, but the code is still here so that it doesn't have +# to be rewritten once a new sync target is added. sub attr { my ($self, $attribute, $values, $user, $host, $time) = @_; + $time ||= time; + my @trace = ($user, $host, $time); my %known = map { $_ => 1 } qw(enctypes sync); undef $self->{error}; unless ($known{$attribute}) { @@ -395,14 +178,25 @@ sub attr { if (@$values > 1) { $self->error ('only one synchronization target supported'); return; - } elsif (@$values and $values->[0] ne 'kaserver') { + } elsif (@$values) { my $target = $values->[0]; $self->error ("unsupported synchronization target $target"); return; - } elsif (@$values) { - return $self->kaserver_set ($user, $host, $time); } else { - return $self->kaserver_clear ($user, $host, $time); + 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); + } + $self->{dbh}->commit; + } } } } else { @@ -511,12 +305,6 @@ sub destroy { $self->error ("cannot destroy $id: object is locked"); return; } - my @sync = $self->attr ('sync'); - if (grep { $_ eq 'kaserver' } @sync) { - unless ($self->kaserver_destroy ($self->{name})) { - return; - } - } eval { my $sql = 'delete from keytab_sync where ks_name = ?'; $self->{dbh}->do ($sql, undef, $self->{name}); @@ -582,15 +370,6 @@ sub get { return; } close KEYTAB; - my @sync = $self->attr ('sync'); - if (grep { $_ eq 'kaserver' } @sync) { - unless ($self->kaserver_sync ($self->{name}, $file)) { - unlink $file; - return; - } - } elsif ($Wallet::Config::KEYTAB_AFS_DESTROY) { - $self->kaserver_destroy ($self->{name}); - } unlink $file; $self->log_action ('get', $user, $host, $time); return $data; @@ -646,7 +425,7 @@ methods that are overridden or behave specially for this implementation. =item attr(ATTRIBUTE [, VALUES, PRINCIPAL, HOSTNAME [, DATETIME]]) -Sets or retrieves a given object attribute. The following attributes are +Sets or retrieves a given object attribute. The following attribute is supported: =over 4 @@ -655,40 +434,21 @@ supported: Restricts the generated keytab to a specific set of encryption types. The values of this attribute must be enctype strings recognized by Kerberos -(strings like C or C). Encryption types must also -be present in the list of supported enctypes stored in the database database -or the attr() method will reject them. Note that the salt should not be -included; since the salt is irrelevant for keytab keys, it will always be -set to C by the wallet. +(strings like C or C). Encryption +types must also be present in the list of supported enctypes stored in the +database database or the attr() method will reject them. Note that the +salt should not be included; since the salt is irrelevant for keytab keys, +it will always be set to the default by the wallet. -If this attribute is set, the specified enctype list will be passed to -ktadd when get() is called for that keytab. If it is not set, the default -set in the KDC will be used. +If this attribute is set, the principal will be restricted to that +specific enctype list when get() is called for that keytab. If it is not +set, the default set in the KDC will be used. This attribute is ignored if the C flag is set on a keytab. Keytabs retrieved with C set will contain all keys present in the KDC for that Kerberos principal and therefore may contain different enctypes than those requested by this attribute. -=item sync - -Sets the external systems to which the key of a given principal is -synchronized. The only supported value for this attribute is C, -which says to synchronize the key with an AFS Kerberos v4 kaserver. - -If this attribute is set on a keytab, whenever get() is called for that -keytab, the new DES key will be extracted from that keytab and set in the -configured AFS kaserver. The Kerberos v4 principal name will be the same as -the Kerberos v5 principal name except that the components are separated by -C<.> instead of C; the second component is truncated after the first C<.> -if the first component is one of C, C, C, C, or -C; and the first component is C if the Kerberos v5 principal -component is C. The principal name must not contain more than two -components. - -If this attribute is set, calling destroy() will also destroy the principal -from the AFS kaserver, with a principal mapping determined as above. - =back If no other arguments besides ATTRIBUTE are given, returns the values of @@ -716,11 +476,11 @@ used. When a new keytab object is created, the Kerberos principal designated by NAME is also created in the Kerberos realm determined from the wallet -configuration. If the principal already exists, create() still succeeds (so -that a previously unmanaged principal can be imported into the wallet). -Otherwise, if the Kerberos principal could not be created, create() fails. -The principal is created with the C<-randkey> option to randomize its keys. -NAME must not contain the realm; instead, the KEYTAB_REALM configuration +configuration. If the principal already exists, create() still succeeds +(so that a previously unmanaged principal can be imported into the +wallet). Otherwise, if the Kerberos principal could not be created, +create() fails. The principal is created with the randomized keys. NAME +must not contain the realm; instead, the KEYTAB_REALM configuration variable should be set. See Wallet::Config(3) for more information. If create() fails, it throws an exception. @@ -738,18 +498,14 @@ destroying the object. If DATETIME isn't given, the current time is used. =item get(PRINCIPAL, HOSTNAME [, DATETIME]) -Retrieves a keytab for this object and returns the keytab data or undef -on error. The caller should call error() to get the error message if -get() returns undef. The keytab is created with C, invalidating -any existing keytabs for that principal, unless the unchanging flag is set -on the object. PRINCIPAL, HOSTNAME, and DATETIME are stored as history -information. PRINCIPAL should be the user who is downloading the keytab. -If DATETIME isn't given, the current time is used. - -If the configuration variable $KEYTAB_AFS_DESTROY is set and the C -attribute is not set to C, calling get() on a keytab object will -cause the corresponding Kerberos v4 principal to be destroyed. This -variable is not set by default. +Retrieves a keytab for this object and returns the keytab data or undef on +error. The caller should call error() to get the error message if get() +returns undef. The keytab is created with new randomized keys, +invalidating any existing keytabs for that principal, unless the +unchanging flag is set on the object. PRINCIPAL, HOSTNAME, and DATETIME +are stored as history information. PRINCIPAL should be the user who is +downloading the keytab. If DATETIME isn't given, the current time is +used. =back @@ -767,15 +523,14 @@ of the current process. The file is unlinked after being read. =head1 LIMITATIONS -Currently, this implementation only supports MIT Kerberos and needs -modifications to support Heimdal. It calls an external B program -rather than using a native Perl module and therefore requires B be -installed and parses its output. It may miss some error conditions if the -output of B ever changes. +Currently, when used with MIT Kerberos, this implementation calls an +external B program rather than using a native Perl module and +therefore requires B be installed and parses its output. It may +miss some error conditions if the output of B ever changes. Only one Kerberos realm is supported for a given wallet implementation and -all keytab objects stored must be in that realm. Keytab names in the wallet -database do not have realm information. +all keytab objects stored must be in that realm. Keytab names in the +wallet database do not have realm information. =head1 SEE ALSO diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index 2b256a2..252da03 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -1,7 +1,7 @@ # Wallet::Schema -- Database schema for the wallet system. # # Written by Russ Allbery -# 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. @@ -20,7 +20,7 @@ use DBI; # 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'; ############################################################################## # Data manipulation @@ -372,12 +372,12 @@ change was made. =head2 Keytab Backend Data -The keytab backend supports synchronizing keys with an external system. The -permitted external systems are listed in a normalization table: +The keytab backend has stub support for synchronizing keys with an +external system, although no external systems are currently supported. +The permitted external systems are listed in a normalization table: create table sync_targets (st_name varchar(255) primary key); - insert into sync_targets (st_name) values ('kaserver'); and then the synchronization targets for a given keytab are stored in this table: diff --git a/perl/t/config.t b/perl/t/config.t index d60d7e7..1377cb8 100755 --- a/perl/t/config.t +++ b/perl/t/config.t @@ -3,11 +3,11 @@ # t/config.t -- Tests for the wallet server configuration. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. -use Test::More tests => 7; +use Test::More tests => 6; # Silence warnings since we're not using use. package Wallet::Config; @@ -25,8 +25,6 @@ is ($Wallet::Config::KEYTAB_FLAGS, '-clearpolicy', ' and KEYTAB_FLAGS is correct'); is ($Wallet::Config::KEYTAB_KADMIN, 'kadmin', ' and KEYTAB_KADMIN is correct'); -is ($Wallet::Config::KEYTAB_AFS_KASETKEY, 'kasetkey', - ' and KEYTAB_AFS_KASETKEY is correct'); is ($Wallet::Config::DB_DRIVER, undef, ' and DB_DRIVER is unset'); # Create a configuration file with a single setting. diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 93df51c..e5a68be 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -9,7 +9,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 213; +use Test::More tests => 125; use Wallet::Admin; use Wallet::Config; @@ -147,24 +147,6 @@ sub enctypes { return sort @enctypes; } -# Given a Wallet::Object::Keytab object, the keytab data, the Kerberos v5 -# principal, and the Kerberos v4 principal, write the keytab to a file, -# generate a srvtab, and try authenticating using k4start. -sub valid_srvtab { - my ($object, $keytab, $k5, $k4) = @_; - open (KEYTAB, '>', 'keytab') or die "cannot create keytab: $!\n"; - print KEYTAB $keytab; - close KEYTAB; - unless ($object->kaserver_srvtab ('keytab', $k5, 'srvtab', $k4)) { - warn "cannot write srvtab: ", $object->error, "\n"; - return 0; - } - $ENV{KRBTKFILE} = 'krb4cc_temp'; - system ("k4start -f srvtab $k4 2>&1 >/dev/null history, $history, 'History is correct to this point'); } -# Tests for kaserver synchronization support. +# Tests for synchronization support. This code is deactivated at present +# since no synchronization targets are supported, but we want to still test +# the basic stub code. SKIP: { skip 'no keytab configuration', 106 unless -f 't/data/test.keytab'; - # Test the principal mapping. We can do this without having a kaserver - # configuration. We only need a basic keytab object configuration. Do - # this as white-box testing since we don't want to fill the test realm - # with a bunch of random principals. + # Test setting synchronization attributes, which can also be done without + # configuration. my $one = eval { Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) }; ok (defined ($one), 'Creating wallet/one succeeds'); - my %princs = - (foo => 'foo', - host => 'host', - rcmd => 'rcmd', - 'rcmd.foo' => 'rcmd.foo', - 'host/foo.example.org' => 'rcmd.foo', - 'ident/foo.example.org' => 'ident.foo', - 'imap/foo.example.org' => 'imap.foo', - 'pop/foo.example.org' => 'pop.foo', - 'smtp/foo.example.org' => 'smtp.foo', - 'service/foo' => 'service.foo', - 'foo/bar' => 'foo.bar'); - for my $princ (sort keys %princs) { - my $result = $princs{$princ}; - is ($one->kaserver_name ($princ), $result, "Name mapping: $princ"); - is ($one->kaserver_name ("$princ\@EXAMPLE.ORG"), $result, - ' with K5 realm'); - $Wallet::Config::KEYTAB_AFS_REALM = 'AFS.EXAMPLE.ORG'; - is ($one->kaserver_name ($princ), "$result\@AFS.EXAMPLE.ORG", - ' with K4 realm'); - is ($one->kaserver_name ("$princ\@EXAMPLE.ORG"), - "$result\@AFS.EXAMPLE.ORG", ' with K5 and K4 realm'); - undef $Wallet::Config::KEYTAB_AFS_REALM; - } - for my $princ (qw{service/foo/bar foo/bar/baz}) { - is ($one->kaserver_name ($princ), undef, "Name mapping: $princ"); - is ($one->kaserver_name ("$princ\@EXAMPLE.ORG"), undef, - ' with K5 realm'); - $Wallet::Config::KEYTAB_AFS_REALM = 'AFS.EXAMPLE.ORG'; - is ($one->kaserver_name ($princ), undef, ' with K4 realm'); - is ($one->kaserver_name ("$princ\@EXAMPLE.ORG"), undef, - ' with K5 and K4 realm'); - undef $Wallet::Config::KEYTAB_AFS_REALM; - } - - # Test setting synchronization attributes, which can also be done without - # configuration. my $expected = <<"EOO"; Type: keytab Name: wallet/one @@ -537,16 +482,20 @@ EOO my @targets = $one->attr ('foo'); is (scalar (@targets), 0, ' and getting an unknown attribute fails'); is ($one->error, 'unknown attribute foo', ' with the right error'); - is ($one->attr ('sync', [ 'foo' ], @trace), undef, + is ($one->attr ('sync', [ 'kaserver' ], @trace), undef, ' and setting an unknown sync target fails'); - is ($one->error, 'unsupported synchronization target foo', + is ($one->error, 'unsupported synchronization target kaserver', ' with the right error'); is ($one->attr ('sync', [ 'kaserver', 'bar' ], @trace), undef, ' and setting two targets fails'); is ($one->error, 'only one synchronization target supported', ' with the right error'); - is ($one->attr ('sync', [ 'kaserver' ], @trace), 1, - ' but setting only kaserver works'); + + # Create a synchronization manually so that we can test the display and + # removal code. + my $sql = "insert into keytab_sync (ks_name, ks_target) values + ('wallet/one', 'kaserver')"; + $dbh->do ($sql); @targets = $one->attr ('sync'); is (scalar (@targets), 1, ' and now one target is set'); is ($targets[0], 'kaserver', ' and it is correct'); @@ -563,15 +512,10 @@ EOO $history .= <<"EOO"; $date create by $user from $host -$date add kaserver to attribute sync - by $user from $host EOO is ($one->history, $history, ' and history is correct for attributes'); - is ($one->destroy (@trace), undef, 'Destroying wallet/one fails'); - is ($one->error, 'kaserver synchronization not configured', - ' because kaserver support is not configured'); is ($one->attr ('sync', [], @trace), 1, - ' but removing the kaserver sync attribute works'); + 'Removing the kaserver sync attribute works'); is ($one->destroy (@trace),1, ' and then destroying wallet/one works'); $history .= <<"EOO"; $date remove kaserver from attribute sync @@ -579,136 +523,7 @@ $date remove kaserver from attribute sync $date destroy by $user from $host EOO - - # Set up our configuration. - skip 'no AFS kaserver configuration', 34 unless -f 't/data/test.srvtab'; - skip 'no kaserver support', 34 unless -x '../kasetkey/kasetkey'; - $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; - $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); - $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); - $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); - $Wallet::Config::KEYTAB_TMP = '.'; - $Wallet::Config::KEYTAB_AFS_KASETKEY = '../kasetkey/kasetkey'; - my $realm = $Wallet::Config::KEYTAB_REALM; - my $k5 = "wallet/one\@$realm"; - - # Recreate and reconfigure the object. - $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) - }; - ok (defined ($one), 'Creating wallet/one succeeds'); - is ($one->attr ('sync', [ 'kaserver' ], @trace), 1, - ' and setting the kaserver sync attribute works'); - - # Finally, we can test. - is ($one->get (@trace), undef, 'Get without configuration fails'); - is ($one->error, 'kaserver synchronization not configured', - ' with the right error'); - $Wallet::Config::KEYTAB_AFS_ADMIN = contents ('t/data/test.admin'); - my $k4_realm = $Wallet::Config::KEYTAB_AFS_ADMIN; - $k4_realm =~ s/^[^\@]+\@//; - $Wallet::Config::KEYTAB_AFS_REALM = $k4_realm; - my $k4 = "wallet.one\@$k4_realm"; - is ($one->get (@trace), undef, ' and still fails with just admin'); - is ($one->error, 'kaserver synchronization not configured', - ' with the right error'); - $Wallet::Config::KEYTAB_AFS_SRVTAB = 't/data/test.srvtab'; - my $keytab = $one->get (@trace); - if (defined ($keytab)) { - ok (1, ' and now get works'); - } else { - is ($one->error, '', ' and now get works'); - } - ok (valid_srvtab ($one, $keytab, $k5, $k4), ' and the srvtab is valid'); - ok (! -f "./srvtab.$$", ' and the temporary file was cleaned up'); - - # Now remove the sync attribute and make sure things aren't synced. - is ($one->attr ('sync', [], @trace), 1, 'Clearing sync works'); - @targets = $one->attr ('sync'); - is (scalar (@targets), 0, ' and now there is no attribute'); - is ($one->error, undef, ' and no error'); - my $new_keytab = $one->get (@trace); - ok (defined ($new_keytab), ' and get still works'); - ok (! valid_srvtab ($one, $new_keytab, $k5, $k4), - ' but the srvtab does not'); - ok (valid_srvtab ($one, $keytab, $k5, $k4), ' and the old one does'); - is ($one->destroy (@trace), 1, ' and destroying wallet/one works'); - ok (valid_srvtab ($one, $keytab, $k5, $k4), - ' and the principal is still there'); - - # Test KEYTAB_AFS_DESTROY. - $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) - }; - ok (defined ($one), 'Creating wallet/one succeeds'); - $Wallet::Config::KEYTAB_AFS_DESTROY = 1; - $new_keytab = $one->get (@trace); - ok (defined ($new_keytab), ' and get works'); - ok (! valid_srvtab ($one, $new_keytab, $k5, $k4), - ' but the srvtab does not'); - ok (! valid_srvtab ($one, $keytab, $k5, $k4), - ' and now neither does the old one'); - $Wallet::Config::KEYTAB_AFS_DESTROY = 0; - - # Put it back and make sure it works again. - is ($one->attr ('sync', [ 'kaserver' ], @trace), 1, 'Setting sync works'); - $keytab = $one->get (@trace); - ok (defined ($keytab), ' and get works'); - ok (valid_srvtab ($one, $keytab, $k5, $k4), ' and the srvtab is valid'); - $Wallet::Config::KEYTAB_AFS_KASETKEY = '/path/to/nonexistent/file'; - $new_keytab = $one->get (@trace); - ok (! defined ($new_keytab), - ' but it fails if we mess up the kasetkey path'); - like ($one->error, qr{^cannot synchronize key with kaserver: }, - ' with the right error message'); - ok (! -f "keytab.$$", ' and the temporary file was cleaned up'); - $Wallet::Config::KEYTAB_AFS_KASETKEY = '../kasetkey/kasetkey'; - - # Destroy the principal and recreate it and make sure we cleaned up. - is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); - ok (! valid_srvtab ($one, $keytab, $k5, $k4), - ' and the principal is gone'); - $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) - }; - ok (defined ($one), ' and recreating it succeeds'); - @targets = $one->attr ('sync'); - is (scalar (@targets), 0, ' and now there is no attribute'); - is ($one->error, undef, ' and no error'); - - # Now destroy it for good. - is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); - - # Check that history is still correct. - $history .= <<"EOO"; -$date create - by $user from $host -$date add kaserver to attribute sync - by $user from $host -$date get - by $user from $host -$date remove kaserver from attribute sync - by $user from $host -$date get - by $user from $host -$date destroy - by $user from $host -$date create - by $user from $host -$date get - by $user from $host -$date add kaserver to attribute sync - by $user from $host -$date get - by $user from $host -$date destroy - by $user from $host -$date create - by $user from $host -$date destroy - by $user from $host -EOO - is ($one->history, $history, 'History is correct to this point'); + is ($one->history, $history, ' and history is correct for removal'); } # Tests for enctype restriction. diff --git a/perl/t/schema.t b/perl/t/schema.t index 01d5dac..559ece4 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), 29, ' and returns the right number of statements'); +is (scalar (@sql), 28, ' and returns the right number of statements'); # Connect to a database and test create. db_setup; -- cgit v1.2.3 From 31c47c6f5efde6df930b11be281470f75e685324 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 9 Feb 2010 18:42:26 -0800 Subject: Update keytab test for new KRBTYPE error message --- perl/t/keytab.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'perl/t') diff --git a/perl/t/keytab.t b/perl/t/keytab.t index e5a68be..39be547 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -370,7 +370,7 @@ EOO Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) }; is ($object, undef, ' and one set to an invalid value'); - is ($@, "keytab krb server type not set to a valid value\n", + is ($@, "unknown KEYTAB_KRBTYPE setting: Active Directory\n", ' with the right error'); $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); } -- cgit v1.2.3 From ae02de1488068b84371b05842c81a9aecc5f24c4 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 9 Feb 2010 23:19:27 -0800 Subject: Check spelling of server API POD and tweak server docs Also update the POD syntax check to the current version of that check I use elsewhere. Since I'm touching all the POD anyway, also rewrap all of the POD to 74 columns. Fix some references to MIT in the Wallet::Kadmin::Heimdal module documentation. --- perl/Wallet/ACL.pm | 110 +++++++++++----------- perl/Wallet/ACL/Base.pm | 31 ++++--- perl/Wallet/ACL/Krb5.pm | 13 ++- perl/Wallet/ACL/NetDB.pm | 26 +++--- perl/Wallet/ACL/NetDB/Root.pm | 46 +++++----- perl/Wallet/Admin.pm | 39 ++++---- perl/Wallet/Config.pm | 196 ++++++++++++++++++++------------------- perl/Wallet/Database.pm | 17 ++-- perl/Wallet/Kadmin.pm | 31 ++++--- perl/Wallet/Kadmin/Heimdal.pm | 52 +++++------ perl/Wallet/Kadmin/MIT.pm | 45 ++++----- perl/Wallet/Object/Base.pm | 209 ++++++++++++++++++++++-------------------- perl/Wallet/Object/File.pm | 18 ++-- perl/Wallet/Object/Keytab.pm | 55 ++++++----- perl/Wallet/Schema.pm | 129 ++++++++++++++------------ perl/Wallet/Server.pm | 209 ++++++++++++++++++++++-------------------- perl/t/pod-spelling.t | 75 +++++++++++++++ perl/t/pod.t | 14 ++- 18 files changed, 731 insertions(+), 584 deletions(-) create mode 100755 perl/t/pod-spelling.t (limited to 'perl/t') diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm index 9136fc2..76e7354 100644 --- a/perl/Wallet/ACL.pm +++ b/perl/Wallet/ACL.pm @@ -1,7 +1,7 @@ # Wallet::ACL -- Implementation of ACLs in the wallet system. # # Written by Russ Allbery -# 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. @@ -21,7 +21,7 @@ use POSIX qw(strftime); # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.05'; +$VERSION = '0.06'; ############################################################################## # Constructors @@ -427,6 +427,9 @@ __END__ Wallet::ACL - Implementation of ACLs in the wallet system +=for stopwords +ACL DBH metadata HOSTNAME DATETIME timestamp Allbery + =head1 SYNOPSIS my $acl = Wallet::ACL->create ('group:sysadmin'); @@ -445,22 +448,22 @@ Wallet::ACL - Implementation of ACLs in the wallet system =head1 DESCRIPTION -Wallet::ACL implements the ACL system for the wallet: the methods to create, -find, rename, and destroy ACLs; the methods to add and remove entries from -an ACL; and the methods to list the contents of an ACL and check a principal -against it. +Wallet::ACL implements the ACL system for the wallet: the methods to +create, find, rename, and destroy ACLs; the methods to add and remove +entries from an ACL; and the methods to list the contents of an ACL and +check a principal against it. An ACL is a list of zero or more ACL entries, each of which consists of a -scheme and an identifier. Each scheme is associated with a verifier module -that checks Kerberos principals against identifiers for that scheme and -returns whether the principal should be permitted access by that identifier. -The interpretation of the identifier is entirely left to the scheme. This -module maintains the ACLs and dispatches check operations to the appropriate -verifier module. - -Each ACL is identified by a human-readable name and a persistant unique -numeric identifier. The numeric identifier (ID) should be used to refer to -the ACL so that it can be renamed as needed without breaking external +scheme and an identifier. Each scheme is associated with a verifier +module that checks Kerberos principals against identifiers for that scheme +and returns whether the principal should be permitted access by that +identifier. The interpretation of the identifier is entirely left to the +scheme. This module maintains the ACLs and dispatches check operations to +the appropriate verifier module. + +Each ACL is identified by a human-readable name and a persistent unique +numeric identifier. The numeric identifier (ID) should be used to refer +to the ACL so that it can be renamed as needed without breaking external references. =head1 CLASS METHODS @@ -481,8 +484,8 @@ finding an existing one, creates a new ACL record in the database with the given NAME. NAME must not be all-numeric, since that would conflict with the automatically assigned IDs. Returns the new object on success and throws an exception on failure. PRINCIPAL, HOSTNAME, and DATETIME are -stored as history information. PRINCIPAL should be the user who is creating -the ACL. If DATETIME isn't given, the current time is used. +stored as history information. PRINCIPAL should be the user who is +creating the ACL. If DATETIME isn't given, the current time is used. =back @@ -492,42 +495,43 @@ the ACL. If DATETIME isn't given, the current time is used. =item add(SCHEME, INSTANCE, PRINCIPAL, HOSTNAME [, DATETIME]) -Add the given ACL entry (given by SCHEME and INSTANCE) to this ACL. Returns -true on success and false on failure. On failure, the caller should call -error() to get the error message. PRINCIPAL, HOSTNAME, and DATETIME are -stored as history information. PRINCIPAL should be the user who is adding -the ACL entry. If DATETIME isn't given, the current time is used. +Add the given ACL entry (given by SCHEME and INSTANCE) to this ACL. +Returns true on success and false on failure. On failure, the caller +should call error() to get the error message. PRINCIPAL, HOSTNAME, and +DATETIME are stored as history information. PRINCIPAL should be the user +who is adding the ACL entry. If DATETIME isn't given, the current time is +used. =item check(PRINCIPAL) Checks whether the given PRINCIPAL should be allowed access given ACL. Returns 1 if access was granted, 0 if access is declined, and undef on -error. On error, the caller should call error() to get the error text. Any -errors found by the individual ACL verifiers can be retrieved by calling -check_errors(). Errors from individual ACL verifiers will not result in an -error return from check(); instead, the check will continue with the next -entry in the ACL. +error. On error, the caller should call error() to get the error text. +Any errors found by the individual ACL verifiers can be retrieved by +calling check_errors(). Errors from individual ACL verifiers will not +result in an error return from check(); instead, the check will continue +with the next entry in the ACL. check() returns success as soon as an entry in the ACL grants access to PRINCIPAL. There is no provision for negative ACLs or exceptions. =item check_errors() -Return (as a list in array context and a string with newlines between errors -and at the end of the last error in scalar context) the errors, if any, -returned by ACL verifiers for the last check operation. If there were no -errors from the last check() operation, returns the empty list in array -context and undef in scalar context. +Return (as a list in array context and a string with newlines between +errors and at the end of the last error in scalar context) the errors, if +any, returned by ACL verifiers for the last check operation. If there +were no errors from the last check() operation, returns the empty list in +array context and undef in scalar context. =item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) Destroys this ACL from the database. Note that this will fail due to integrity constraint errors if the ACL is still referenced by any object; -the ACL must be removed from all objects first. Returns true on success and -false on failure. On failure, the caller should call error() to get the -error message. PRINCIPAL, HOSTNAME, and DATETIME are stored as history -information. PRINCIPAL should be the user who is destroying the ACL. If -DATETIME isn't given, the current time is used. +the ACL must be removed from all objects first. Returns true on success +and false on failure. On failure, the caller should call error() to get +the error message. PRINCIPAL, HOSTNAME, and DATETIME are stored as +history information. PRINCIPAL should be the user who is destroying the +ACL. If DATETIME isn't given, the current time is used. =item error() @@ -542,7 +546,8 @@ the ACL (not including changes to the name of the ACL) will be represented by two lines. The first line will have a timestamp of the change followed by a description of the change, and the second line will give the user who made the change and the host from which the change was made. On failure, -returns undef, and the caller should call error() to get the error message. +returns undef, and the caller should call error() to get the error +message. =item id() @@ -569,28 +574,29 @@ Returns the human-readable name of this ACL. =item remove(SCHEME, INSTANCE, PRINCIPAL, HOSTNAME [, DATETIME]) Remove the given ACL line (given by SCHEME and INSTANCE) from this ACL. -Returns true on success and false on failure. On failure, the caller should -call error() to get the error message. PRINCIPAL, HOSTNAME, and DATETIME -are stored as history information. PRINCIPAL should be the user who is -removing the ACL entry. If DATETIME isn't given, the current time is used. +Returns true on success and false on failure. On failure, the caller +should call error() to get the error message. PRINCIPAL, HOSTNAME, and +DATETIME are stored as history information. PRINCIPAL should be the user +who is removing the ACL entry. If DATETIME isn't given, the current time +is used. =item rename(NAME) Rename this ACL. This changes the name used for human convenience but not the system-generated ACL ID that is used to reference this ACL. The new NAME must not be all-numeric, since that would conflict with -system-generated ACL IDs. Returns true on success and false on failure. On -failure, the caller should call error() to get the error message. +system-generated ACL IDs. Returns true on success and false on failure. +On failure, the caller should call error() to get the error message. Note that rename() operations are not logged in the ACL history. =item show() -Returns a human-readable description of this ACL, including its membership. -This method should only be used for display of the ACL to humans. Use the -list(), name(), and id() methods instead to get ACL information for use in -other code. On failure, returns undef, and the caller should call error() -to get the error message. +Returns a human-readable description of this ACL, including its +membership. This method should only be used for display of the ACL to +humans. Use the list(), name(), and id() methods instead to get ACL +information for use in other code. On failure, returns undef, and the +caller should call error() to get the error message. =back @@ -598,8 +604,8 @@ to get the error message. Wallet::ACL::Base(3), wallet-backend(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/Wallet/ACL/Base.pm b/perl/Wallet/ACL/Base.pm index 004de75..9a8a3cb 100644 --- a/perl/Wallet/ACL/Base.pm +++ b/perl/Wallet/ACL/Base.pm @@ -1,7 +1,7 @@ # Wallet::ACL::Base -- Parent class for wallet ACL verifiers. # # Written by Russ Allbery -# Copyright 2007 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -18,7 +18,7 @@ use vars qw($VERSION); # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.01'; +$VERSION = '0.02'; ############################################################################## # Interface @@ -59,6 +59,9 @@ __END__ # Documentation ############################################################################## +=for stopwords +ACL Allbery + =head1 NAME Wallet::ACL::Base - Generic parent class for wallet ACL verifiers @@ -74,9 +77,9 @@ Wallet::ACL::Base - Generic parent class for wallet ACL verifiers =head1 DESCRIPTION -Wallet::ACL::Base is the generic parent class for wallet ACL verifiers. It -provides default functions and behavior and all ACL verifiers should inherit -from it. It is not used directly. +Wallet::ACL::Base is the generic parent class for wallet ACL verifiers. +It provides default functions and behavior and all ACL verifiers should +inherit from it. It is not used directly. =head1 METHODS @@ -84,8 +87,8 @@ from it. It is not used directly. =item new() -Creates a new ACL verifier. The generic function provided here just creates -and blesses an object. +Creates a new ACL verifier. The generic function provided here just +creates and blesses an object. =item check(PRINCIPAL, ACL) @@ -99,11 +102,11 @@ have failed. Callers should call this function to get the error message after an undef return from any other instance method. For the convenience of child classes, this method can also be called with -one or more error strings. If so, those strings are concatenated together, -trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is stored -as the error. Only child classes should call this method with an error -string. +one or more error strings. If so, those strings are concatenated +together, trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is +stored as the error. Only child classes should call this method with an +error string. =back @@ -111,8 +114,8 @@ string. Wallet::ACL(3), wallet-backend(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/Wallet/ACL/Krb5.pm b/perl/Wallet/ACL/Krb5.pm index 1c584c5..496fcf0 100644 --- a/perl/Wallet/ACL/Krb5.pm +++ b/perl/Wallet/ACL/Krb5.pm @@ -1,7 +1,7 @@ # Wallet::ACL::Krb5 -- Wallet Kerberos v5 principal ACL verifier. # # Written by Russ Allbery -# Copyright 2007 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -22,7 +22,7 @@ use 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'; +$VERSION = '0.02'; ############################################################################## # Interface @@ -50,6 +50,9 @@ __END__ # Documentation ############################################################################## +=for stopwords +ACL krb5 Allbery + =head1 NAME Wallet::ACL::Krb5 - Simple wallet ACL verifier for Kerberos principals @@ -69,7 +72,7 @@ Wallet::ACL::Krb5 - Simple wallet ACL verifier for Kerberos principals =head1 DESCRIPTION Wallet::ACL::Krb5 is the simplest wallet ACL verifier, used to verify ACL -lines of type krb5. The value of such an ACL is a simple Kerberos +lines of type C. The value of such an ACL is a simple Kerberos principal in its text display form, and the ACL grants access to a given principal if and only if the principal exactly matches the ACL. @@ -111,8 +114,8 @@ The PRINCIPAL parameter to check() was undefined or the empty string. Wallet::ACL(3), Wallet::ACL::Base(3), wallet-backend(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/Wallet/ACL/NetDB.pm b/perl/Wallet/ACL/NetDB.pm index 6775c62..2096ba8 100644 --- a/perl/Wallet/ACL/NetDB.pm +++ b/perl/Wallet/ACL/NetDB.pm @@ -1,7 +1,7 @@ # Wallet::ACL::NetDB -- Wallet NetDB role ACL verifier. # # Written by Russ Allbery -# Copyright 2007 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -23,7 +23,7 @@ use Wallet::Config; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.03'; +$VERSION = '0.04'; ############################################################################## # Interface @@ -135,6 +135,9 @@ __END__ # Documentation ############################################################################## +=for stopwords +ACL NetDB remctl DNS DHCP Allbery netdb + =head1 NAME Wallet::ACL::NetDB - Wallet ACL verifier for NetDB roles @@ -154,9 +157,10 @@ Wallet::ACL::NetDB - Wallet ACL verifier for NetDB roles =head1 DESCRIPTION Wallet::ACL::NetDB checks a principal against the NetDB roles for a given -host. It is used to verify ACL lines of type netdb. The value of such an -ACL is a node, and the ACL grants access to a given principal if and only -if that principal has one of the roles user, admin, or team for that node. +host. It is used to verify ACL lines of type C. The value of such +an ACL is a node, and the ACL grants access to a given principal if and +only if that principal has one of the roles user, admin, or team for that +node. To use this object, several configuration parameters must be set. See Wallet::Config(3) for details on those configuration parameters and @@ -227,7 +231,7 @@ error message or otherwise returned failure. The ACL parameter to check() was malformed. Currently, this error is only given if ACL is undefined or the empty string. -=item malformed NetDBL remctl token: %s +=item malformed NetDB remctl token: %s The Net::Remctl Perl library returned a malformed token. This should never happen and indicates a bug in Net::Remctl. @@ -248,12 +252,12 @@ grant access is not currently configurable. Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::Config(3), wallet-backend(8) -NetDB is a free software system for managing DNS, DHCP, and related machine -information for large organizations. For more information on NetDB, see -L. +NetDB is a free software system for managing DNS, DHCP, and related +machine information for large organizations. For more information on +NetDB, see L. -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/Wallet/ACL/NetDB/Root.pm b/perl/Wallet/ACL/NetDB/Root.pm index cbd1387..3aeebda 100644 --- a/perl/Wallet/ACL/NetDB/Root.pm +++ b/perl/Wallet/ACL/NetDB/Root.pm @@ -1,7 +1,7 @@ # Wallet::ACL::NetDB::Root -- Wallet NetDB role ACL verifier (root instances). # # Written by Russ Allbery -# Copyright 2007 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -23,7 +23,7 @@ use Wallet::Config; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.01'; +$VERSION = '0.02'; ############################################################################## # Interface @@ -48,6 +48,9 @@ sub check { # Documentation ############################################################################## +=for stopwords +ACL NetDB DNS DHCP Allbery + =head1 NAME Wallet::ACL::NetDB::Root - Wallet ACL verifier for NetDB roles (root instances) @@ -66,13 +69,14 @@ Wallet::ACL::NetDB::Root - Wallet ACL verifier for NetDB roles (root instances) =head1 DESCRIPTION -Wallet::ACL::NetDB::Root works identically to Wallet::ACL::NetDB except that -it requires the principal to be a root instance (in other words, to be in -the form /root@) and strips the C portion from the -principal before checking against NetDB roles. As with the base NetDB ACL -verifier, the value of a netdb-root ACL is a node, and the ACL grants access -to a given principal if and only if the that principal (with C -stripped) has one of the roles user, admin, or team for that node. +Wallet::ACL::NetDB::Root works identically to Wallet::ACL::NetDB except +that it requires the principal to be a root instance (in other words, to +be in the form /root@) and strips the C portion +from the principal before checking against NetDB roles. As with the base +NetDB ACL verifier, the value of a C ACL is a node, and the +ACL grants access to a given principal if and only if the that principal +(with C stripped) has one of the roles user, admin, or team for +that node. To use this object, the same configuration parameters must be set as for Wallet::ACL::NetDB. See Wallet::Config(3) for details on those @@ -85,11 +89,11 @@ configuration. =item check(PRINCIPAL, ACL) -Returns true if PRINCIPAL is granted access according to ACL, false if not, -and undef on an error (see L<"DIAGNOSTICS"> below). ACL is a node, and -PRINCIPAL will be granted access if it has an instance of C and if -(with C stripped off and the realm stripped off if configured) has -the user, admin, or team role for that node. +Returns true if PRINCIPAL is granted access according to ACL, false if +not, and undef on an error (see L<"DIAGNOSTICS"> below). ACL is a node, +and PRINCIPAL will be granted access if it has an instance of C and +if (with C stripped off and the realm stripped off if configured) +has the user, admin, or team role for that node. =back @@ -106,15 +110,15 @@ grant access is not currently configurable. =head1 SEE ALSO -Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::ACL::NetDB(3), -Wallet::Config(3), wallet-backend(8) +Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3), +Wallet::ACL::NetDB(3), Wallet::Config(3), wallet-backend(8) -NetDB is a free software system for managing DNS, DHCP, and related machine -information for large organizations. For more information on NetDB, see -L. +NetDB is a free software system for managing DNS, DHCP, and related +machine information for large organizations. For more information on +NetDB, see L. -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index ff87b94..b4b3d86 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -1,7 +1,7 @@ # Wallet::Admin -- Wallet system administrative interface. # # Written by Russ Allbery -# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -413,6 +413,9 @@ __DATA__ Wallet::Admin - Wallet system administrative interface +=for stopwords +ACL hostname ACLs SQL wildcard Allbery + =head1 SYNOPSIS use Wallet::Admin; @@ -429,9 +432,9 @@ thin wrapper around this object that provides a command-line interface to its actions. To use this object, several configuration variables must be set (at least -the database configuration). For information on those variables and how to -set them, see Wallet::Config(3). For more information on the normal user -interface to the wallet server, see Wallet::Server(3). +the database configuration). For information on those variables and how +to set them, see Wallet::Config(3). For more information on the normal +user interface to the wallet server, see Wallet::Server(3). =head1 CLASS METHODS @@ -491,11 +494,11 @@ at least one ACL, but an error can be distinguished from the odd case of a database with no ACLs by calling error(). error() is guaranteed to return the error message if there was an error and undef if there was no error. -There are currently two search types. 'empty' takes no arguments, and will -return only those acls that have no entries within them. 'entry' takes two -arguments -- an entry scheme and an entry identifier -- and will return -any ACLs with an entry that matches the given scheme and contains the -given identifier. +There are currently two search types. C takes no arguments and +will return only those ACLs that have no entries within them. C +takes two arguments, an entry scheme and an entry identifier, and will +return any ACLs with an entry that matches the given scheme and contains +the given identifier. =item list_objects(TYPE, SEARCH) @@ -503,7 +506,7 @@ 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. 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 -"keytab" and with values "host/example.com" and "foo", list_objects() +C and with values C and C, list_objects() with no arguments would return: ([ 'keytab', 'host/example.com' ], [ 'keytab', 'foo' ]) @@ -513,13 +516,13 @@ database containing no objects, the caller should call error(). error() is guaranteed to return the error message if there was an error and undef if there was no error. -There are four types of searches currently. 'type' (with a given type) +There are four types of searches currently. C (with a given type) will return only those entries where the type matches the given type. -'owner', with a given owner, will only return those objects owned by the -given acl name. 'flag', with a given flag name, will only return those -items with a flag set to the given value. 'acl' operates like 'owner', -but will return only those objects that have the given acl name on any -of the possible acl settings, not just owner. +C, with a given owner, will only return those objects owned by the +given ACL name. C, with a given flag name, will only return those +items with a flag set to the given value. C operates like C, +but will return only those objects that have the given ACL name on any of +the possible ACL settings, not just owner. =item register_object (TYPE, CLASS) @@ -559,8 +562,8 @@ the error message if there was an error and undef if there was no error. wallet-admin(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index ae8cf9c..c59d3e3 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -23,6 +23,11 @@ $PATH = $ENV{WALLET_CONFIG} || '/etc/wallet/wallet.conf'; Wallet::Config - Configuration handling for the wallet server +=for stopwords +DBI DSN SQLite subdirectories KEYTAB keytab kadmind KDC add-ons kadmin DNS +SRV kadmin keytabs remctl backend lowercased NETDB ACL NetDB unscoped +usernames rekey hostnames Allbery wallet-backend keytab-backend + =head1 SYNOPSIS use Wallet::Config; @@ -63,9 +68,9 @@ variable DB_DRIVER to C, use: $DB_DRIVER = 'MySQL'; -Always remember the initial dollar sign (C<$>) and ending semicolon (C<;>). -Those familiar with Perl syntax can of course use the full range of Perl -expressions. +Always remember the initial dollar sign (C<$>) and ending semicolon +(C<;>). Those familiar with Perl syntax can of course use the full range +of Perl expressions. This configuration file should end with the line: @@ -80,11 +85,11 @@ file. =item DB_DRIVER -Sets the Perl database driver to use for the wallet database. Common values -would be C or C. Less common values would be C, -C, or C. The appropriate DBD::* Perl module for the chosen -driver must be installed and will be dynamically loaded by the wallet. For -more information, see DBI(3). +Sets the Perl database driver to use for the wallet database. Common +values would be C or C. Less common values would be +C, C, or C. The appropriate DBD::* Perl module for +the chosen driver must be installed and will be dynamically loaded by the +wallet. For more information, see DBI(3). This variable must be set. @@ -95,8 +100,8 @@ our $DB_DRIVER; =item DB_INFO Sets the remaining contents for the DBI DSN (everything after the driver). -Using this variable provides full control over the connect string passed to -DBI. When using SQLite, set this variable to the path to the SQLite +Using this variable provides full control over the connect string passed +to DBI. When using SQLite, set this variable to the path to the SQLite database. If this variable is set, DB_NAME, DB_HOST, and DB_PORT are ignored. For more information, see DBI(3) and the documentation for the database driver you're using. @@ -111,9 +116,10 @@ our $DB_INFO; =item DB_NAME If DB_INFO is not set, specifies the database name. The third part of the -DBI connect string will be set to C, possibly with a host -and port appended if DB_HOST and DB_PORT are set. For more information, see -DBI(3) and the documentation for the database driver you're using. +DBI connect string will be set to C, possibly with a +host and port appended if DB_HOST and DB_PORT are set. For more +information, see DBI(3) and the documentation for the database driver +you're using. Either DB_INFO or DB_NAME must be set. @@ -124,8 +130,8 @@ our $DB_NAME; =item DB_HOST If DB_INFO is not set, specifies the database host. C<;host=DB_HOST> will -be appended to the DBI connect string. For more information, see DBI(3) and -the documentation for the database driver you're using. +be appended to the DBI connect string. For more information, see DBI(3) +and the documentation for the database driver you're using. =cut @@ -135,8 +141,8 @@ our $DB_HOST; If DB_PORT is not set, specifies the database port. C<;port=DB_PORT> will be appended to the DBI connect string. If this variable is set, DB_HOST -should also be set. For more information, see DBI(3) and the documentation -for the database driver you're using. +should also be set. For more information, see DBI(3) and the +documentation for the database driver you're using. =cut @@ -153,8 +159,8 @@ our $DB_USER; =item DB_PASSWORD -Specifies the password for database authentication. Some database backends, -particularly SQLite, do not need this. +Specifies the password for database authentication. Some database +backends, particularly SQLite, do not need this. =cut @@ -205,9 +211,10 @@ C object type (the Wallet::Object::Keytab class). =item KEYTAB_FILE Specifies the keytab to use to authenticate to B. The principal -whose key is stored in this keytab must have the ability to create, modify, -inspect, and delete any principals that should be managed by the wallet. -(In MIT Kerberos F parlance, this is C privileges.) +whose key is stored in this keytab must have the ability to create, +modify, inspect, and delete any principals that should be managed by the +wallet. (In MIT Kerberos F parlance, this is C +privileges.) KEYTAB_FILE must be set to use keytab objects. @@ -218,12 +225,13 @@ our $KEYTAB_FILE; =item KEYTAB_FLAGS These flags, if any, are passed to the C command when creating a -new principal in the Kerberos KDC. To not pass any flags, set KEYTAB_FLAGS -to the empty string. The default value is C<-clearpolicy>, which clears any -password strength policy from principals created by the wallet. (Since the -wallet randomizes the keys, password strength checking is generally -pointless and may interact poorly with the way C works -when third-party add-ons for password strength checking are used.) +new principal in the Kerberos KDC. To not pass any flags, set +KEYTAB_FLAGS to the empty string. The default value is C<-clearpolicy>, +which clears any password strength policy from principals created by the +wallet. (Since the wallet randomizes the keys, password strength checking +is generally pointless and may interact poorly with the way C works when third-party add-ons for password strength checking +are used.) =cut @@ -264,9 +272,9 @@ our $KEYTAB_KRBTYPE; The principal whose key is stored in KEYTAB_FILE. The wallet will authenticate as this principal to the kadmin service. -KEYTAB_PRINCIPAL must be set to use keytab objects, at least until B -is smart enough to use the first principal found in the keytab it's using -for authentication. +KEYTAB_PRINCIPAL must be set to use keytab objects, at least until +B is smart enough to use the first principal found in the keytab +it's using for authentication. =cut @@ -289,11 +297,11 @@ our $KEYTAB_REALM; =item KEYTAB_TMP A directory into which the wallet can write keytabs temporarily while -processing C commands from clients. The keytabs are written into this -directory with predictable names, so this should not be a system temporary -directory such as F or F. It's best to create a directory -solely for this purpose that's owned by the user the wallet server will run -as. +processing C commands from clients. The keytabs are written into +this directory with predictable names, so this should not be a system +temporary directory such as F or F. It's best to create a +directory solely for this purpose that's owned by the user the wallet +server will run as. KEYTAB_TMP must be set to use keytab objects. @@ -305,20 +313,20 @@ our $KEYTAB_TMP; =head2 Retrieving Existing Keytabs -The keytab object backend optionally supports retrieving existing keys, and -hence keytabs, for Kerberos principals by contacting the KDC via remctl and -talking to B. This is enabled by setting the C -flag on keytab objects. To configure that support, set the following -variables. +The keytab object backend optionally supports retrieving existing keys, +and hence keytabs, for Kerberos principals by contacting the KDC via +remctl and talking to B. This is enabled by setting the +C flag on keytab objects. To configure that support, set the +following variables. =over 4 =item KEYTAB_REMCTL_CACHE -Specifies the ticket cache to use when retrieving existing keytabs from the -KDC. This is only used to implement support for the C flag. -The ticket cache must be for a principal with access to run C via remctl on KEYTAB_REMCTL_HOST. +Specifies the ticket cache to use when retrieving existing keytabs from +the KDC. This is only used to implement support for the C +flag. The ticket cache must be for a principal with access to run +C via remctl on KEYTAB_REMCTL_HOST. =cut @@ -326,10 +334,10 @@ our $KEYTAB_REMCTL_CACHE; =item KEYTAB_REMCTL_HOST -The host to which to connect with remctl to retrieve existing keytabs. This -is only used to implement support for the C flag. This host -must provide the C command and KEYTAB_REMCTL_CACHE must -also be set to a ticket cache for a principal with access to run that +The host to which to connect with remctl to retrieve existing keytabs. +This is only used to implement support for the C flag. This +host must provide the C command and KEYTAB_REMCTL_CACHE +must also be set to a ticket cache for a principal with access to run that command. =cut @@ -339,9 +347,10 @@ our $KEYTAB_REMCTL_HOST; =item KEYTAB_REMCTL_PRINCIPAL The service principal to which to authenticate when retrieving existing -keytabs. This is only used to implement support for the C flag. -If this variable is not set, the default is formed by prepending C to -KEYTAB_REMCTL_HOST. (Note that KEYTAB_REMCTL_HOST is not lowercased first.) +keytabs. This is only used to implement support for the C +flag. If this variable is not set, the default is formed by prepending +C to KEYTAB_REMCTL_HOST. (Note that KEYTAB_REMCTL_HOST is not +lowercased first.) =cut @@ -365,18 +374,18 @@ our $KEYTAB_REMCTL_PORT; These configuration variables are only needed if you intend to use the C ACL type (the Wallet::ACL::NetDB class). They specify the remctl connection information for retrieving user roles from NetDB and the local -realm to remove from principals (since NetDB normally expects unscoped local -usernames). +realm to remove from principals (since NetDB normally expects unscoped +local usernames). =over 4 =item NETDB_REALM The wallet uses fully-qualified principal names (including the realm), but -NetDB normally expects local usernames without the realm. If this variable -is set, the given realm will be stripped from any principal names before -passing them to NetDB. Principals in other realms will be passed to NetDB -without modification. +NetDB normally expects local usernames without the realm. If this +variable is set, the given realm will be stripped from any principal names +before passing them to NetDB. Principals in other realms will be passed +to NetDB without modification. =cut @@ -385,9 +394,9 @@ our $NETDB_REALM; =item NETDB_REMCTL_CACHE Specifies the ticket cache to use when querying the NetDB remctl interface -for user roles. The ticket cache must be for a principal with access to run -C via remctl on KEYTAB_REMCTL_HOST. This variable must be -set to use NetDB ACLs. +for user roles. The ticket cache must be for a principal with access to +run C via remctl on KEYTAB_REMCTL_HOST. This variable +must be set to use NetDB ACLs. =cut @@ -406,10 +415,10 @@ our $NETDB_REMCTL_HOST; =item NETDB_REMCTL_PRINCIPAL -The service principal to which to authenticate when querying NetDB for user -roles. If this variable is not set, the default is formed by prepending -C to NETDB_REMCTL_HOST. (Note that NETDB_REMCTL_HOST is not -lowercased first.) +The service principal to which to authenticate when querying NetDB for +user roles. If this variable is not set, the default is formed by +prepending C to NETDB_REMCTL_HOST. (Note that NETDB_REMCTL_HOST is +not lowercased first.) =cut @@ -417,9 +426,9 @@ our $NETDB_REMCTL_PRINCIPAL; =item NETDB_REMCTL_PORT -The port on NETDB_REMCTL_HOST to which to connect with remctl to query NetDB -for user roles. If this variable is not set, the default remctl port will -be used. +The port on NETDB_REMCTL_HOST to which to connect with remctl to query +NetDB for user roles. If this variable is not set, the default remctl +port will be used. =cut @@ -430,17 +439,18 @@ our $NETDB_REMCTL_PORT; =head1 DEFAULT OWNERS By default, only users in the ADMIN ACL can create new objects in the -wallet. To allow other users to create new objects, define a Perl function -named default_owner. This function will be called whenever a non-ADMIN user -tries to create a new object and will be passed the type and name of the -object. It should return undef if there is no default owner for that -object. If there is, it should return a list containing the name to use for -the ACL and then zero or more anonymous arrays of two elements each giving -the type and identifier for each ACL entry. - -For example, the following simple function says to use a default owner named -C with one entry of type C and identifier C -for the object with type C and name C: +wallet. To allow other users to create new objects, define a Perl +function named default_owner. This function will be called whenever a +non-ADMIN user tries to create a new object and will be passed the type +and name of the object. It should return undef if there is no default +owner for that object. If there is, it should return a list containing +the name to use for the ACL and then zero or more anonymous arrays of two +elements each giving the type and identifier for each ACL entry. + +For example, the following simple function says to use a default owner +named C with one entry of type C and identifier +C for the object with type C and name +C: sub default_owner { my ($type, $name) = @_; @@ -453,8 +463,8 @@ for the object with type C and name C: Of course, normally this function is used for more complex mappings. Here is a more complete example. For objects of type keytab corresponding to -various types of per-machine principals, return a default owner that sets as -owner anyone with a NetDB role for that system and the system's host +various types of per-machine principals, return a default owner that sets +as owner anyone with a NetDB role for that system and the system's host principal. This permits authorization management using NetDB while also allowing the system to bootstrap itself once the host principal has been downloaded and rekey itself using the old host principal. @@ -474,17 +484,19 @@ downloaded and rekey itself using the old host principal. return ($acl_name, @acl); } -The auto-created ACL used for the owner of the new object will, in the above -example, be named C> where I is the fully-qualified -name of the system as derived from the keytab being requested. - -If the name of the ACL returned by the default_owner function matches an ACL -that already exists in the wallet database, the existing ACL will be -compared to the default ACL returned by the default_owner function. If the -existing ACL has the same entries as the one returned by default_owner, -creation continues if the user is authorized by that ACL. If they don't -match, creation of the object is rejected, since the presence of an existing -ACL may indicate that something different is being done with this object. +The auto-created ACL used for the owner of the new object will, in the +above example, be named C> where I is the +fully-qualified name of the system as derived from the keytab being +requested. + +If the name of the ACL returned by the default_owner function matches an +ACL that already exists in the wallet database, the existing ACL will be +compared to the default ACL returned by the default_owner function. If +the existing ACL has the same entries as the one returned by +default_owner, creation continues if the user is authorized by that ACL. +If they don't match, creation of the object is rejected, since the +presence of an existing ACL may indicate that something different is being +done with this object. =head1 NAMING ENFORCEMENT diff --git a/perl/Wallet/Database.pm b/perl/Wallet/Database.pm index 68fb6bb..7b3474a 100644 --- a/perl/Wallet/Database.pm +++ b/perl/Wallet/Database.pm @@ -6,7 +6,7 @@ # like DBI objects in the rest of the code. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -39,7 +39,7 @@ use Wallet::Config; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.01'; +$VERSION = '0.02'; ############################################################################## # Core overrides @@ -84,6 +84,9 @@ __END__ Wallet::Dabase - Wrapper module for wallet database connections +=for stopwords +DBI RaiseError PrintError AutoCommit Allbery + =head1 SYNOPSIS use Wallet::Database; @@ -93,9 +96,9 @@ Wallet::Dabase - Wrapper module for wallet database connections Wallet::Database is a thin wrapper module around DBI that takes care of building a connect string and setting database options based on wallet -configuration. The only overriden method is connect(). All other methods -should work the same as in DBI and Wallet::Database objects should be -usable exactly as if they were DBI objects. +configuration. The only overridden method is connect(). All other +methods should work the same as in DBI and Wallet::Database objects should +be usable exactly as if they were DBI objects. connect() will obtain the database connection information from the wallet configuration; see Wallet::Config(3) for more details. It will also @@ -120,8 +123,8 @@ configuration. DBI(3), Wallet::Config(3) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm index 65ddf4b..b653f87 100644 --- a/perl/Wallet/Kadmin.pm +++ b/perl/Wallet/Kadmin.pm @@ -55,6 +55,9 @@ __END__ # Documentation ############################################################################## +=for stopwords +Kadmin keytabs keytab Heimdal API kadmind kadmin + =head1 NAME Wallet::Kadmin - Kadmin module wrapper for wallet keytabs @@ -69,21 +72,21 @@ Wallet::Kadmin - Kadmin module wrapper for wallet keytabs =head1 DESCRIPTION -Wallet::Kadmin is a wrapper to modules that provide an interface for keytab -integration with the wallet. Each module is meant to interface with a -specific type of Kerberos implementation, such as MIT Kerberos or Heimdal -Kerberos, and provide a standndard set of API calls used to interact with -that implementation's kadmind. +Wallet::Kadmin is a wrapper to modules that provide an interface for +keytab integration with wallet. Each module is meant to interface with a +specific type of Kerberos implementation, such as MIT Kerberos or Heimdal, +and provide a standard set of API calls used to interact with that +implementation's kadmin interface. The class simply uses Wallet::Config to find which type of kadmind we have requested to use, and then returns an object to use for interacting with that kadmind. A keytab is an on-disk store for the key or keys for a Kerberos principal. -Keytabs are used by services to verify incoming authentication from clients -or by automated processes that need to authenticate to Kerberos. To create -a keytab, the principal has to be created in Kerberos and then a keytab is -generated and stored in a file on disk. +Keytabs are used by services to verify incoming authentication from +clients or by automated processes that need to authenticate to Kerberos. +To create a keytab, the principal has to be created in Kerberos and then a +keytab is generated and stored in a file on disk. To use this object, several configuration parameters must be set. See Wallet::Config(3) for details on those configuration parameters and @@ -95,9 +98,9 @@ information about how to set wallet configuration. =item new() -Finds the proper Kerberos implementation and calls the new() constructor for -that implementation's module, returning the result. If the implementation -is not recognized or set, die with an error message. +Finds the proper Kerberos implementation and calls the new() constructor +for that implementation's module, returning the result. If the +implementation is not recognized or set, die with an error message. =back @@ -105,8 +108,8 @@ is not recognized or set, die with an error message. kadmin(8), Wallet::Config(3), Wallet::Object::Keytab(3), wallet-backend(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHORS diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm index 428202b..2ad35e3 100644 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ b/perl/Wallet/Kadmin/Heimdal.pm @@ -230,9 +230,12 @@ __END__ # Documentation ############################################################################## +=for stopwords +keytabs keytab kadmin enctypes API ENCTYPES enctype Allbery Heimdal + =head1 NAME -Wallet::Kadmin::MIT - MIT admin interactions for wallet keytabs +Wallet::Kadmin::Heimdal - Heimdal admin interactions for wallet keytabs =head1 SYNOPSIS @@ -244,18 +247,18 @@ Wallet::Kadmin::MIT - MIT admin interactions for wallet keytabs =head1 DESCRIPTION -Wallet::Kadmin::MIT is an interface for keytab integration with the wallet, -specifically for using kadmin to create, delete, and add enctypes to keytabs. -It implments the wallet kadmin API and provides the necessary glue to MIT -Kerberos installs for each of these functions, while allowing the wallet -to keep the details of what type of Kerberos installation is being used -abstracted. +Wallet::Kadmin::Heimdal is an interface for keytab integration with the +wallet, specifically for using kadmin to create, delete, and add enctypes +to keytabs. It implements the wallet kadmin API and provides the +necessary glue to Heimdal installs for each of these functions, while +allowing the wallet to keep the details of what type of Kerberos +installation is being used abstracted. A keytab is an on-disk store for the key or keys for a Kerberos principal. -Keytabs are used by services to verify incoming authentication from clients -or by automated processes that need to authenticate to Kerberos. To create -a keytab, the principal has to be created in Kerberos and then a keytab is -generated and stored in a file on disk. +Keytabs are used by services to verify incoming authentication from +clients or by automated processes that need to authenticate to Kerberos. +To create a keytab, the principal has to be created in Kerberos and then a +keytab is generated and stored in a file on disk. To use this object, several configuration parameters must be set. See Wallet::Config(3) for details on those configuration parameters and @@ -268,17 +271,17 @@ information about how to set wallet configuration. =item addprinc(PRINCIPAL) Adds a new principal with a given name. The principal is created with a -random password, and any other flags set by Wallet::Config. Returns true on -success, or throws an error if there was a failure in adding the principal. -If the principal already exists, return true as we are bringing our -expectations in line with reality. +random password, and any other flags set by Wallet::Config. Returns true +on success, or throws an error if there was a failure in adding the +principal. If the principal already exists, return true as we are +bringing our expectations in line with reality. =item addprinc(PRINCIPAL) -Removes a principal with the given name. Returns true on success, or throws -an error if there was a failure in removing the principal. If the principal -does not exist, return true as we are bringing our expectations in line with -reality. +Removes a principal with the given name. Returns true on success, or +throws an error if there was a failure in removing the principal. If the +principal does not exist, return true as we are bringing our expectations +in line with reality. =item ktadd(PRINCIPAL, FILE, ENCTYPES) @@ -290,19 +293,12 @@ otherwise true is returned. =back -=head1 LIMITATIONS - -Currently, this implementation calls an external B program rather - than using a native Perl module and therefore requires B be -installed and parses its output. It may miss some error conditions if the -output of B ever changes. - =head1 SEE ALSO kadmin(8), Wallet::Config(3), Wallet::Object::Keytab(3), wallet-backend(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHORS diff --git a/perl/Wallet/Kadmin/MIT.pm b/perl/Wallet/Kadmin/MIT.pm index 49691b0..8449868 100644 --- a/perl/Wallet/Kadmin/MIT.pm +++ b/perl/Wallet/Kadmin/MIT.pm @@ -226,6 +226,9 @@ __END__ # Documentation ############################################################################## +=for stopwords +keytabs keytab kadmin enctype enctypes API ENCTYPES Allbery + =head1 NAME Wallet::Kadmin::MIT - MIT admin interactions for wallet keytabs @@ -240,18 +243,18 @@ Wallet::Kadmin::MIT - MIT admin interactions for wallet keytabs =head1 DESCRIPTION -Wallet::Kadmin::MIT is an interface for keytab integration with the wallet, -specifically for using kadmin to create, delete, and add enctypes to keytabs. -It implments the wallet kadmin API and provides the necessary glue to MIT -Kerberos installs for each of these functions, while allowing the wallet -to keep the details of what type of Kerberos installation is being used -abstracted. +Wallet::Kadmin::MIT is an interface for keytab integration with the +wallet, specifically for using kadmin to create, delete, and add enctypes +to keytabs. It implements the wallet kadmin API and provides the +necessary glue to MIT Kerberos installs for each of these functions, while +allowing the wallet to keep the details of what type of Kerberos +installation is being used abstracted. A keytab is an on-disk store for the key or keys for a Kerberos principal. -Keytabs are used by services to verify incoming authentication from clients -or by automated processes that need to authenticate to Kerberos. To create -a keytab, the principal has to be created in Kerberos and then a keytab is -generated and stored in a file on disk. +Keytabs are used by services to verify incoming authentication from +clients or by automated processes that need to authenticate to Kerberos. +To create a keytab, the principal has to be created in Kerberos and then a +keytab is generated and stored in a file on disk. To use this object, several configuration parameters must be set. See Wallet::Config(3) for details on those configuration parameters and @@ -264,17 +267,17 @@ information about how to set wallet configuration. =item addprinc(PRINCIPAL) Adds a new principal with a given name. The principal is created with a -random password, and any other flags set by Wallet::Config. Returns true on -success, or throws an error if there was a failure in adding the principal. -If the principal already exists, return true as we are bringing our -expectations in line with reality. +random password, and any other flags set by Wallet::Config. Returns true +on success, or throws an error if there was a failure in adding the +principal. If the principal already exists, return true as we are +bringing our expectations in line with reality. -=item addprinc(PRINCIPAL) +=item delprinc(PRINCIPAL) -Removes a principal with the given name. Returns true on success, or throws -an error if there was a failure in removing the principal. If the principal -does not exist, return true as we are bringing our expectations in line with -reality. +Removes a principal with the given name. Returns true on success, or +throws an error if there was a failure in removing the principal. If the +principal does not exist, return true as we are bringing our expectations +in line with reality. =item ktadd(PRINCIPAL, FILE, ENCTYPES) @@ -297,8 +300,8 @@ output of B ever changes. kadmin(8), Wallet::Config(3), Wallet::Object::Keytab(3), wallet-backend(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHORS diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm index fea0320..5097729 100644 --- a/perl/Wallet/Object/Base.pm +++ b/perl/Wallet/Object/Base.pm @@ -1,7 +1,7 @@ # Wallet::Object::Base -- Parent class for any object stored in the wallet. # # Written by Russ Allbery -# 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. @@ -22,7 +22,7 @@ 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.04'; +$VERSION = '0.05'; ############################################################################## # Constructors @@ -669,6 +669,10 @@ __END__ Wallet::Object::Base - Generic parent class for wallet objects +=for stopwords +DBH HOSTNAME DATETIME ACL backend metadata timestamp Allbery wallet-backend +backend-specific + =head1 SYNOPSIS package Wallet::Object::Simple; @@ -682,104 +686,107 @@ Wallet::Object::Base - Generic parent class for wallet objects =head1 DESCRIPTION Wallet::Object::Base is the generic parent class for wallet objects (data -types that can be stored in the wallet system). It provides defualt +types that can be stored in the wallet system). It provides default functions and behavior, including handling generic object settings. All handlers for objects stored in the wallet should inherit from it. It is not used directly. =head1 PUBLIC CLASS METHODS -The following methods are called by the rest of the wallet system and should -be implemented by all objects stored in the wallet. They should be called -with the desired wallet object class as the first argument (generally using -the Wallet::Object::Type->new syntax). +The following methods are called by the rest of the wallet system and +should be implemented by all objects stored in the wallet. They should be +called with the desired wallet object class as the first argument +(generally using the Wallet::Object::Type->new syntax). =over 4 =item new(TYPE, NAME, DBH) Creates a new object with the given object type and name, based on data -already in the database. This method will only succeed if an object of the -given TYPE and NAME is already present in the wallet database. If no such -object exits, throws an exception. Otherwise, returns an object blessed -into the class used for the new() call (so subclasses can leave this method -alone and not override it). +already in the database. This method will only succeed if an object of +the given TYPE and NAME is already present in the wallet database. If no +such object exits, throws an exception. Otherwise, returns an object +blessed into the class used for the new() call (so subclasses can leave +this method alone and not override it). -Takes a Wallet::Database object, which is stored in the object and used for -any further operations. +Takes a Wallet::Database object, which is stored in the object and used +for any further operations. =item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME]) Similar to new() but instead creates a new entry in the database. This method will throw an exception if an entry for that type and name already -exists in the database or if creating the database record fails. Otherwise, -a new database entry will be created with that type and name, no owner, no -ACLs, no expiration, no flags, and with created by, from, and on set to the -PRINCIPAL, HOSTNAME, and DATETIME parameters. If DATETIME isn't given, the -current time is used. The database handle is treated as with new(). +exists in the database or if creating the database record fails. +Otherwise, a new database entry will be created with that type and name, +no owner, no ACLs, no expiration, no flags, and with created by, from, and +on set to the PRINCIPAL, HOSTNAME, and DATETIME parameters. If DATETIME +isn't given, the current time is used. The database handle is treated as +with new(). =back =head1 PUBLIC INSTANCE METHODS The following methods may be called on instantiated wallet objects. -Normally, the only methods that a subclass will need to override are get(), -store(), show(), and destroy(). +Normally, the only methods that a subclass will need to override are +get(), store(), show(), and destroy(). -If the locked flag is set on an object, no actions may be performed on that -object except for the flag methods and show(). All other actions will be -rejected with an error saying the object is locked. +If the locked flag is set on an object, no actions may be performed on +that object except for the flag methods and show(). All other actions +will be rejected with an error saying the object is locked. =over 4 =item acl(TYPE [, ACL, PRINCIPAL, HOSTNAME [, DATETIME]]) -Sets or retrieves a given object ACL as a numeric ACL ID. TYPE must be one -of C, C, C, C, or C, corresponding to the -ACLs kept on an object. If no other arguments are given, returns the -current ACL setting as an ACL ID or undef if that ACL isn't set. If other -arguments are given, change that ACL to ACL and return true on success and -false on failure. Pass in the empty string for ACL to clear the ACL. The -other arguments are used for logging and history and should indicate the -user and host from which the change is made and the time of the change. +Sets or retrieves a given object ACL as a numeric ACL ID. TYPE must be +one of C, C, C, C, or C, corresponding +to the ACLs kept on an object. If no other arguments are given, returns +the current ACL setting as an ACL ID or undef if that ACL isn't set. If +other arguments are given, change that ACL to ACL and return true on +success and false on failure. Pass in the empty string for ACL to clear +the ACL. The other arguments are used for logging and history and should +indicate the user and host from which the change is made and the time of +the change. =item attr(ATTRIBUTE [, VALUES, PRINCIPAL, HOSTNAME [, DATETIME]]) Sets or retrieves a given object attribute. Attributes are used to store -backend-specific information for a particular object type and ATTRIBUTE must -be an attribute type known to the underlying object implementation. The -default implementation of this method rejects all attributes as unknown. +backend-specific information for a particular object type and ATTRIBUTE +must be an attribute type known to the underlying object implementation. +The default implementation of this method rejects all attributes as +unknown. If no other arguments besides ATTRIBUTE are given, returns the values of that attribute, if any, as a list. On error, returns the empty list. To -distinguish between an error and an empty return, call error() afterwards. +distinguish between an error and an empty return, call error() afterward. It is guaranteed to return undef unless there was an error. If other arguments are given, sets the given ATTRIBUTE values to VALUES, -which must be a reference to an array (even if only one value is being set). -Pass a reference to an empty array to clear the attribute values. The other -arguments are used for logging and history and should indicate the user and -host from which the change is made and the time of the change. Returns true -on success and false on failure. +which must be a reference to an array (even if only one value is being +set). Pass a reference to an empty array to clear the attribute values. +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. Returns true on success and false on failure. =item attr_show() -Returns a formatted text description of the type-specific attributes of the -object, or undef on error. The default implementation of this method always -returns the empty string. If there are any type-specific attributes set, -this method should return that metadata, formatted as key: value pairs with -the keys right-aligned in the first 15 characters, followed by a space, a -colon, and the value. +Returns a formatted text description of the type-specific attributes of +the object, or undef on error. The default implementation of this method +always returns the empty string. If there are any type-specific +attributes set, this method should return that metadata, formatted as key: +value pairs with the keys right-aligned in the first 15 characters, +followed by a space, a colon, and the value. =item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) Destroys the object by removing all record of it from the database. The -Wallet::Object::Base implementation handles the generic database work, -but any subclass should override this method to do any deletion of files -or entries in external databases and any other database entries and then -call the parent method to handle the generic database cleanup. Returns -true on success and false on failure. The arguments are used for logging -and history and should indicate the user and host from which the change is +Wallet::Object::Base implementation handles the generic database work, but +any subclass should override this method to do any deletion of files or +entries in external databases and any other database entries and then call +the parent method to handle the generic database cleanup. Returns true on +success and false on failure. The arguments are used for logging and +history and should indicate the user and host from which the change is made and the time of the change. =item error([ERROR ...]) @@ -789,47 +796,50 @@ have failed. Callers should call this function to get the error message after an undef return from any other instance method. For the convenience of child classes, this method can also be called with -one or more error strings. If so, those strings are concatenated together, -trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is stored -as the error. Only child classes should call this method with an error -string. +one or more error strings. If so, those strings are concatenated +together, trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is +stored as the error. Only child classes should call this method with an +error string. =item expires([EXPIRES, PRINCIPAL, HOSTNAME [, DATETIME]]) Sets or retrieves the expiration date of an object. If no arguments are -given, returns the current expiration or undef if no expiration is set. If -arguments are given, change the expiration to EXPIRES and return true on -success and false on failure. EXPIRES must be in the format C, although the time portion may be omitted. Pass in the empty -string for EXPIRES to clear the expiration date. - -The other arguments are used for logging and history and should indicate the -user and host from which the change is made and the time of the change. +given, returns the current expiration or undef if no expiration is set. +If arguments are given, change the expiration to EXPIRES and return true +on success and false on failure. EXPIRES must be in the format +C, although the time portion may be omitted. Pass in +the empty string for EXPIRES to clear the expiration date. + +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. =item flag_check(FLAG) -Check whether the given flag is set on an object. Returns true if set, C<0> -if not set, and undef on error. +Check whether the given flag is set on an object. Returns true if set, +C<0> if not set, and undef on error. =item flag_clear(FLAG, PRINCIPAL, HOSTNAME [, DATETIME]) Clears FLAG on an object. Returns true on success and false on failure. -The other arguments are used for logging and history and should indicate the -user and host from which the change is made and the time of the change. +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. =item flag_list() List the flags set on an object. If no flags are set, returns the empty -list. On failure, returns an empty list. To distinguish between the empty -response and an error, the caller should call error() after an empty return. -It is guaranteed to return undef if there was no error. +list. On failure, returns an empty list. To distinguish between the +empty response and an error, the caller should call error() after an empty +return. It is guaranteed to return undef if there was no error. =item flag_set(FLAG, PRINCIPAL, HOSTNAME [, DATETIME]) Sets FLAG on an object. Returns true on success and false on failure. -The other arguments are used for logging and history and should indicate the -user and host from which the change is made and the time of the change. +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. =item get(PRINCIPAL, HOSTNAME [, DATETIME]) @@ -856,9 +866,9 @@ Sets or retrieves the owner of an object as a numeric ACL ID. If no arguments are given, returns the current owner ACL ID or undef if none is set. If arguments are given, change the owner to OWNER and return true on success and false on failure. Pass in the empty string for OWNER to clear -the owner. The other arguments are used for logging and history and should -indicate the user and host from which the change is made and the time of the -change. +the owner. The other arguments are used for logging and history and +should indicate the user and host from which the change is made and the +time of the change. =item show() @@ -866,17 +876,17 @@ Returns a formatted text description of the object suitable for human display, or undef on error. All of the base metadata about the object, formatted as key: value pairs with the keys aligned in the first 15 characters followed by a space, a colon, and the value. The attr_show() -method of the object is also called and any formatted output it returns will -be included. If any ACLs or an owner are set, after this data there is a -blank line and then the information for each unique ACL, separated by blank -lines. +method of the object is also called and any formatted output it returns +will be included. If any ACLs or an owner are set, after this data there +is a blank line and then the information for each unique ACL, separated by +blank lines. =item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME]) Store user-supplied data into the given object. This may not be supported -by all backends (for instance, backends that automatically generate the data -will not support this). The default implementation rejects all store() -calls with an error message saying that the object is immutable. +by all backends (for instance, backends that automatically generate the +data will not support this). The default implementation rejects all +store() calls with an error message saying that the object is immutable. =item type() @@ -894,23 +904,24 @@ provided for subclasses to call to implement some generic actions. =item log_action (ACTION, PRINCIPAL, HOSTNAME, DATETIME) Updates the history tables and trace information appropriately for ACTION, -which should be either C or C. No other changes are made to the -database, just updates of the history table and trace fields with the +which should be either C or C. No other changes are made to +the database, just updates of the history table and trace fields with the provided data about who performed the action and when. -This function commits its transaction when complete and therefore should not -be called inside another transaction. Normally it's called as a separate -transaction after the data is successfully stored or retrieved. +This function commits its transaction when complete and therefore should +not be called inside another transaction. Normally it's called as a +separate transaction after the data is successfully stored or retrieved. =item log_set (FIELD, OLD, NEW, PRINCIPAL, HOSTNAME, DATETIME) -Updates the history tables for the change in a setting value for an object. -FIELD should be one of C, C, C, C, -C, C, C, C, or a value starting with -C followed by a space and a type-specific field name. The last -form is the most common form used by a subclass. OLD is the previous value -of the field or undef if the field was unset, and NEW is the new value of -the field or undef if the field should be unset. +Updates the history tables for the change in a setting value for an +object. FIELD should be one of C, C, C, +C, C, C, C, C, or a +value starting with C followed by a space and a type-specific +field name. The last form is the most common form used by a subclass. +OLD is the previous value of the field or undef if the field was unset, +and NEW is the new value of the field or undef if the field should be +unset. This function does not commit and does not catch database exceptions. It should normally be called as part of a larger transaction that implements @@ -922,8 +933,8 @@ the change in the setting. wallet-backend(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/Wallet/Object/File.pm b/perl/Wallet/Object/File.pm index be72d7f..69262f6 100644 --- a/perl/Wallet/Object/File.pm +++ b/perl/Wallet/Object/File.pm @@ -1,7 +1,7 @@ # Wallet::Object::File -- File object implementation for the wallet. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -24,7 +24,7 @@ use 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'; +$VERSION = '0.02'; ############################################################################## # File naming @@ -136,6 +136,9 @@ __END__ Wallet::Object::File - File object implementation for wallet +=for stopwords +API HOSTNAME DATETIME keytab remctld backend nul Allbery wallet-backend + =head1 SYNOPSIS my @name = qw(file mysql-lsdb) @@ -163,17 +166,18 @@ 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. +documentation for that class for all generic methods. Below are only +those methods that are overridden or behave specially for this +implementation. =over 4 =item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) Destroys a file object by removing it from the database and deleting the -corresonding 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 +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. diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index b604907..760280f 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -382,6 +382,10 @@ __END__ # Documentation ############################################################################## +=for stopwords +keytab API KDC keytabs HOSTNAME DATETIME enctypes enctype DBH metadata +unmanaged kadmin Allbery + =head1 NAME Wallet::Object::Keytab - Keytab object implementation for wallet @@ -396,17 +400,17 @@ Wallet::Object::Keytab - Keytab object implementation for wallet =head1 DESCRIPTION -Wallet::Object::Keytab is a representation of Kerberos keytab objects in the -wallet. It implements the wallet object API and provides the necessary -glue to create principals in a Kerberos KDC, create and return keytabs for -those principals, and delete them out of Kerberos when the wallet object is -destroyed. +Wallet::Object::Keytab is a representation of Kerberos keytab objects in +the wallet. It implements the wallet object API and provides the +necessary glue to create principals in a Kerberos KDC, create and return +keytabs for those principals, and delete them out of Kerberos when the +wallet object is destroyed. A keytab is an on-disk store for the key or keys for a Kerberos principal. -Keytabs are used by services to verify incoming authentication from clients -or by automated processes that need to authenticate to Kerberos. To create -a keytab, the principal has to be created in Kerberos and then a keytab is -generated and stored in a file on disk. +Keytabs are used by services to verify incoming authentication from +clients or by automated processes that need to authenticate to Kerberos. +To create a keytab, the principal has to be created in Kerberos and then a +keytab is generated and stored in a file on disk. This implementation generates a new random key (and hence invalidates all existing keytabs) each time the keytab is retrieved with the get() method. @@ -418,8 +422,9 @@ 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. +documentation for that class for all generic methods. Below are only +those methods that are overridden or behave specially for this +implementation. =over 4 @@ -453,12 +458,12 @@ enctypes than those requested by this attribute. If no other arguments besides ATTRIBUTE are given, returns the values of that attribute, if any, as a list. On error, returns the empty list. To -distinguish between an error and an empty return, call error() afterwards. +distinguish between an error and an empty return, call error() afterward. It is guaranteed to return undef unless there was an error. If other arguments are given, sets the given ATTRIBUTE values to VALUES, -which must be a reference to an array (even if only one value is being set). -Pass a reference to an empty array to clear the attribute values. +which must be a reference to an array (even if only one value is being +set). Pass a reference to an empty array to clear the attribute values. PRINCIPAL, HOSTNAME, and DATETIME are stored as history information. PRINCIPAL should be the user who is destroying the object. If DATETIME isn't given, the current time is used. @@ -467,12 +472,12 @@ isn't given, the current time is used. This is a class method and should be called on the Wallet::Object::Keytab class. It creates a new object with the given TYPE and NAME (TYPE is -normally C and must be for the rest of the wallet system to use the -right class, but this module doesn't check for ease of subclassing), using -DBH as the handle to the wallet metadata database. PRINCIPAL, HOSTNAME, and -DATETIME are stored as history information. PRINCIPAL should be the user -who is creating the object. If DATETIME isn't given, the current time is -used. +normally C and must be for the rest of the wallet system to use +the right class, but this module doesn't check for ease of subclassing), +using DBH as the handle to the wallet metadata database. PRINCIPAL, +HOSTNAME, and DATETIME are stored as history information. PRINCIPAL +should be the user who is creating the object. If DATETIME isn't given, +the current time is used. When a new keytab object is created, the Kerberos principal designated by NAME is also created in the Kerberos realm determined from the wallet @@ -515,9 +520,9 @@ used. =item KEYTAB_TMP/keytab. -The keytab is created in this file using C and then read into memory. -KEYTAB_TMP is set in the wallet configuration, and is the process ID -of the current process. The file is unlinked after being read. +The keytab is created in this file using C and then read into +memory. KEYTAB_TMP is set in the wallet configuration, and is the +process ID of the current process. The file is unlinked after being read. =back @@ -536,8 +541,8 @@ wallet database do not have realm information. kadmin(8), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index 252da03..589a15d 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -133,6 +133,10 @@ __DATA__ Wallet::Schema - Database schema for the wallet system +=for stopwords +SQL ACL API APIs enums Enums Keytab Backend keytab backend enctypes +enctype Allbery + =head1 SYNOPSIS use Wallet::Schema; @@ -157,30 +161,30 @@ MySQL and may require some modifications for other databases. =item new() -Instantiates a new Wallet::Schema object. This parses the documentation and -extracts the schema, but otherwise doesn't do anything. +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. +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. +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. +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 @@ -188,8 +192,8 @@ database. =head2 Normalization Tables -The following are normalization tables used to constrain the values in other -tables. +The following are normalization tables used to constrain the values in +other tables. Holds the supported flag names: @@ -221,16 +225,16 @@ Holds the supported ACL schemes and their corresponding Perl classes: values ('netdb-root', 'Wallet::ACL::NetDB::Root'); If you have extended the wallet to support additional object types or -additional ACL schemes, you will want to add additional rows to these tables -mapping those types or schemes to Perl classes that implement the object or -ACL verifier APIs. +additional ACL schemes, you will want to add additional rows to these +tables mapping those types or schemes to Perl classes that implement the +object or ACL verifier APIs. =head2 ACL Tables -A wallet ACL consists of zero or more ACL entries, each of which is a scheme -and an identifier. The scheme identifies the check that should be performed -and the identifier is additional scheme-specific information. Each ACL -references entries in the following table: +A wallet ACL consists of zero or more ACL entries, each of which is a +scheme and an identifier. The scheme identifies the check that should be +performed and the identifier is additional scheme-specific information. +Each ACL references entries in the following table: create table acls (ac_id integer auto_increment primary key, @@ -249,8 +253,9 @@ in: create index ae_id on acl_entries (ae_id); ACLs may be referred to in the API via either the numeric ID or the -human-readable name, but internally ACLs are always referenced by numeric ID -so that they can be renamed without requiring complex data modifications. +human-readable name, but internally ACLs are always referenced by numeric +ID so that they can be renamed without requiring complex data +modifications. Currently, the ACL named C (case-sensitive) is special-cased in the Wallet::Server code and granted global access. @@ -269,17 +274,18 @@ table. ah_on datetime not null); create index ah_acl on acl_history (ah_acl); -ah_action must be one of C, C, C, or C (enums -aren't used for compatibility with databases other than MySQL). For a -change of type create or destroy, only the action and the trace records (by, -from, and on) are stored. For a change to the lines of an ACL, the scheme -and identifier of the line that was added or removed is included. Note that -changes to the ACL name are not recorded; ACLs are always tracked by -system-generated ID, so name changes are purely cosmetic. +ah_action must be one of C, C, C, or C +(enums aren't used for compatibility with databases other than MySQL). +For a change of type create or destroy, only the action and the trace +records (by, from, and on) are stored. For a change to the lines of an +ACL, the scheme and identifier of the line that was added or removed is +included. Note that changes to the ACL name are not recorded; ACLs are +always tracked by system-generated ID, so name changes are purely +cosmetic. -ah_by stores the authenticated identity that made the change, ah_from stores -the host from which they made the change, and ah_on stores the time the -change was made. +ah_by stores the authenticated identity that made the change, ah_from +stores the host from which they made the change, and ah_on stores the time +the change was made. =head2 Object Tables @@ -311,13 +317,13 @@ table: create index ob_expires on objects (ob_expires); Object names are not globally unique but only unique within their type, so -the table has a joint primary key. Each object has an owner and then up to -five more specific ACLs. The owner provides permission for get, store, and -show operations if no more specific ACL is set. It does not provide +the table has a joint primary key. Each object has an owner and then up +to five more specific ACLs. The owner provides permission for get, store, +and show operations if no more specific ACL is set. It does not provide permission for destroy or flags. -The ob_acl_flags ACL controls who can set flags on this object. Each object -may have zero or more flags associated with it: +The ob_acl_flags ACL controls who can set flags on this object. Each +object may have zero or more flags associated with it: create table flags (fl_type varchar(16) @@ -348,27 +354,28 @@ this table: oh_on datetime not null); create index oh_object on object_history (oh_type, oh_name); -oh_action must be one of C, C, C, C, or C. -oh_field must be one of C, C, C, C, -C, C, C, C, or C. Enums -aren't used for compatibility with databases other than MySQL. - -For a change of type create, get, store, or destroy, only the action and the -trace records (by, from, and on) are stored. For changes to columns or to -the flags table, oh_field takes what attribute is changed, oh_from takes the -previous value converted to a string and oh_to takes the next value -similarly converted to a string. The special field value "type_data" is -used when type-specific data is changed, and in that case (and only that -case) some type-specific name for the data being changed is stored in -oh_type_field. +oh_action must be one of C, C, C, C, or +C. oh_field must be one of C, C, C, +C, C, C, C, C, or +C. Enums aren't used for compatibility with databases other +than MySQL. + +For a change of type create, get, store, or destroy, only the action and +the trace records (by, from, and on) are stored. For changes to columns +or to the flags table, oh_field takes what attribute is changed, oh_from +takes the previous value converted to a string and oh_to takes the next +value similarly converted to a string. The special field value +"type_data" is used when type-specific data is changed, and in that case +(and only that case) some type-specific name for the data being changed is +stored in oh_type_field. When clearing a flag, oh_old will have the name of the flag and oh_new will be null. When setting a flag, oh_old will be null and oh_new will have the name of the flag. -oh_by stores the authenticated identity that made the change, oh_from stores -the host from which they made the change, and oh_on stores the time the -change was made. +oh_by stores the authenticated identity that made the change, oh_from +stores the host from which they made the change, and oh_on stores the time +the change was made. =head2 Keytab Backend Data @@ -406,16 +413,16 @@ and then the restrictions for a given keytab are stored in this table: primary key (ke_name, ke_enctype)); create index ke_name on keytab_enctypes (ke_name); -To use this functionality, you will need to populate the enctypes table with -the enctypes that a keytab may be restricted to. Currently, there is no -automated mechanism to do this. +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 SEE ALSO wallet-backend(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm index 40e48a3..dd596c4 100644 --- a/perl/Wallet/Server.pm +++ b/perl/Wallet/Server.pm @@ -1,7 +1,7 @@ # Wallet::Server -- Wallet system server implementation. # # Written by Russ Allbery -# 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. @@ -23,7 +23,7 @@ use Wallet::Schema; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.07'; +$VERSION = '0.08'; ############################################################################## # Utility methods @@ -714,6 +714,10 @@ __END__ Wallet::Server - Wallet system server implementation +=for stopwords +keytabs metadata backend HOSTNAME ACL timestamp ACL's nul Allbery +backend-specific wallet-backend + =head1 SYNOPSIS use Wallet::Server; @@ -725,8 +729,8 @@ Wallet::Server - Wallet system server implementation Wallet::Server is the top-level class that implements the wallet server. The wallet is a system for storing, generating, and retrieving secure information such as Kerberos keytabs. The server maintains metadata about -the objects, checks access against ACLs, and dispatches requests for objects -to backend implementations for that object type. +the objects, checks access against ACLs, and dispatches requests for +objects to backend implementations for that object type. Wallet::Server is normally instantiated and used by B, a thin wrapper around this object that determines the authenticated remote @@ -734,8 +738,8 @@ user and gets user input and then calls the appropriate method of this object. To use this object, several configuration variables must be set (at least -the database configuration). For information on those variables and how to -set them, see Wallet::Config(3). +the database configuration). For information on those variables and how +to set them, see Wallet::Config(3). =head1 CLASS METHODS @@ -765,11 +769,12 @@ failure to get the error message. Gets or sets the ACL type ACL to ID for the object identified by TYPE and NAME. ACL should be one of C, C, C, C, or -C. If ID is not given, returns the current setting of that ACL as a -numeric ACL ID or undef if that ACL isn't set or on failure. To distinguish -between an ACL that isn't set and a failure to retrieve the ACL, the caller -should call error() after an undef return. If error() also returns undef, -that ACL wasn't set; otherwise, error() will return the error message. +C. If ID is not given, returns the current setting of that ACL as +a numeric ACL ID or undef if that ACL isn't set or on failure. To +distinguish between an ACL that isn't set and a failure to retrieve the +ACL, the caller should call error() after an undef return. If error() +also returns undef, that ACL wasn't set; otherwise, error() will return +the error message. If ID is given, sets the specified ACL to ID, which can be either the name of an ACL or a numeric ACL ID. To set an ACL, the current user must be @@ -798,64 +803,65 @@ failure. Destroys the ACL identified by ID, which may be either the ACL name or its numeric ID. This call will fail if the ACL is still referenced by any -object. The ADMIN ACL may not be destroyed. To destroy an ACL, the current -user must be authorized by the ADMIN ACL. Returns true on success and false -on failure. +object. The ADMIN ACL may not be destroyed. To destroy an ACL, the +current user must be authorized by the ADMIN ACL. Returns true on success +and false on failure. =item acl_history(ID) -Returns the history of the ACL identified by ID, which may be either the ACL -name or its numeric ID. To see the history of an ACL, the current user must -be authorized by the ADMIN ACL. Each change that modifies the ACL (not -counting changes in the name of the ACL) will be represented by two lines. -The first line will have a timestamp of the change followed by a description -of the change, and the second line will give the user who made the change -and the host from which the change was made. Returns undef on failure. +Returns the history of the ACL identified by ID, which may be either the +ACL name or its numeric ID. To see the history of an ACL, the current +user must be authorized by the ADMIN ACL. Each change that modifies the +ACL (not counting changes in the name of the ACL) will be represented by +two lines. The first line will have a timestamp of the change followed by +a description of the change, and the second line will give the user who +made the change and the host from which the change was made. Returns +undef on failure. =item acl_remove(ID, SCHEME, IDENTIFIER) Removes from the ACL identified by ID the entry matching SCHEME and IDENTIFIER. ID may be either the name of the ACL or its numeric ID. The last entry in the ADMIN ACL cannot be removed. To remove an entry from an -ACL, the current user must be authorized by the ADMIN ACL. Returns true on -success and false on failure. +ACL, the current user must be authorized by the ADMIN ACL. Returns true +on success and false on failure. =item acl_rename(OLD, NEW) Renames the ACL identified by OLD to NEW. This changes the human-readable -name, not the underlying numeric ID, so the ACL's associations with objects -will be unchanged. The ADMIN ACL may not be renamed. OLD may be either the -current name or the numeric ID. NEW must not be all-numeric. To rename an -ACL, the current user must be authorized by the ADMIN ACL. Returns true on -success and false on failure. +name, not the underlying numeric ID, so the ACL's associations with +objects will be unchanged. The ADMIN ACL may not be renamed. OLD may be +either the current name or the numeric ID. NEW must not be all-numeric. +To rename an ACL, the current user must be authorized by the ADMIN ACL. +Returns true on success and false on failure. =item acl_show(ID) Returns a human-readable description, including membership, of the ACL identified by ID, which may be either the ACL name or its numeric ID. To -show an ACL, the current user must be authorized by the ADMIN ACL (although -be aware that anyone with show access to an object can see the membership of -ACLs associated with that object through the show() method). Returns the -human-readable description on success and undef on failure. +show an ACL, the current user must be authorized by the ADMIN ACL +(although be aware that anyone with show access to an object can see the +membership of ACLs associated with that object through the show() method). +Returns the human-readable description on success and undef on failure. =item attr(TYPE, NAME, ATTRIBUTE [, VALUE ...]) Sets or retrieves a given object attribute. Attributes are used to store -backend-specific information for a particular object type and ATTRIBUTE must -be an attribute type known to the underlying object implementation. +backend-specific information for a particular object type and ATTRIBUTE +must be an attribute type known to the underlying object implementation. If VALUE is not given, returns the values of that attribute, if any, as a list. On error, returns the empty list. To distinguish between an error -and an empty return, call error() afterwards. It is guaranteed to return -undef unless there was an error. To retrieve an attribute setting, the user -must be authorized by the ADMIN ACL, the show ACL if set, or the owner ACL -if the show ACL is not set. +and an empty return, call error() afterward. It is guaranteed to return +undef unless there was an error. To retrieve an attribute setting, the +user must be authorized by the ADMIN ACL, the show ACL if set, or the +owner ACL if the show ACL is not set. -If VALUE is given, sets the given ATTRIBUTE values to VALUE, which is one or -more attribute values. Pass the empty string as the only VALUE to clear the -attribute values. Returns true on success and false on failure. To set an -attribute value, the user must be authorized by the ADMIN ACL, the store ACL -if set, or the owner ACL if the store ACL is not set. +If VALUE is given, sets the given ATTRIBUTE values to VALUE, which is one +or more attribute values. Pass the empty string as the only VALUE to +clear the attribute values. Returns true on success and false on failure. +To set an attribute value, the user must be authorized by the ADMIN ACL, +the store ACL if set, or the owner ACL if the store ACL is not set. =item autocreate(TYPE, NAME) @@ -877,9 +883,9 @@ for the existence of the object. =item create(TYPE, NAME) -Creates a new object of type TYPE and name NAME. TYPE must be a recognized -type for which the wallet system has a backend implementation. Returns true -on success and false on failure. +Creates a new object of type TYPE and name NAME. TYPE must be a +recognized type for which the wallet system has a backend implementation. +Returns true on success and false on failure. To create an object using this method, the current user must be authorized by the ADMIN ACL. Use autocreate() to create objects based on the default @@ -888,18 +894,18 @@ owner as determined by the wallet configuration. =item destroy(TYPE, NAME) Destroys the object identified by TYPE and NAME. This destroys any data -that the wallet had saved about the object, may remove the underlying object -from other external systems, and destroys the wallet database entry for the -object. To destroy an object, the current user must be 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. +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. =item dbh() -Returns the database handle of a Wallet::Server object. This is used mostly -for testing; normally, clients should perform all actions through the -Wallet::Server object to ensure that authorization and history logging is -done properly. +Returns the database handle of a Wallet::Server object. This is used +mostly for testing; normally, clients should perform all actions through +the Wallet::Server object to ensure that authorization and history logging +is done properly. =item error() @@ -909,12 +915,12 @@ after an undef return from any other instance method. =item expires(TYPE, NAME [, EXPIRES]) -Gets or sets the expiration for the object identified by TYPE and NAME. If -EXPIRES is not given, returns the current expiration or undef if no -expiration is set or on an error. To distinguish between an expiration that -isn't set and a failure to retrieve the expiration, the caller should call -error() after an undef return. If error() also returns undef, that ACL -wasn't set; otherwise, error() will return the error message. +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. If EXPIRES is given, sets the expiration to EXPIRES. EXPIRES must be in the format C, although the time portion may be @@ -924,23 +930,23 @@ ADMIN ACL. Returns true for success and false for failure. =item flag_clear(TYPE, NAME, FLAG) -Clears the flag FLAG on the object identified by TYPE and NAME. To clear a -flag, the current user must be authorized by the ADMIN ACL or the flags ACL -on the object. +Clears the flag FLAG on the object identified by TYPE and NAME. To clear +a flag, the current user must be authorized by the ADMIN ACL or the flags +ACL on the object. =item flag_set(TYPE, NAME, FLAG) Sets the flag FLAG on the object identified by TYPE and NAME. To set a -flag, the current user must be authorized by the ADMIN ACL or the flags ACL -on the object. +flag, the current user must be authorized by the ADMIN ACL or the flags +ACL on the object. =item get(TYPE, NAME) Returns the data associated with the object identified by TYPE and NAME. -Depending on the object TYPE, this may generate new data and invalidate any -existing data or it may return data previously stored or generated. Note -that this data may be binary and may contain nul characters. To get an -object, the current user must either be authorized by the owner ACL or +Depending on the object TYPE, this may generate new data and invalidate +any existing data or it may return data previously stored or generated. +Note that this data may be binary and may contain nul characters. To get +an object, the current user must either be authorized by the owner ACL or authorized by the get ACL; however, if the get ACL is set, the owner ACL will not be checked. Being a member of the ADMIN ACL does not provide any special privileges to get objects. @@ -950,48 +956,49 @@ between undef and the empty string, which is valid object data. =item history(TYPE, NAME) -Returns (as a string) the human-readable history of the object identified by -TYPE and NAME, or undef on error. To see the object history, the current -user must be a member of the ADMIN ACL, authorized by the show ACL, or -authorized by the owner ACL; however, if the show ACL is set, the owner ACL -will not be checked. +Returns (as a string) the human-readable history of the object identified +by TYPE and NAME, or undef on error. To see the object history, the +current user must be a member of the ADMIN ACL, authorized by the show +ACL, or authorized by the owner ACL; however, if the show ACL is set, the +owner ACL will not be checked. =item owner(TYPE, NAME [, OWNER]) -Gets or sets the owner for the object identified by TYPE and NAME. If OWNER -is not given, returns the current owner as a numeric ACL ID or undef if no -owner is set or on an error. To distinguish between an owner that isn't set -and a failure to retrieve the owner, the caller should call error() after an -undef return. If error() also returns undef, that ACL wasn't set; -otherwise, error() will return the error message. +Gets or sets the owner for the object identified by TYPE and NAME. If +OWNER is not given, returns the current owner as a numeric ACL ID or undef +if no owner is set or on an error. To distinguish between an owner that +isn't set and a failure to retrieve the owner, the caller should call +error() after an undef return. If error() also returns undef, that ACL +wasn't set; otherwise, error() will return the error message. -If OWNER is given, sets the owner to OWNER, which may be either the name of -an ACL or a numeric ACL ID. To set an owner, the current user must be +If OWNER is given, sets the owner to OWNER, which may be either the name +of an ACL or a numeric ACL ID. To set an owner, the current user must be authorized by the ADMIN ACL. Returns true for success and false for failure. -The owner of an object is permitted to get, store, and show that object, but -cannot destroy or set flags on that object without being listed on those -ACLs as well. +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 show(TYPE, NAME) -Returns (as a string) a human-readable representation of the metadata stored -for the object identified by TYPE and NAME, or undef on error. Included is -the metadata and entries of any ACLs associated with the object. To show an -object, the current user must be a member of the ADMIN ACL, authorized by -the show ACL, or authorized by the owner ACL; however, if the show ACL is -set, the owner ACL will not be checked. +Returns (as a string) a human-readable representation of the metadata +stored for the object identified by TYPE and NAME, or undef on error. +Included is the metadata and entries of any ACLs associated with the +object. To show an object, the current user must be a member of the ADMIN +ACL, authorized by the show ACL, or authorized by the owner ACL; however, +if the show ACL is set, the owner ACL will not be checked. =item store(TYPE, NAME, DATA) -Stores DATA for the object identified with TYPE and NAME for later retrieval -with get. Not all object types support this. Note that DATA may be binary -and may contain nul characters. To store an object, the current user must -either be authorized by the owner ACL or authorized by the store ACL; -however, if the store ACL is set, the owner ACL is not checked. Being a -member of the ADMIN ACL does not provide any special privileges to store -objects. Returns true on success and false on failure. +Stores DATA for the object identified with TYPE and NAME for later +retrieval with get. Not all object types support this. Note that DATA +may be binary and may contain nul characters. To store an object, the +current user must either be authorized by the owner ACL or authorized by +the store ACL; however, if the store ACL is set, the owner ACL is not +checked. Being a member of the ADMIN ACL does not provide any special +privileges to store objects. Returns true on success and false on +failure. =back @@ -999,8 +1006,8 @@ objects. Returns true on success and false on failure. wallet-backend(8) -This module is part of the wallet system. The current version is available -from L. +This module is part of the wallet system. The current version is +available from L. =head1 AUTHOR diff --git a/perl/t/pod-spelling.t b/perl/t/pod-spelling.t new file mode 100755 index 0000000..d3ab858 --- /dev/null +++ b/perl/t/pod-spelling.t @@ -0,0 +1,75 @@ +#!/usr/bin/perl -w +# +# Check for spelling errors in POD documentation +# +# Checks all POD files in the tree for spelling problems using Pod::Spell and +# either aspell or ispell. aspell is preferred. This test is disabled unless +# RRA_MAINTAINER_TESTS is set, since spelling dictionaries vary too much +# between environments. +# +# Copyright 2008, 2009 Russ Allbery +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. + +use strict; +use Test::More; + +# Skip all spelling tests unless the maintainer environment variable is set. +plan skip_all => 'Spelling tests only run for maintainer' + unless $ENV{RRA_MAINTAINER_TESTS}; + +# Load required Perl modules. +eval 'use Test::Pod 1.00'; +plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; +eval 'use Pod::Spell'; +plan skip_all => 'Pod::Spell required to test POD spelling' if $@; + +# Locate a spell-checker. hunspell is not currently supported due to its lack +# of support for contractions (at least in the version in Debian). +my @spell; +my %options = (aspell => [ qw(-d en_US --home-dir=./ list) ], + ispell => [ qw(-d american -l -p /dev/null) ]); +SEARCH: for my $program (qw/aspell ispell/) { + for my $dir (split ':', $ENV{PATH}) { + if (-x "$dir/$program") { + @spell = ("$dir/$program", @{ $options{$program} }); + } + last SEARCH if @spell; + } +} +plan skip_all => 'aspell or ispell required to test POD spelling' + unless @spell; + +# Prerequisites are satisfied, so we're going to do some testing. Figure out +# what POD files we have and from that develop our plan. +$| = 1; +my @pod = all_pod_files (); +plan tests => scalar @pod; + +# Finally, do the checks. +for my $pod (@pod) { + my $child = open (CHILD, '-|'); + if (not defined $child) { + die "Cannot fork: $!\n"; + } elsif ($child == 0) { + my $pid = open (SPELL, '|-', @spell) or die "Cannot run @spell: $!\n"; + open (POD, '<', $pod) or die "Cannot open $pod: $!\n"; + my $parser = Pod::Spell->new; + $parser->parse_from_filehandle (\*POD, \*SPELL); + close POD; + close SPELL; + exit ($? >> 8); + } else { + my @words = ; + close CHILD; + SKIP: { + skip "@spell failed for $pod", 1 unless $? == 0; + for (@words) { + s/^\s+//; + s/\s+$//; + } + is ("@words", '', $pod); + } + } +} diff --git a/perl/t/pod.t b/perl/t/pod.t index e9aa0a8..c467b82 100755 --- a/perl/t/pod.t +++ b/perl/t/pod.t @@ -1,16 +1,14 @@ -#!/usr/bin/perl +#!/usr/bin/perl -w # -# t/pod.t -- Test POD formatting for the wallet Perl modules. +# Test POD formatting for the wallet Perl modules. # # Written by Russ Allbery -# Copyright 2007 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. +use strict; +use Test::More; eval 'use Test::Pod 1.00'; -if ($@) { - print "1..1\n"; - print "ok 1 # skip - Test::Pod 1.00 required for testing POD\n"; - exit; -} +plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; all_pod_files_ok (); -- cgit v1.2.3 From ae9db60c9b9601f66b34b564b80bbcfbe41301e1 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Thu, 18 Feb 2010 16:12:10 -0800 Subject: Add a more complete test suite for Wallet::Kadmin --- perl/t/kadmin.t | 93 +++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 67 insertions(+), 26 deletions(-) (limited to 'perl/t') diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index 18d452e..82e6edf 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -3,12 +3,12 @@ # t/kadmin.t -- Tests for the kadmin object implementation. # # Written by Jon Robertson -# Copyright 2009 Board of Trustees, Leland Stanford Jr. University +# Copyright 2009, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 17; +use Test::More tests => 33; use Wallet::Admin; use Wallet::Config; @@ -19,7 +19,6 @@ use Wallet::Kadmin::MIT; my $heimdal_kadm5 = 0; eval 'use Heimdal::Kadm5'; if (!$@) { - print "No error...\n"; $heimdal_kadm5 = 1; require Wallet::Kadmin::Heimdal; } @@ -27,43 +26,85 @@ if (!$@) { use lib 't/lib'; use Util; -# We test a Wallet::Kadmin::* module's actual workings in the keytab.t tests. -# The only things we want to test here are that each module is found, that -# Wallet::Kadmin itself delegates to them, and that the private MIT principal -# validation works as it should. -for my $bad (qw{service\* = host/foo+bar host/foo/bar /bar bar/ - rcmd.foo}) { - ok (! Wallet::Kadmin::MIT->valid_principal ($bad), - "Invalid principal name $bad"); -} -for my $good (qw{service service/foo bar foo/bar host/example.org - aservice/foo}) { - ok (Wallet::Kadmin::MIT->valid_principal ($good), - "Valid principal name $good"); -} - # Test creating an MIT object and seeing if the callback works. $Wallet::Config::KEYTAB_KRBTYPE = 'MIT'; my $kadmin = Wallet::Kadmin->new; ok (defined ($kadmin), 'MIT kadmin object created'); my $callback = sub { return 1 }; $kadmin->fork_callback ($callback); -is ($kadmin->{fork_callback} (), 1, ' and callback works.'); +is ($kadmin->{fork_callback} (), 1, ' and callback works'); $callback = sub { return 2 }; $kadmin->fork_callback ($callback); -is ($kadmin->{fork_callback} (), 2, ' and changing it works.'); +is ($kadmin->{fork_callback} (), 2, ' and changing it works'); + +# Check principal validation in the Wallet::Kadmin::MIT module. This is +# specific to that module, since Heimdal doesn't require passing the principal +# through the kadmin client. +for my $bad (qw{service\* = host/foo+bar host/foo/bar /bar bar/ rcmd.foo}) { + ok (! Wallet::Kadmin::MIT->valid_principal ($bad), + "Invalid principal name $bad"); +} +for my $good (qw{service service/foo bar foo/bar host/example.org + aservice/foo}) { + ok (Wallet::Kadmin::MIT->valid_principal ($good), + "Valid principal name $good"); +} -# Test creating a Heimdal object. For us to test a working Heimdal object, -# we need a properly configured Heimdal KDC. So instead, we deliberately -# connect without configuration to get the error. That at least tests that -# we can find the Heimdal module and it dies how it should. +# Test creating a Heimdal object. We deliberately connect without +# configuration to get the error. That tests that we can find the Heimdal +# module and it dies how it should. SKIP: { - skip 'Heimdal::Kadm5 not installed', 1 unless $heimdal_kadm5; + skip 'Heimdal::Kadm5 not installed', 3 unless $heimdal_kadm5; undef $Wallet::Config::KEYTAB_PRINCIPAL; undef $Wallet::Config::KEYTAB_FILE; undef $Wallet::Config::KEYTAB_REALM; undef $kadmin; $Wallet::Config::KEYTAB_KRBTYPE = 'Heimdal'; $kadmin = eval { Wallet::Kadmin->new }; - is ($kadmin, undef, 'Heimdal fails properly.'); + is ($kadmin, undef, 'Heimdal fails properly'); + is ($@, "keytab object implementation not configured\n", + ' with the right error'); +} + +# Now, check the generic API. We can run this test no matter which +# implementation is configured. This retests some things that are also tested +# by the keytab test, but specifically through the Wallet::Kadmin API. +SKIP: { + skip 'no keytab configuration', 15 unless -f 't/data/test.keytab'; + + # Set up our configuration. + $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; + $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); + $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); + $Wallet::Config::KEYTAB_TMP = '.'; + + # Create the object and clean up the principal we're going to use. + $kadmin = eval { Wallet::Kadmin->new }; + ok (defined $kadmin, 'Creating Wallet::Kadmin object succeeds'); + is ($@, '', ' and there is no error'); + is ($kadmin->delprinc ('wallet/one'), 1, 'Deleting wallet/one works'); + is ($kadmin->exists ('wallet/one'), 0, ' and it does not exist'); + + # Create the principal and check that ktadd returns something. We'll + # check the details of the return in the keytab check. + is ($kadmin->addprinc ('wallet/one'), 1, 'Creating wallet/one works'); + is ($kadmin->exists ('wallet/one'), 1, ' and it now exists'); + unlink ('./tmp.keytab'); + is ($kadmin->ktadd ('wallet/one', './tmp.keytab'), 1, + ' and retrieving a keytab works'); + ok (-s './tmp.keytab', ' and the resulting keytab is non-zero'); + is (getcreds ('./tmp.keytab', "wallet/one\@$Wallet::Config::KEYTAB_REALM"), + 1, ' and works for authentication'); + unlink ('./tmp.keytab'); + + # Delete the principal and confirm behavior. + is ($kadmin->delprinc ('wallet/one'), 1, 'Deleting principal works'); + is ($kadmin->exists ('wallet/one'), 0, ' and now it does not exist'); + is ($kadmin->ktadd ('wallet/one', './tmp.keytab'), undef, + ' and retrieving the keytab does not work'); + ok (! -f './tmp.keytab', ' and no file was created'); + like ($kadmin->error, qr%^error creating keytab for wallet/one%, + ' and the right error message is set'); + is ($kadmin->delprinc ('wallet/one'), 1, ' and deleting it again works'); } -- cgit v1.2.3 From 2651ef4352c8cc782c4e0f3175257f7bb0c1e495 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Thu, 18 Feb 2010 18:03:09 -0800 Subject: Rename functions in Wallet::Kadmin API Now that we support multiple versions of Kerberos, use generic names for the functions in the Wallet::Kadmin interface rather than the commands from the MIT kadmin interface. --- TODO | 4 ---- perl/Wallet/Kadmin.pm | 14 +++++++------- perl/Wallet/Kadmin/Heimdal.pm | 12 ++++++------ perl/Wallet/Kadmin/MIT.pm | 12 ++++++------ perl/Wallet/Object/Keytab.pm | 17 ++++++----------- perl/t/kadmin.t | 14 +++++++------- perl/t/keytab.t | 4 ++-- 7 files changed, 34 insertions(+), 43 deletions(-) (limited to 'perl/t') diff --git a/TODO b/TODO index bfc7910..4ad1b1e 100644 --- a/TODO +++ b/TODO @@ -2,12 +2,8 @@ Release 0.10: -* Remove stub fork hook from Wallet::Kadmin::MIT. - * Handle unchanging support for Heimdal. -* Fix the Wallet::Kadmin API to use more generic function names. - * Move reporting code from Wallet::Admin to Wallet::Report. * Refactor attribute handling code in Wallet::Object::Keytab, move to diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm index a06e1e2..21678ca 100644 --- a/perl/Wallet/Kadmin.pm +++ b/perl/Wallet/Kadmin.pm @@ -73,7 +73,7 @@ __END__ ############################################################################## =for stopwords -backend Kadmin keytabs keytab Heimdal API kadmind kadmin KDC ENCTYPES +backend Kadmin keytabs keytab Heimdal API kadmind kadmin KDC ENCTYPE enctypes enctype Allbery =head1 NAME @@ -83,10 +83,10 @@ Wallet::Kadmin - Kerberos administration API for wallet keytab backend =head1 SYNOPSIS my $kadmin = Wallet::Kadmin->new; - $kadmin->addprinc ("host/shell.example.com"); - $kadmin->ktadd ("host/shell.example.com", "aes256-cts-hmac-sha1-96"); + $kadmin->create ("host/foo.example.com"); + $kadmin->keytab ("host/foo.example.com", "aes256-cts-hmac-sha1-96"); my $exists = $kadmin->exists ("host/oldshell.example.com"); - $kadmin->delprinc ("host/oldshell.example.com") if $exists; + $kadmin->destroy ("host/oldshell.example.com") if $exists; =head1 DESCRIPTION @@ -123,14 +123,14 @@ appropriate for the configured Kerberos implementation. =over 4 -=item addprinc(PRINCIPAL) +=item create(PRINCIPAL) Adds a new principal with a given name. The principal is created with a random password, and any other flags set by Wallet::Config. Returns true on success and false on failure. If the principal already exists, return true as we are bringing our expectations in line with reality. -=item delprinc(PRINCIPAL) +=item destroy(PRINCIPAL) Removes a principal with the given name. Returns true on success or false on failure. If the principal does not exist, return true as we are @@ -162,7 +162,7 @@ kadmin command-line client, the sub CALLBACK will be called in the child process before running the program. This can be used to, for example, properly clean up shared database handles. -=item ktadd(PRINCIPAL, FILE, ENCTYPES) +=item keytab(PRINCIPAL, FILE [, ENCTYPE ... ]) A keytab is an on-disk store for the key or keys for a Kerberos principal. Keytabs are used by services to verify incoming authentication from diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm index d59b33c..0ac8cd9 100644 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ b/perl/Wallet/Kadmin/Heimdal.pm @@ -59,7 +59,7 @@ sub exists { # Create a principal in Kerberos. If there is an error, return undef and set # the error. Return 1 on success or the principal already existing. -sub addprinc { +sub create { my ($self, $principal) = @_; $principal = $self->canonicalize_principal ($principal); my $exists = eval { $self->exists ($principal) }; @@ -97,7 +97,7 @@ sub addprinc { # optionally a list of encryption types to which to limit the keytab. Return # true if successful, false otherwise. If the keytab creation fails, sets the # error. -sub ktadd { +sub keytab { my ($self, $principal, $file, @enctypes) = @_; $principal = $self->canonicalize_principal ($principal); @@ -155,7 +155,7 @@ sub ktadd { # Delete a principal from Kerberos. Return true if successful, false # otherwise. If the deletion fails, sets the error. If the principal doesn't # exist, return success; we're bringing reality in line with our expectations. -sub delprinc { +sub destroy { my ($self, $principal) = @_; $principal = $self->canonicalize_principal ($principal); my $exists = eval { $self->exists ($principal) }; @@ -213,10 +213,10 @@ Wallet::Kadmin::Heimdal - Wallet Kerberos administration API for Heimdal =head1 SYNOPSIS my $kadmin = Wallet::Kadmin::Heimdal->new; - $kadmin->addprinc ("host/shell.example.com"); - $kadmin->ktadd ("host/shell.example.com", "aes256-cts-hmac-sha1-96"); + $kadmin->create ("host/foo.example.com"); + $kadmin->keytab ("host/foo.example.com", "aes256-cts-hmac-sha1-96"); my $exists = $kadmin->exists ("host/oldshell.example.com"); - $kadmin->delprinc ("host/oldshell.example.com") if $exists; + $kadmin->destroy ("host/oldshell.example.com") if $exists; =head1 DESCRIPTION diff --git a/perl/Wallet/Kadmin/MIT.pm b/perl/Wallet/Kadmin/MIT.pm index 1ab8b1d..9ab575c 100644 --- a/perl/Wallet/Kadmin/MIT.pm +++ b/perl/Wallet/Kadmin/MIT.pm @@ -116,7 +116,7 @@ sub exists { # Create a principal in Kerberos. Sets the error and returns undef on failure, # and returns 1 on either success or the principal already existing. -sub addprinc { +sub create { my ($self, $principal) = @_; unless ($self->valid_principal ($principal)) { $self->error ("invalid principal name $principal"); @@ -141,7 +141,7 @@ sub addprinc { # optionally a list of encryption types to which to limit the keytab. Return # true if successful, false otherwise. If the keytab creation fails, sets the # error. -sub ktadd { +sub keytab { my ($self, $principal, $file, @enctypes) = @_; unless ($self->valid_principal ($principal)) { $self->error ("invalid principal name: $principal"); @@ -168,7 +168,7 @@ sub ktadd { # Delete a principal from Kerberos. Return true if successful, false # otherwise. If the deletion fails, sets the error. If the principal doesn't # exist, return success; we're bringing reality in line with our expectations. -sub delprinc { +sub destroy { my ($self, $principal) = @_; unless ($self->valid_principal ($principal)) { $self->error ("invalid principal name: $principal"); @@ -219,10 +219,10 @@ Wallet::Kadmin::MIT - Wallet Kerberos administration API for MIT =head1 SYNOPSIS my $kadmin = Wallet::Kadmin::MIT->new; - $kadmin->addprinc ("host/shell.example.com"); - $kadmin->ktadd ("host/shell.example.com", "aes256-cts-hmac-sha1-96"); + $kadmin->create ("host/foo.example.com"); + $kadmin->keytab ("host/foo.example.com", "aes256-cts-hmac-sha1-96"); my $exists = $kadmin->exists ("host/oldshell.example.com"); - $kadmin->delprinc ("host/oldshell.example.com") if $exists; + $kadmin->destroy ("host/oldshell.example.com") if $exists; =head1 DESCRIPTION diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index 760280f..66c5e6a 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -289,7 +289,7 @@ sub create { my $callback = sub { $self->{dbh}->{InactiveDestroy} = 1 }; $kadmin->fork_callback ($callback); - if (not $kadmin->addprinc ($name)) { + if (not $kadmin->create ($name)) { die $kadmin->error, "\n"; } $self = $class->SUPER::create ($type, $name, $dbh, $creator, $host, $time); @@ -318,7 +318,7 @@ sub destroy { return; } my $kadmin = $self->{kadmin}; - if (not $kadmin->delprinc ($self->{name})) { + if (not $kadmin->destroy ($self->{name})) { $self->error ($kadmin->error); return; } @@ -350,7 +350,7 @@ sub get { unlink $file; my @enctypes = $self->attr ('enctypes'); my $kadmin = $self->{kadmin}; - if (not $kadmin->ktadd ($self->{name}, $file, @enctypes)) { + if (not $kadmin->keytab ($self->{name}, $file, @enctypes)) { $self->error ($kadmin->error); return; } @@ -520,19 +520,14 @@ used. =item KEYTAB_TMP/keytab. -The keytab is created in this file using C and then read into -memory. KEYTAB_TMP is set in the wallet configuration, and is the -process ID of the current process. The file is unlinked after being read. +The keytab is created in this file and then read into memory. KEYTAB_TMP +is set in the wallet configuration, and is the process ID of the +current process. The file is unlinked after being read. =back =head1 LIMITATIONS -Currently, when used with MIT Kerberos, this implementation calls an -external B program rather than using a native Perl module and -therefore requires B be installed and parses its output. It may -miss some error conditions if the output of B ever changes. - Only one Kerberos realm is supported for a given wallet implementation and all keytab objects stored must be in that realm. Keytab names in the wallet database do not have realm information. diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index 82e6edf..9c49995 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -83,15 +83,15 @@ SKIP: { $kadmin = eval { Wallet::Kadmin->new }; ok (defined $kadmin, 'Creating Wallet::Kadmin object succeeds'); is ($@, '', ' and there is no error'); - is ($kadmin->delprinc ('wallet/one'), 1, 'Deleting wallet/one works'); + is ($kadmin->destroy ('wallet/one'), 1, 'Deleting wallet/one works'); is ($kadmin->exists ('wallet/one'), 0, ' and it does not exist'); - # Create the principal and check that ktadd returns something. We'll + # Create the principal and check that keytab returns something. We'll # check the details of the return in the keytab check. - is ($kadmin->addprinc ('wallet/one'), 1, 'Creating wallet/one works'); + is ($kadmin->create ('wallet/one'), 1, 'Creating wallet/one works'); is ($kadmin->exists ('wallet/one'), 1, ' and it now exists'); unlink ('./tmp.keytab'); - is ($kadmin->ktadd ('wallet/one', './tmp.keytab'), 1, + is ($kadmin->keytab ('wallet/one', './tmp.keytab'), 1, ' and retrieving a keytab works'); ok (-s './tmp.keytab', ' and the resulting keytab is non-zero'); is (getcreds ('./tmp.keytab', "wallet/one\@$Wallet::Config::KEYTAB_REALM"), @@ -99,12 +99,12 @@ SKIP: { unlink ('./tmp.keytab'); # Delete the principal and confirm behavior. - is ($kadmin->delprinc ('wallet/one'), 1, 'Deleting principal works'); + is ($kadmin->destroy ('wallet/one'), 1, 'Deleting principal works'); is ($kadmin->exists ('wallet/one'), 0, ' and now it does not exist'); - is ($kadmin->ktadd ('wallet/one', './tmp.keytab'), undef, + is ($kadmin->keytab ('wallet/one', './tmp.keytab'), undef, ' and retrieving the keytab does not work'); ok (! -f './tmp.keytab', ' and no file was created'); like ($kadmin->error, qr%^error creating keytab for wallet/one%, ' and the right error message is set'); - is ($kadmin->delprinc ('wallet/one'), 1, ' and deleting it again works'); + is ($kadmin->destroy ('wallet/one'), 1, ' and deleting it again works'); } diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 39be547..a14b63e 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -59,7 +59,7 @@ sub system_quiet { sub create { my ($principal) = @_; my $kadmin = Wallet::Kadmin->new; - return $kadmin->addprinc ($principal); + return $kadmin->create ($principal); } # Destroy a principal out of Kerberos. Only usable once the configuration has @@ -67,7 +67,7 @@ sub create { sub destroy { my ($principal) = @_; my $kadmin = Wallet::Kadmin->new; - return $kadmin->delprinc ($principal); + return $kadmin->destroy ($principal); } # Check whether a principal exists. MIT uses kvno and Heimdal uses kgetcred. -- cgit v1.2.3 From a24d3ac3c7e8cb68fe2268f337a4edb599d5f881 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Thu, 18 Feb 2010 21:31:10 -0800 Subject: Support unchanging keytabs with Heimdal without remctl Heimdal supports retrieving a keytab containing the existing keys over the kadmin protocol. Move the support for using remctl to retrieve an existing keytab into Wallet::Kadmin::MIT and provide two separate methods in the Wallet::Kadmin interface: one which rekeys and one which doesn't. Implement the non-rekeying interface for Heimdal. Expand the test suite for the unchanging keytabs to include tests for the Heimdal method. --- TODO | 2 - perl/Wallet/Config.pm | 21 +++++-- perl/Wallet/Kadmin.pm | 43 ++++++++------ perl/Wallet/Kadmin/Heimdal.pm | 74 +++++++++++++++++++++--- perl/Wallet/Kadmin/MIT.pm | 68 +++++++++++++++++++--- perl/Wallet/Object/Keytab.pm | 49 +--------------- perl/t/kadmin.t | 4 +- perl/t/keytab.t | 127 ++++++++++++++++++++++++++++-------------- 8 files changed, 257 insertions(+), 131 deletions(-) (limited to 'perl/t') diff --git a/TODO b/TODO index 92bd025..662ea47 100644 --- a/TODO +++ b/TODO @@ -2,8 +2,6 @@ Release 0.10: -* Handle unchanging support for Heimdal. - * Move reporting code from Wallet::Admin to Wallet::Report. * Check whether we can just drop the realm restriction on keytabs and diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index c59d3e3..396bf7d 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -26,7 +26,8 @@ Wallet::Config - Configuration handling for the wallet server =for stopwords DBI DSN SQLite subdirectories KEYTAB keytab kadmind KDC add-ons kadmin DNS SRV kadmin keytabs remctl backend lowercased NETDB ACL NetDB unscoped -usernames rekey hostnames Allbery wallet-backend keytab-backend +usernames rekey hostnames Allbery wallet-backend keytab-backend Heimdal +rekeys =head1 SYNOPSIS @@ -313,11 +314,19 @@ our $KEYTAB_TMP; =head2 Retrieving Existing Keytabs -The keytab object backend optionally supports retrieving existing keys, -and hence keytabs, for Kerberos principals by contacting the KDC via -remctl and talking to B. This is enabled by setting the -C flag on keytab objects. To configure that support, set the -following variables. +Heimdal provides the choice, over the network protocol, of either +downloading the existing keys for a principal or generating new random +keys. MIT Kerberos does not; downloading a keytab over the kadmin +protocol always rekeys the principal. + +For MIT Kerberos, the keytab object backend therefore optionally supports +retrieving existing keys, and hence keytabs, for Kerberos principals by +contacting the KDC via remctl and talking to B. This is +enabled by setting the C flag on keytab objects. To configure +that support, set the following variables. + +This is not required for Heimdal; for Heimdal, setting the C +flag is all that's needed. =over 4 diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm index 3ca531e..f3c2895 100644 --- a/perl/Wallet/Kadmin.pm +++ b/perl/Wallet/Kadmin.pm @@ -83,10 +83,12 @@ Wallet::Kadmin - Kerberos administration API for wallet keytab backend =head1 SYNOPSIS my $kadmin = Wallet::Kadmin->new; - $kadmin->create ("host/foo.example.com"); - $kadmin->keytab ("host/foo.example.com", "aes256-cts-hmac-sha1-96"); - my $exists = $kadmin->exists ("host/oldshell.example.com"); - $kadmin->destroy ("host/oldshell.example.com") if $exists; + $kadmin->create ('host/foo.example.com'); + $kadmin->keytab_rekey ('host/foo.example.com', 'keytab', + 'aes256-cts-hmac-sha1-96'); + my $data = $kadmin->keytab ('host/foo.example.com'); + my $exists = $kadmin->exists ('host/oldshell.example.com'); + $kadmin->destroy ('host/oldshell.example.com') if $exists; =head1 DESCRIPTION @@ -162,19 +164,26 @@ kadmin command-line client, the sub CALLBACK will be called in the child process before running the program. This can be used to, for example, properly clean up shared database handles. -=item keytab(PRINCIPAL, FILE [, ENCTYPE ... ]) - -A keytab is an on-disk store for the key or keys for a Kerberos principal. -Keytabs are used by services to verify incoming authentication from -clients or by automated processes that need to authenticate to Kerberos. -To create a keytab, the principal has to be created in Kerberos and then a -keytab is generated and stored in a file on disk. - -ktadd() creates a new keytab for the given principal, storing it in the -given file and limited to the enctypes supplied. The enctype values must -be enctype strings recognized by the Kerberos implementation (strings like -C or C). Returns true on success -and false on failure. +=item keytab(PRINCIPAL) + +keytab() creates a keytab for the given principal, storing it in the given +file. A keytab is an on-disk store for the key or keys for a Kerberos +principal. Keytabs are used by services to verify incoming authentication +from clients or by automated processes that need to authenticate to +Kerberos. To create a keytab, the principal has to have previously been +created in the Kerberos KDC. Returns the keytab as binary data on success +and undef on failure. + +=item keytab_rekey(PRINCIPAL, FILE [, ENCTYPE ...]) + +Like keytab(), but randomizes the key for the principal before generating +the keytab and writes it to the given file. This will invalidate any +existing keytabs for that principal. This method can also limit the +encryption types of the keys for that principal via the optional ENCTYPE +arguments. The enctype values must be enctype strings recognized by the +Kerberos implementation (strings like C or +C). If none are given, the KDC defaults will be used. +Returns true on success and false on failure. =back diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm index 0ac8cd9..e066006 100644 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ b/perl/Wallet/Kadmin/Heimdal.pm @@ -39,6 +39,23 @@ sub canonicalize_principal { return $principal; } +# Read the entirety of a possibly binary file and return the contents. If +# reading the file fails, set the error message and return undef. +sub slurp_file { + my ($self, $file) = @_; + unless (open (TMPFILE, '<', $file)) { + $self->error ("cannot open temporary file $file: $!"); + return; + } + local $/; + my $data = ; + unless (close TMPFILE) { + $self->error ("cannot read temporary file $file: $!"); + return; + } + return $data; +} + ############################################################################## # Public interfaces ############################################################################## @@ -93,11 +110,38 @@ sub create { return 1; } -# Create a keytab from a principal. Takes the principal, the file, and -# optionally a list of encryption types to which to limit the keytab. Return -# true if successful, false otherwise. If the keytab creation fails, sets the -# error. +# Create a keytab for a principal. Returns the keytab as binary data or undef +# on failure, setting the error. sub keytab { + my ($self, $principal) = @_; + $principal = $self->canonicalize_principal ($principal); + my $kadmin = $self->{client}; + my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; + unlink $file; + my $princdata = eval { $kadmin->getPrincipal ($principal) }; + if ($@) { + $self->error ("error creating keytab for $principal: $@"); + return; + } elsif (!$princdata) { + $self->error ("error creating keytab for $principal: principal does" + . " not exist"); + return; + } + eval { $kadmin->extractKeytab ($princdata, $file) }; + if ($@) { + $self->error ("error creating keytab for principal: $@"); + return; + } + my $data = $self->slurp_file ($file); + unlink $file; + return $data; +} + +# Create a keytab for a principal, randomizing the keys for that principal at +# the same time. Takes the principal, the file, and optionally a list of +# encryption types to which to limit the keytab. Return true if successful, +# false otherwise. If the keytab creation fails, sets the error. +sub keytab_rekey { my ($self, $principal, $file, @enctypes) = @_; $principal = $self->canonicalize_principal ($principal); @@ -213,10 +257,12 @@ Wallet::Kadmin::Heimdal - Wallet Kerberos administration API for Heimdal =head1 SYNOPSIS my $kadmin = Wallet::Kadmin::Heimdal->new; - $kadmin->create ("host/foo.example.com"); - $kadmin->keytab ("host/foo.example.com", "aes256-cts-hmac-sha1-96"); - my $exists = $kadmin->exists ("host/oldshell.example.com"); - $kadmin->destroy ("host/oldshell.example.com") if $exists; + $kadmin->create ('host/foo.example.com'); + $kadmin->keytab_rekey ('host/foo.example.com', 'keytab', + 'aes256-cts-hmac-sha1-96'); + my $data = $kadmin->keytab ('host/foo.example.com'); + my $exists = $kadmin->exists ('host/oldshell.example.com'); + $kadmin->destroy ('host/oldshell.example.com') if $exists; =head1 DESCRIPTION @@ -228,6 +274,18 @@ To use this object, several configuration parameters must be set. See Wallet::Config(3) for details on those configuration parameters and information about how to set wallet configuration. +=head1 FILES + +=over 4 + +=item KEYTAB_TMP/keytab. + +The keytab is created in this file and then read into memory. KEYTAB_TMP +is set in the wallet configuration, and is the process ID of the +current process. The file is unlinked after being read. + +=back + =head1 SEE ALSO kadmin(8), Wallet::Config(3), Wallet::Kadmin(3), diff --git a/perl/Wallet/Kadmin/MIT.pm b/perl/Wallet/Kadmin/MIT.pm index 9ab575c..1c6d2c1 100644 --- a/perl/Wallet/Kadmin/MIT.pm +++ b/perl/Wallet/Kadmin/MIT.pm @@ -137,11 +137,52 @@ sub create { return 1; } -# Create a keytab from a principal. Takes the principal, the file, and -# optionally a list of encryption types to which to limit the keytab. Return -# true if successful, false otherwise. If the keytab creation fails, sets the -# error. +# Retrieve an existing keytab from the KDC via a remctl call. The KDC needs +# to be running the keytab-backend script and support the keytab retrieve +# remctl command. In addition, the user must have configured us with the path +# to a ticket cache and the host to which to connect with remctl. Returns the +# keytab on success and undef on failure. sub keytab { + my ($self, $principal) = @_; + my $host = $Wallet::Config::KEYTAB_REMCTL_HOST; + unless ($host and $Wallet::Config::KEYTAB_REMCTL_CACHE) { + $self->error ('keytab unchanging support not configured'); + return; + } + eval { require Net::Remctl }; + if ($@) { + $self->error ("keytab unchanging support not available: $@"); + return; + } + if ($principal !~ /\@/ && $Wallet::Config::KEYTAB_REALM) { + $principal .= '@' . $Wallet::Config::KEYTAB_REALM; + } + local $ENV{KRB5CCNAME} = $Wallet::Config::KEYTAB_REMCTL_CACHE; + my $port = $Wallet::Config::KEYTAB_REMCTL_PORT || 0; + my $remctl_princ = $Wallet::Config::KEYTAB_REMCTL_PRINCIPAL || ''; + my @command = ('keytab', 'retrieve', $principal); + my $result = Net::Remctl::remctl ($host, $port, $remctl_princ, @command); + if ($result->error) { + $self->error ("cannot retrieve keytab for $principal: ", + $result->error); + return; + } elsif ($result->status != 0) { + my $error = $result->stderr; + $error =~ s/\s+$//; + $error =~ s/\n/ /g; + $self->error ("cannot retrieve keytab for $principal: $error"); + return; + } else { + return $result->stdout; + } +} + +# Create a keytab for a principal, randomizing the keys for that principal +# in the process. Takes the principal, the file, and optionally a list of +# encryption types to which to limit the keytab. Return true if +# successful, false otherwise. If the keytab creation fails, sets the +# error. +sub keytab_rekey { my ($self, $principal, $file, @enctypes) = @_; unless ($self->valid_principal ($principal)) { $self->error ("invalid principal name: $principal"); @@ -210,7 +251,7 @@ __END__ ############################################################################## =for stopwords -keytabs keytab kadmin KDC API Allbery +rekeying rekeys remctl backend keytabs keytab kadmin KDC API Allbery =head1 NAME @@ -219,10 +260,12 @@ Wallet::Kadmin::MIT - Wallet Kerberos administration API for MIT =head1 SYNOPSIS my $kadmin = Wallet::Kadmin::MIT->new; - $kadmin->create ("host/foo.example.com"); - $kadmin->keytab ("host/foo.example.com", "aes256-cts-hmac-sha1-96"); - my $exists = $kadmin->exists ("host/oldshell.example.com"); - $kadmin->destroy ("host/oldshell.example.com") if $exists; + $kadmin->create ('host/foo.example.com'); + $kadmin->keytab_rekey ('host/foo.example.com', 'keytab', + 'aes256-cts-hmac-sha1-96'); + my $data = $kadmin->keytab ('host/foo.example.com'); + my $exists = $kadmin->exists ('host/oldshell.example.com'); + $kadmin->destroy ('host/oldshell.example.com') if $exists; =head1 DESCRIPTION @@ -231,6 +274,13 @@ providing an interface to create and delete principals and create keytabs. It provides the API documented in Wallet::Kadmin(3) for an MIT Kerberos KDC. +MIT Kerberos does not provide any method via the kadmin network protocol +to retrieve a keytab for a principal without rekeying it, so the keytab() +method (as opposed to keytab_rekey(), which rekeys the principal) is +implemented using a remctl backend. For that method (used for unchanging +keytab objects) to work, the necessary wallet configuration and remctl +interface on the KDC must be set up. + To use this object, several configuration parameters must be set. See Wallet::Config(3) for details on those configuration parameters and information about how to set wallet configuration. diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index 44ee003..5c66967 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -179,49 +179,6 @@ sub sync_list { return @targets; } -############################################################################## -# Keytab retrieval -############################################################################## - -# Retrieve an existing keytab from the KDC via a remctl call. The KDC needs -# to be running the keytab-backend script and support the keytab retrieve -# remctl command. In addition, the user must have configured us with the path -# to a ticket cache and the host to which to connect with remctl. Returns the -# keytab on success and undef on failure. -sub keytab_retrieve { - my ($self, $keytab) = @_; - my $host = $Wallet::Config::KEYTAB_REMCTL_HOST; - unless ($host and $Wallet::Config::KEYTAB_REMCTL_CACHE) { - $self->error ('keytab unchanging support not configured'); - return; - } - eval { require Net::Remctl }; - if ($@) { - $self->error ("keytab unchanging support not available: $@"); - return; - } - if ($Wallet::Config::KEYTAB_REALM) { - $keytab .= '@' . $Wallet::Config::KEYTAB_REALM; - } - local $ENV{KRB5CCNAME} = $Wallet::Config::KEYTAB_REMCTL_CACHE; - my $port = $Wallet::Config::KEYTAB_REMCTL_PORT || 0; - my $principal = $Wallet::Config::KEYTAB_REMCTL_PRINCIPAL || ''; - my @command = ('keytab', 'retrieve', $keytab); - my $result = Net::Remctl::remctl ($host, $port, $principal, @command); - if ($result->error) { - $self->error ("cannot retrieve keytab for $keytab: ", $result->error); - return; - } elsif ($result->status != 0) { - my $error = $result->stderr; - $error =~ s/\s+$//; - $error =~ s/\n/ /g; - $self->error ("cannot retrieve keytab for $keytab: $error"); - return; - } else { - return $result->stdout; - } -} - ############################################################################## # Core methods ############################################################################## @@ -365,8 +322,9 @@ sub get { $self->error ("cannot get $id: object is locked"); return; } + my $kadmin = $self->{kadmin}; if ($self->flag_check ('unchanging')) { - my $result = $self->keytab_retrieve ($self->{name}); + my $result = $kadmin->keytab ($self->{name}); if (defined $result) { $self->log_action ('get', $user, $host, $time); } @@ -379,8 +337,7 @@ sub get { my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; unlink $file; my @enctypes = $self->attr ('enctypes'); - my $kadmin = $self->{kadmin}; - if (not $kadmin->keytab ($self->{name}, $file, @enctypes)) { + if (not $kadmin->keytab_rekey ($self->{name}, $file, @enctypes)) { $self->error ($kadmin->error); return; } diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index 9c49995..a29cae3 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -91,7 +91,7 @@ SKIP: { is ($kadmin->create ('wallet/one'), 1, 'Creating wallet/one works'); is ($kadmin->exists ('wallet/one'), 1, ' and it now exists'); unlink ('./tmp.keytab'); - is ($kadmin->keytab ('wallet/one', './tmp.keytab'), 1, + is ($kadmin->keytab_rekey ('wallet/one', './tmp.keytab'), 1, ' and retrieving a keytab works'); ok (-s './tmp.keytab', ' and the resulting keytab is non-zero'); is (getcreds ('./tmp.keytab', "wallet/one\@$Wallet::Config::KEYTAB_REALM"), @@ -101,7 +101,7 @@ SKIP: { # Delete the principal and confirm behavior. is ($kadmin->destroy ('wallet/one'), 1, 'Deleting principal works'); is ($kadmin->exists ('wallet/one'), 0, ' and now it does not exist'); - is ($kadmin->keytab ('wallet/one', './tmp.keytab'), undef, + is ($kadmin->keytab_rekey ('wallet/one', './tmp.keytab'), undef, ' and retrieving the keytab does not work'); ok (! -f './tmp.keytab', ' and no file was created'); like ($kadmin->error, qr%^error creating keytab for wallet/one%, diff --git a/perl/t/keytab.t b/perl/t/keytab.t index a14b63e..a702c0f 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -9,7 +9,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 125; +use Test::More tests => 135; use Wallet::Admin; use Wallet::Config; @@ -378,12 +378,7 @@ EOO # Tests for unchanging support. Skip these if we don't have a keytab or if we # can't find remctld. SKIP: { - skip 'no keytab configuration', 17 unless -f 't/data/test.keytab'; - my @path = (split (':', $ENV{PATH}), '/usr/local/sbin', '/usr/sbin'); - my ($remctld) = grep { -x $_ } map { "$_/remctld" } @path; - skip 'remctld not found', 17 unless $remctld; - eval { require Net::Remctl }; - skip 'Net::Remctl not available', 17 if $@; + skip 'no keytab configuration', 27 unless -f 't/data/test.keytab'; # Set up our configuration. $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; @@ -406,41 +401,85 @@ SKIP: { ok (defined ($two), 'Creating wallet/two succeeds'); is ($two->flag_set ('unchanging', @trace), 1, ' and setting unchanging'); - # Now spawn our remctld server and get a ticket cache. - remctld_spawn ($remctld, $principal, 't/data/test.keytab', - 't/data/keytab.conf'); - $ENV{KRB5CCNAME} = 'krb5cc_test'; - getcreds ('t/data/test.keytab', $principal); - $ENV{KRB5CCNAME} = 'krb5cc_good'; + # Finally we can test. First the MIT Kerberos tests. + SKIP: { + skip 'skipping MIT unchanging tests for Heimdal', 12 + if (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'heimdal'); + + # We need remctld and Net::Remctl. + my @path = (split (':', $ENV{PATH}), '/usr/local/sbin', '/usr/sbin'); + my ($remctld) = grep { -x $_ } map { "$_/remctld" } @path; + skip 'remctld not found', 12 unless $remctld; + eval { require Net::Remctl }; + skip 'Net::Remctl not available', 12 if $@; + + # Now spawn our remctld server and get a ticket cache. + remctld_spawn ($remctld, $principal, 't/data/test.keytab', + 't/data/keytab.conf'); + $ENV{KRB5CCNAME} = 'krb5cc_test'; + getcreds ('t/data/test.keytab', $principal); + $ENV{KRB5CCNAME} = 'krb5cc_good'; + + # Do the unchanging tests for MIT Kerberos. + is ($one->get (@trace), undef, 'Get without configuration fails'); + is ($one->error, 'keytab unchanging support not configured', + ' with the right error'); + $Wallet::Config::KEYTAB_REMCTL_CACHE = 'krb5cc_test'; + is ($one->get (@trace), undef, ' and still fails without host'); + is ($one->error, 'keytab unchanging support not configured', + ' with the right error'); + $Wallet::Config::KEYTAB_REMCTL_HOST = 'localhost'; + $Wallet::Config::KEYTAB_REMCTL_PRINCIPAL = $principal; + $Wallet::Config::KEYTAB_REMCTL_PORT = 14373; + is ($one->get (@trace), undef, ' and still fails without ACL'); + is ($one->error, + "cannot retrieve keytab for wallet/one\@$realm: Access denied", + ' with the right error'); + open (ACL, '>', 'test-acl') or die "cannot create test-acl: $!\n"; + print ACL "$principal\n"; + close ACL; + is ($one->get (@trace), 'Keytab for wallet/one', 'Now get works'); + is ($ENV{KRB5CCNAME}, 'krb5cc_good', + ' and we did not nuke the cache name'); + is ($one->get (@trace), 'Keytab for wallet/one', + ' and we get the same thing the second time'); + is ($one->flag_clear ('unchanging', @trace), 1, + 'Clearing the unchanging flag works'); + my $data = $object->get (@trace); + ok (defined ($data), ' and getting the keytab works'); + ok (valid ($data, 'wallet/one'), ' and the keytab is valid'); + is ($two->get (@trace), undef, 'Get for wallet/two does not work'); + is ($two->error, + "cannot retrieve keytab for wallet/two\@$realm: bite me", + ' with the right error'); + is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); + is ($two->destroy (@trace), 1, ' as does destroying wallet/two'); + remctld_stop; + } - # Finally we can test. - is ($one->get (@trace), undef, 'Get without configuration fails'); - is ($one->error, 'keytab unchanging support not configured', - ' with the right error'); - $Wallet::Config::KEYTAB_REMCTL_CACHE = 'krb5cc_test'; - is ($one->get (@trace), undef, ' and still fails without host'); - is ($one->error, 'keytab unchanging support not configured', - ' with the right error'); - $Wallet::Config::KEYTAB_REMCTL_HOST = 'localhost'; - $Wallet::Config::KEYTAB_REMCTL_PRINCIPAL = $principal; - $Wallet::Config::KEYTAB_REMCTL_PORT = 14373; - is ($one->get (@trace), undef, ' and still fails without ACL'); - is ($one->error, - "cannot retrieve keytab for wallet/one\@$realm: Access denied", - ' with the right error'); - open (ACL, '>', 'test-acl') or die "cannot create test-acl: $!\n"; - print ACL "$principal\n"; - close ACL; - is ($one->get (@trace), 'Keytab for wallet/one', 'Now get works'); - is ($ENV{KRB5CCNAME}, 'krb5cc_good', - ' and we did not nuke the cache name'); - is ($two->get (@trace), undef, ' but get for wallet/two does not'); - is ($two->error, - "cannot retrieve keytab for wallet/two\@$realm: bite me", - ' with the right error'); - is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); - is ($two->destroy (@trace), 1, ' as does destroying wallet/two'); - remctld_stop; + # Now Heimdal. Since the keytab contains timestamps, before testing for + # equality we have to substitute out the timestamps. + SKIP: { + skip 'skipping Heimdal unchanging tests for MIT', 10 + if (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'mit'); + my $data = $one->get (@trace); + ok (defined $data, 'Get of unchanging keytab works'); + ok (valid ($data, 'wallet/one'), ' and the keytab is valid'); + my $second = $one->get (@trace); + ok (defined $second, ' and second retrieval also works'); + $data =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; + $second =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; + is ($data, $second, ' and the keytab matches'); + is ($one->flag_clear ('unchanging', @trace), 1, + 'Clearing the unchanging flag works'); + $data = $one->get (@trace); + ok (defined ($data), ' and getting the keytab works'); + ok (valid ($data, 'wallet/one'), ' and the keytab is valid'); + $data =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; + ok ($data ne $second, ' and the new keytab is different'); + is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); + is ($two->destroy (@trace), 1, ' as does destroying wallet/two'); + } # Check that history has been updated correctly. $history .= <<"EOO"; @@ -450,6 +489,12 @@ $date set flag unchanging by $user from $host $date get by $user from $host +$date get + by $user from $host +$date clear flag unchanging + by $user from $host +$date get + by $user from $host $date destroy by $user from $host EOO -- cgit v1.2.3 From 93eb5f8fe8d05398dd6fb364680e40eb8dae23e4 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Thu, 18 Feb 2010 22:06:17 -0800 Subject: Refactor Wallet::Kadmin keytab_rekey to return keytab Change the API for keytab_rekey to match keytab, returning the keytab as data instead of writing it to a file. This simplifies the wallet object implementation and moves the logic for reading the temporary file into Wallet::Kadmin and its child classes. (Eventually, there may be a kadmin backend that doesn't require using a temporary file.) Setting KEYTAB_TMP is now required to instantiate either the ::MIT or ::Heimdal Wallet::Kadmin classes. --- perl/Wallet/Kadmin.pm | 54 ++++++++++++++++++++++++++++++++++++------- perl/Wallet/Kadmin/Heimdal.pm | 41 +++++++++++--------------------- perl/Wallet/Kadmin/MIT.pm | 39 +++++++++++++++++++++---------- perl/Wallet/Object/Keytab.pm | 42 ++++++++------------------------- perl/t/kadmin.t | 15 ++++++------ perl/t/keytab.t | 42 +++++++++++++-------------------- perl/t/lib/Util.pm | 21 +++++++++++++++-- 7 files changed, 137 insertions(+), 117 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm index f3c2895..074dd1e 100644 --- a/perl/Wallet/Kadmin.pm +++ b/perl/Wallet/Kadmin.pm @@ -22,6 +22,33 @@ use Wallet::Config (); # that it will sort properly. $VERSION = '0.03'; +############################################################################## +# Utility functions for child classes +############################################################################## + +# Read the entirety of a possibly binary file and return the contents, +# deleting the file after reading it. If reading the file fails, set the +# error message and return undef. +sub read_keytab { + my ($self, $file) = @_; + local *TMPFILE; + unless (open (TMPFILE, '<', $file)) { + $self->error ("cannot open temporary file $file: $!"); + return; + } + local $/; + undef $!; + my $data = ; + if ($!) { + $self->error ("cannot read temporary file $file: $!"); + unlink $file; + return; + } + close TMPFILE; + unlink $file; + return $data; +} + ############################################################################## # Public methods ############################################################################## @@ -84,9 +111,9 @@ Wallet::Kadmin - Kerberos administration API for wallet keytab backend my $kadmin = Wallet::Kadmin->new; $kadmin->create ('host/foo.example.com'); - $kadmin->keytab_rekey ('host/foo.example.com', 'keytab', - 'aes256-cts-hmac-sha1-96'); - my $data = $kadmin->keytab ('host/foo.example.com'); + my $data = $kadmin->keytab_rekey ('host/foo.example.com', + 'aes256-cts-hmac-sha1-96'); + $data = $kadmin->keytab ('host/foo.example.com'); my $exists = $kadmin->exists ('host/oldshell.example.com'); $kadmin->destroy ('host/oldshell.example.com') if $exists; @@ -101,9 +128,8 @@ interact with that implementation's kadmin interface. The class uses Wallet::Config to find which type of kadmin interface is in use and then returns an object to use for interacting with that interface. -To use this object, several configuration parameters must be set. See -Wallet::Config(3) for details on those configuration parameters and -information about how to set wallet configuration. +See L for details on how to +configure this module. =head1 CLASS METHODS @@ -174,7 +200,7 @@ Kerberos. To create a keytab, the principal has to have previously been created in the Kerberos KDC. Returns the keytab as binary data on success and undef on failure. -=item keytab_rekey(PRINCIPAL, FILE [, ENCTYPE ...]) +=item keytab_rekey(PRINCIPAL [, ENCTYPE ...]) Like keytab(), but randomizes the key for the principal before generating the keytab and writes it to the given file. This will invalidate any @@ -183,7 +209,19 @@ encryption types of the keys for that principal via the optional ENCTYPE arguments. The enctype values must be enctype strings recognized by the Kerberos implementation (strings like C or C). If none are given, the KDC defaults will be used. -Returns true on success and false on failure. +Returns the keytab as binary data on success and undef on failure. + +=back + +The following methods are utility methods to aid with child class +implementation and should only be called by child classes. + +=over 4 + +=item read_keytab(FILE) + +Reads the contents of the keytab stored in FILE into memory and returns it +as binary data. On failure, returns undef and sets the object error. =back diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm index e066006..d1eecda 100644 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ b/perl/Wallet/Kadmin/Heimdal.pm @@ -39,23 +39,6 @@ sub canonicalize_principal { return $principal; } -# Read the entirety of a possibly binary file and return the contents. If -# reading the file fails, set the error message and return undef. -sub slurp_file { - my ($self, $file) = @_; - unless (open (TMPFILE, '<', $file)) { - $self->error ("cannot open temporary file $file: $!"); - return; - } - local $/; - my $data = ; - unless (close TMPFILE) { - $self->error ("cannot read temporary file $file: $!"); - return; - } - return $data; -} - ############################################################################## # Public interfaces ############################################################################## @@ -132,17 +115,15 @@ sub keytab { $self->error ("error creating keytab for principal: $@"); return; } - my $data = $self->slurp_file ($file); - unlink $file; - return $data; + return $self->read_keytab ($file); } # Create a keytab for a principal, randomizing the keys for that principal at -# the same time. Takes the principal, the file, and optionally a list of -# encryption types to which to limit the keytab. Return true if successful, -# false otherwise. If the keytab creation fails, sets the error. +# the same time. Takes the principal and an optional list of encryption types +# to which to limit the keytab. Return the keytab data on success and undef +# on failure. If the keytab creation fails, sets the error. sub keytab_rekey { - my ($self, $principal, $file, @enctypes) = @_; + my ($self, $principal, @enctypes) = @_; $principal = $self->canonicalize_principal ($principal); # The way Heimdal works, you can only remove enctypes from a principal, @@ -188,12 +169,14 @@ sub keytab_rekey { } # Create the keytab. + my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; + unlink $file; eval { $kadmin->extractKeytab ($princdata, $file) }; if ($@) { $self->error ("error creating keytab for principal: $@"); return; } - return 1; + return $self->read_keytab ($file); } # Delete a principal from Kerberos. Return true if successful, false @@ -227,6 +210,9 @@ sub new { and defined ($Wallet::Config::KEYTAB_REALM)) { die "keytab object implementation not configured\n"; } + unless (defined ($Wallet::Config::KEYTAB_TMP)) { + die "KEYTAB_TMP configuration variable not set\n"; + } my @options = (RaiseError => 1, Principal => $Wallet::Config::KEYTAB_PRINCIPAL, Realm => $Wallet::Config::KEYTAB_REALM, @@ -270,9 +256,8 @@ Wallet::Kadmin::Heimdal implements the Wallet::Kadmin API for Heimdal, providing an interface to create and delete principals and create keytabs. It provides the API documented in Wallet::Kadmin(3) for a Heimdal KDC. -To use this object, several configuration parameters must be set. See -Wallet::Config(3) for details on those configuration parameters and -information about how to set wallet configuration. +To use this class, several configuration parameters must be set. See +L for details. =head1 FILES diff --git a/perl/Wallet/Kadmin/MIT.pm b/perl/Wallet/Kadmin/MIT.pm index 1c6d2c1..434e93d 100644 --- a/perl/Wallet/Kadmin/MIT.pm +++ b/perl/Wallet/Kadmin/MIT.pm @@ -178,12 +178,11 @@ sub keytab { } # Create a keytab for a principal, randomizing the keys for that principal -# in the process. Takes the principal, the file, and optionally a list of -# encryption types to which to limit the keytab. Return true if -# successful, false otherwise. If the keytab creation fails, sets the -# error. +# in the process. Takes the principal and an optional list of encryption +# types to which to limit the keytab. Return the keytab data on success +# and undef otherwise. If the keytab creation fails, sets the error. sub keytab_rekey { - my ($self, $principal, $file, @enctypes) = @_; + my ($self, $principal, @enctypes) = @_; unless ($self->valid_principal ($principal)) { $self->error ("invalid principal name: $principal"); return; @@ -191,6 +190,8 @@ sub keytab_rekey { if ($Wallet::Config::KEYTAB_REALM) { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; } + my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; + unlink $file; my $command = "ktadd -q -k $file"; if (@enctypes) { @enctypes = map { /:/ ? $_ : "$_:normal" } @enctypes; @@ -203,7 +204,7 @@ sub keytab_rekey { $self->error ("error creating keytab for $principal: $1"); return; } - return 1; + return $self->read_keytab ($file); } # Delete a principal from Kerberos. Return true if successful, false @@ -238,6 +239,9 @@ sub destroy { # kadmin directly. sub new { my ($class) = @_; + unless (defined ($Wallet::Config::KEYTAB_TMP)) { + die "KEYTAB_TMP configuration variable not set\n"; + } my $self = {}; bless ($self, $class); return $self; @@ -261,9 +265,9 @@ Wallet::Kadmin::MIT - Wallet Kerberos administration API for MIT my $kadmin = Wallet::Kadmin::MIT->new; $kadmin->create ('host/foo.example.com'); - $kadmin->keytab_rekey ('host/foo.example.com', 'keytab', - 'aes256-cts-hmac-sha1-96'); - my $data = $kadmin->keytab ('host/foo.example.com'); + my $data = $kadmin->keytab_rekey ('host/foo.example.com', + 'aes256-cts-hmac-sha1-96'); + $data = $kadmin->keytab ('host/foo.example.com'); my $exists = $kadmin->exists ('host/oldshell.example.com'); $kadmin->destroy ('host/oldshell.example.com') if $exists; @@ -281,9 +285,20 @@ implemented using a remctl backend. For that method (used for unchanging keytab objects) to work, the necessary wallet configuration and remctl interface on the KDC must be set up. -To use this object, several configuration parameters must be set. See -Wallet::Config(3) for details on those configuration parameters and -information about how to set wallet configuration. +To use this class, several configuration parameters must be set. See +L for details. + +=head1 FILES + +=over 4 + +=item KEYTAB_TMP/keytab. + +The keytab is created in this file and then read into memory. KEYTAB_TMP +is set in the wallet configuration, and is the process ID of the +current process. The file is unlinked after being read. + +=back =head1 LIMITATIONS diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index 5c66967..edb26b3 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -323,43 +323,19 @@ sub get { return; } my $kadmin = $self->{kadmin}; + my $result; if ($self->flag_check ('unchanging')) { - my $result = $kadmin->keytab ($self->{name}); - if (defined $result) { - $self->log_action ('get', $user, $host, $time); - } - return $result; - } - unless (defined ($Wallet::Config::KEYTAB_TMP)) { - $self->error ('KEYTAB_TMP configuration variable not set'); - return; + $result = $kadmin->keytab ($self->{name}); + } else { + my @enctypes = $self->attr ('enctypes'); + $result = $kadmin->keytab_rekey ($self->{name}, @enctypes); } - my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; - unlink $file; - my @enctypes = $self->attr ('enctypes'); - if (not $kadmin->keytab_rekey ($self->{name}, $file, @enctypes)) { + if (defined $result) { + $self->log_action ('get', $user, $host, $time); + } else { $self->error ($kadmin->error); - return; - } - local *KEYTAB; - unless (open (KEYTAB, '<', $file)) { - my $princ = $self->{name}; - $self->error ("error opening keytab for principal $princ: $!"); - return; - } - local $/; - undef $!; - my $data = ; - if ($!) { - my $princ = $self->{name}; - $self->error ("error reading keytab for principal $princ: $!"); - unlink $file; - return; } - close KEYTAB; - unlink $file; - $self->log_action ('get', $user, $host, $time); - return $data; + return $result; } 1; diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index a29cae3..b9ac769 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -8,7 +8,9 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 33; +use Test::More tests => 32; + +BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } use Wallet::Admin; use Wallet::Config; @@ -90,13 +92,10 @@ SKIP: { # check the details of the return in the keytab check. is ($kadmin->create ('wallet/one'), 1, 'Creating wallet/one works'); is ($kadmin->exists ('wallet/one'), 1, ' and it now exists'); - unlink ('./tmp.keytab'); - is ($kadmin->keytab_rekey ('wallet/one', './tmp.keytab'), 1, - ' and retrieving a keytab works'); - ok (-s './tmp.keytab', ' and the resulting keytab is non-zero'); - is (getcreds ('./tmp.keytab', "wallet/one\@$Wallet::Config::KEYTAB_REALM"), - 1, ' and works for authentication'); - unlink ('./tmp.keytab'); + my $data = $kadmin->keytab_rekey ('wallet/one'); + ok (defined ($data), ' and retrieving a keytab works'); + is (keytab_valid ($data, 'wallet/one'), 1, + ' and works for authentication'); # Delete the principal and confirm behavior. is ($kadmin->destroy ('wallet/one'), 1, 'Deleting principal works'); diff --git a/perl/t/keytab.t b/perl/t/keytab.t index a702c0f..4e253eb 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -11,6 +11,8 @@ use POSIX qw(strftime); use Test::More tests => 135; +BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } + use Wallet::Admin; use Wallet::Config; use Wallet::Kadmin; @@ -89,21 +91,6 @@ sub created { } } -# Given keytab data and the principal, write it to a file and try -# authenticating using kinit. -sub valid { - my ($keytab, $principal) = @_; - open (KEYTAB, '>', 'keytab') or die "cannot create keytab: $!\n"; - print KEYTAB $keytab; - close KEYTAB; - $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - my $result = getcreds ('keytab', $principal); - if ($result) { - unlink 'keytab'; - } - return $result; -} - # Given keytab data, write it to a file and try to determine the enctypes of # the keys present in that file. Returns the enctypes as a list, with UNKNOWN # for encryption types that weren't recognized. This is an ugly way of doing @@ -168,7 +155,6 @@ SKIP: { $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); - $Wallet::Config::KEYTAB_TMP = '.'; my $realm = $Wallet::Config::KEYTAB_REALM; # Clean up the principals we're going to use. @@ -178,6 +164,16 @@ SKIP: { # Don't destroy the user's Kerberos ticket cache. $ENV{KRB5CCNAME} = 'krb5cc_test'; + # Test that object creation without KEYTAB_TMP fails. + undef $Wallet::Config::KEYTAB_TMP; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + }; + is ($object, undef, 'Creating keytab without KEYTAB_TMP fails'); + is ($@, "KEYTAB_TMP configuration variable not set\n", + ' with the right error'); + $Wallet::Config::KEYTAB_TMP = '.'; + # Okay, now we can test. First, create. $object = eval { Wallet::Object::Keytab->create ('keytab', "wallet\nf", $dbh, @trace) @@ -244,7 +240,7 @@ SKIP: { is ($object->error, '', ' and getting the keytab works'); } ok (! -f "./keytab.$$", ' and the temporary file was cleaned up'); - ok (valid ($data, 'wallet/one'), ' and the keytab is valid'); + ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); # For right now, this is the only backend type that we have for which we # can do a get, so test display of the last download information. @@ -261,12 +257,6 @@ EOO is ($object->show, $expected, 'Show output is correct'); # Test error handling on keytab retrieval. - undef $Wallet::Config::KEYTAB_TMP; - $data = $object->get (@trace); - is ($data, undef, 'Getting a keytab without a tmp directory fails'); - is ($object->error, 'KEYTAB_TMP configuration variable not set', - ' with the right error'); - $Wallet::Config::KEYTAB_TMP = '.'; SKIP: { skip 'no kadmin program test for Heimdal', 2 if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; @@ -447,7 +437,7 @@ SKIP: { 'Clearing the unchanging flag works'); my $data = $object->get (@trace); ok (defined ($data), ' and getting the keytab works'); - ok (valid ($data, 'wallet/one'), ' and the keytab is valid'); + ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); is ($two->get (@trace), undef, 'Get for wallet/two does not work'); is ($two->error, "cannot retrieve keytab for wallet/two\@$realm: bite me", @@ -464,7 +454,7 @@ SKIP: { if (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'mit'); my $data = $one->get (@trace); ok (defined $data, 'Get of unchanging keytab works'); - ok (valid ($data, 'wallet/one'), ' and the keytab is valid'); + ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); my $second = $one->get (@trace); ok (defined $second, ' and second retrieval also works'); $data =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; @@ -474,7 +464,7 @@ SKIP: { 'Clearing the unchanging flag works'); $data = $one->get (@trace); ok (defined ($data), ' and getting the keytab works'); - ok (valid ($data, 'wallet/one'), ' and the keytab is valid'); + ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); $data =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; ok ($data ne $second, ' and the new keytab is different'); is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); diff --git a/perl/t/lib/Util.pm b/perl/t/lib/Util.pm index ac0f530..ab88b39 100644 --- a/perl/t/lib/Util.pm +++ b/perl/t/lib/Util.pm @@ -20,7 +20,8 @@ $VERSION = '0.02'; use Exporter (); @ISA = qw(Exporter); -@EXPORT = qw(contents db_setup getcreds remctld_spawn remctld_stop); +@EXPORT = qw(contents db_setup getcreds keytab_valid remctld_spawn + remctld_stop); ############################################################################## # General utility functions @@ -66,7 +67,7 @@ sub db_setup { } ############################################################################## -# Local ticket cache +# Kerberos utility functions ############################################################################## # Given a keytab file and a principal, try authenticating with kinit. @@ -85,6 +86,22 @@ sub getcreds { return 0; } +# Given keytab data and the principal, write it to a file and try +# authenticating using kinit. +sub keytab_valid { + my ($keytab, $principal) = @_; + open (KEYTAB, '>', 'keytab') or die "cannot create keytab: $!\n"; + print KEYTAB $keytab; + close KEYTAB; + $principal .= '@' . $Wallet::Config::KEYTAB_REALM + unless $principal =~ /\@/; + my $result = getcreds ('keytab', $principal); + if ($result) { + unlink 'keytab'; + } + return $result; +} + ############################################################################## # remctld handling ############################################################################## -- cgit v1.2.3 From 345333f027be0b34318584b3f1b5e3e12adcaa98 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 19 Feb 2010 01:21:48 -0800 Subject: Refactor reporting into a separate module and script Move all reporting from Wallet::Admin to Wallet::Report and simplify the method names since they're now part of a dedicated reporting class. Similarly, create a new wallet-report script to wrap Wallet::Report, moving all reporting commands to it from wallet-admin, and simplify the commands since they're for a dedicated reporting script. Remove the contrib script wallet-report to wallet-summary so that it doesn't conflict with the new reporting backend script. --- Makefile.am | 24 +-- NEWS | 27 +-- TODO | 2 - autogen | 6 +- contrib/wallet-report | 240 -------------------------- contrib/wallet-summary | 240 ++++++++++++++++++++++++++ perl/Wallet/Admin.pm | 311 +-------------------------------- perl/Wallet/Report.pm | 425 ++++++++++++++++++++++++++++++++++++++++++++++ perl/t/admin.t | 143 ++-------------- perl/t/report.t | 171 +++++++++++++++++++ server/wallet-report | 203 ++++++++++++++++++++++ tests/docs/pod-spelling-t | 2 +- tests/docs/pod-t | 2 +- tests/server/admin-t | 76 +-------- tests/server/report-t | 151 ++++++++++++++++ 15 files changed, 1246 insertions(+), 777 deletions(-) delete mode 100755 contrib/wallet-report create mode 100755 contrib/wallet-summary create mode 100644 perl/Wallet/Report.pm create mode 100755 perl/t/report.t create mode 100755 server/wallet-report create mode 100755 tests/server/report-t (limited to 'perl/t') diff --git a/Makefile.am b/Makefile.am index db6738a..05ffe53 100644 --- a/Makefile.am +++ b/Makefile.am @@ -16,9 +16,10 @@ PERL_FILES = perl/Wallet/ACL.pm perl/Wallet/ACL/Base.pm \ perl/Wallet/Config.pm perl/Wallet/Database.pm perl/Wallet/Kadmin.pm \ perl/Wallet/Kadmin/Heimdal.pm perl/Wallet/Kadmin/MIT.pm \ perl/Wallet/Object/Base.pm perl/Wallet/Object/File.pm \ - perl/Wallet/Object/Keytab.pm perl/Wallet/Schema.pm \ - perl/Wallet/Server.pm perl/t/acl.t perl/t/admin.t perl/t/config.t \ - perl/t/data/README perl/t/data/keytab-fake perl/t/data/keytab.conf \ + perl/Wallet/Object/Keytab.pm perl/Wallet/Report.pm \ + perl/Wallet/Schema.pm perl/Wallet/Server.pm perl/t/acl.t \ + perl/t/admin.t perl/t/config.t perl/t/data/README \ + perl/t/data/keytab-fake perl/t/data/keytab.conf \ perl/t/data/netdb.conf perl/t/data/netdb-fake perl/t/init.t \ perl/t/keytab.t perl/t/lib/Util.pm perl/t/object.t perl/t/pod.t \ perl/t/schema.t perl/t/server.t perl/t/verifier-netdb.t \ @@ -28,14 +29,17 @@ AUTOMAKE_OPTIONS = foreign subdir-objects ACLOCAL_AMFLAGS = -I m4 EXTRA_DIST = LICENSE autogen client/wallet.pod config/allow-extract \ config/keytab config/keytab.acl config/wallet docs/design \ - contrib/README contrib/wallet-report contrib/wallet-report.8 \ + contrib/README contrib/wallet-summary contrib/wallet-summary.8 \ docs/design-acl docs/design-api docs/netdb-role-api docs/notes \ docs/setup examples/stanford.conf tests/TESTS tests/data/README \ tests/data/allow-extract tests/data/basic.conf tests/data/cmd-fake \ tests/data/cmd-wrapper tests/data/fake-data tests/data/fake-kadmin \ tests/data/fake-keytab tests/data/fake-keytab-2 \ tests/data/fake-keytab-merge tests/data/fake-keytab-old \ - tests/data/fake-srvtab tests/data/wallet.conf $(PERL_FILES) + tests/data/fake-srvtab tests/data/wallet.conf \ + tests/docs/pod-spelling-t tests/docs/pod-t tests/server/admin-t \ + tests/server/backend-t tests/server/keytab-t tests/server/report-t \ + $(PERL_FILES) noinst_LIBRARIES = portable/libportable.a util/libutil.a portable_libportable_a_SOURCES = portable/dummy.c portable/krb5-extra.c \ @@ -74,11 +78,11 @@ warnings: # Remove some additional files. DISTCLEANFILES = perl/Makefile tests/data/.placeholder -MAINTAINERCLEANFILES = Makefile.in aclocal.m4 build-aux/compile \ - build-aux/depcomp build-aux/install-sh build-aux/missing \ - client/wallet.1 config.h.in config.h.in~ configure \ - contrib/wallet-report.8 server/keytab-backend.8 \ - server/wallet-backend.8 +MAINTAINERCLEANFILES = Makefile.in aclocal.m4 build-aux/compile \ + build-aux/depcomp build-aux/install-sh build-aux/missing \ + client/wallet.1 config.h.in config.h.in~ configure \ + contrib/wallet-report.8 server/keytab-backend.8 \ + server/wallet-admin.8 server/wallet-backend.8 server/wallet-report.8 # Take appropriate actions in the Perl directory as well. We don't want to # always build the Perl directory in all-local, since otherwise Automake does diff --git a/NEWS b/NEWS index 96962f8..a87ae2f 100644 --- a/NEWS +++ b/NEWS @@ -32,15 +32,22 @@ wallet 0.10 (unreleased) Fix logging in wallet-backend and the remctl configuration to not log the data passed to store. - Add additional reports for wallet-admin list: objects owned by a - specific ACL, objects owned by no one, objects of a specific type, - objects with a specific flag, objects for which a specific ACL has - privileges, ACLs with an entry with a given type and identifier, and - ACLs with no members. - - Add a new report owners command to wallet-admin and corresponding - report_owners() method to Wallet::Admin, which returns all ACL lines - on owner ACLs for matching objects. + Move all reporting from Wallet::Admin to Wallet::Report and simplify + the method names since they're now part of a dedicated reporting + class. Similarly, create a new wallet-report script to wrap + Wallet::Report, moving all reporting commands to it from wallet-admin, + and simplify the commands since they're for a dedicated reporting + script. + + Add additional reports for wallet-report: objects owned by a specific + ACL, objects owned by no one, objects of a specific type, objects with + a specific flag, objects for which a specific ACL has privileges, ACLs + with an entry with a given type and identifier, and ACLs with no + members. + + Add a new owners command to wallet-report and corresponding owners() + method to Wallet::Report, which returns all ACL lines on owner ACLs + for matching objects. Report ACL names as well as numbers in object history. @@ -50,7 +57,7 @@ wallet 0.10 (unreleased) implementation than the wallet client. This primarily helps with testing. - Update to rra-c-util 3.0: + Update to rra-c-util 2.3: * Use Kerberos portability layer to support Heimdal. * Avoid Kerberos API calls deprecated on Heimdal. diff --git a/TODO b/TODO index 662ea47..cca8780 100644 --- a/TODO +++ b/TODO @@ -2,8 +2,6 @@ Release 0.10: -* Move reporting code from Wallet::Admin to Wallet::Report. - * Check whether we can just drop the realm restriction on keytabs and allow the name to contain the realm if the Kerberos type is Heimdal. diff --git a/autogen b/autogen index aeb4339..f7c8055 100755 --- a/autogen +++ b/autogen @@ -11,11 +11,13 @@ rm -rf autom4te.cache version=`grep '^wallet' NEWS | head -1 | cut -d' ' -f2` pod2man --release="$version" --center=wallet client/wallet.pod \ > client/wallet.1 -pod2man --release="$version" --center=wallet -s 8 contrib/wallet-report \ - > contrib/wallet-report.8 +pod2man --release="$version" --center=wallet -s 8 contrib/wallet-summary \ + > contrib/wallet-summary.8 pod2man --release="$version" --center=wallet -s 8 server/keytab-backend \ > server/keytab-backend.8 pod2man --release="$version" --center=wallet -s 8 server/wallet-admin \ > server/wallet-admin.8 pod2man --release="$version" --center=wallet -s 8 server/wallet-backend \ > server/wallet-backend.8 +pod2man --release="$version" --center=wallet -s 8 server/wallet-report \ + > server/wallet-report.8 diff --git a/contrib/wallet-report b/contrib/wallet-report deleted file mode 100755 index 1abe1f8..0000000 --- a/contrib/wallet-report +++ /dev/null @@ -1,240 +0,0 @@ -#!/usr/bin/perl -w -# -# wallet-report -- Report on keytabs in the wallet database. -# -# Written by Russ Allbery -# Copyright 2003, 2008 Board of Trustees, Leland Stanford Jr. University -# -# See LICENSE for licensing terms. - -############################################################################## -# Site configuration -############################################################################## - -# Path to the infrastructure reports directory. -$REPORTS = '/afs/ir/dept/itss/infrastructure/reports'; - -# Address to which to mail the report. -$ADDRESS = 'nobody@example.com'; - -# The various classification patterns for srvtabs. -@PATTERNS - = ([qr(/cgi\z), '*/cgi', 'CGI users'], - [qr(^(?i)http/), 'HTTP/*', 'HTTP Negotiate-Auth'], - [qr(^cifs/), 'cifs/*', 'CIFS'], - [qr(^host/), 'host/*', 'Host login'], - [qr(^ident/), 'ident/*', 'S/Ident'], - [qr(^imap/), 'imap/*', 'IMAP'], - [qr(^ldap/), 'ldap/*', 'LDAP'], - [qr(^nfs/), 'nfs/*', 'NFS'], - [qr(^pop/), 'pop/*', 'Kerberized POP'], - [qr(^sieve/), 'sieve/*', 'Sieve mail sorting'], - [qr(^smtp/), 'smtp/*', 'SMTP'], - [qr(^webauth/), 'webauth/*', 'WebAuth v3'], - [qr(^service/), 'service/*', 'Service principals']); - -############################################################################## -# Modules and declarations -############################################################################## - -require 5.005; - -use strict; -use vars qw($ADDRESS $DUMPFILE @PATTERNS $REPORTS); - -use Getopt::Long qw(GetOptions); -use File::Path qw(mkpath); -use POSIX qw(strftime); -use Wallet::Admin (); - -############################################################################## -# Database queries -############################################################################## - -# Return a list of keytab objects in the wallet database. Currently, we only -# report on keytab objects; reports for other objects will be added later. -sub list_keytabs { - my $admin = Wallet::Admin->new; - my @objects = $admin->list_objects; - if (!@objects and $admin->error) { - die $admin->error; - } - return map { $$_[1] } grep { $$_[0] eq 'keytab' } @objects; -} - -############################################################################## -# Reporting -############################################################################## - -# Used to make heredocs look pretty. -sub unquote { my ($string) = @_; $string =~ s/^:( {0,7}|\t)//gm; $string } - -# Given an array of principal names, classify them into various interesting -# groups and then report on the total number of principals, broken down by the -# individual groups. -sub report_principals { - my @principals = @_; - my (%count, $found); - - # Count the principals in each category. - for (@principals) { - $found = 0; - for my $mapping (@PATTERNS) { - if (/$$mapping[0]/) { - $count{$$mapping[1]}++; - $found = 1; - last; - } - } - $count{OTHER}++ unless $found; - } - my $total = scalar @principals; - - # Find the longest label for any principal type. - my ($taglen, $desclen) = (0, 0); - for (@PATTERNS) { - next unless $count{$$_[1]}; - $taglen = length ($$_[1]) if length ($$_[1]) > $taglen; - $desclen = length ($$_[2]) if length ($$_[2]) > $desclen; - } - $taglen = 6 if $taglen < 6; - - # Print the report. - print unquote (<<"EOM"); -: This is a summary of the current keytab entries in the wallet database, -: which contain entries for every principal that is managed by our -: Kerberos keytab management system. Not all of these principals may -: necessarily be in active use. Principals corresponding to hosts which -: are no longer registered in NetDB are purged periodically. -: -EOM - printf ("%-${taglen}s Count %-${desclen}s\n", 'Type', 'Description'); - print '-' x $taglen, ' ----- ', '-' x $desclen, "\n"; - for (@PATTERNS) { - next unless $count{$$_[1]}; - printf ("%-${taglen}s %5d %s\n", $$_[1], $count{$$_[1]}, $$_[2]); - } - if ($count{OTHER}) { - print "\n"; - printf ("%-${taglen}s %5d %s\n", '', $count{OTHER}, 'Other'); - } - print ' ' x $taglen, ' ', '=====', "\n"; - printf ("%${taglen}s %5d\n", 'Total:', $total); -} - -############################################################################## -# Main routine -############################################################################## - -# Read in command-line options. -my ($help, $mail); -Getopt::Long::config ('no_ignore_case', 'bundling'); -GetOptions ('help|h' => \$help, - 'mail|m' => \$mail) or exit 1; -if ($help) { - print "Feeding myself to perldoc, please wait....\n"; - exec ('perldoc', '-t', $0); -} - -# Clean up $0 for error reporting. -$0 =~ s%.*/%%; - -# If -m was given, save the report into the infrastructure area. -if ($mail) { - my $date = strftime ('%Y/%m', localtime); - mkpath ("$REPORTS/$date/kerberos"); - open (REPORT, "+> $REPORTS/$date/kerberos/wallet") - or die "$0: cannot create $REPORTS/$date/kerberos/wallet: $!\n"; - select REPORT; -} - -# Run the report. -my @principals = read_dump; -report_principals (@principals); - -# If -m was given, take the saved report and mail it as well. -if ($mail) { - seek (REPORT, 0, 0) - or die "$0: cannot rewind generated report: $!\n"; - my $date = strftime ('%Y-%m-%d', localtime); - open (MAIL, '| /usr/lib/sendmail -t -oi -oem') - or die "$0: cannot fork sendmail: $!\n"; - print MAIL "From: root\n"; - print MAIL "To: $ADDRESS\n"; - print MAIL "Subject: wallet keytab report ($date)\n\n"; - print MAIL ; - close MAIL; - if ($? != 0) { - warn "$0: sendmail exited with status ", ($? >> 8), "\n"; - } -} -close REPORT; - -############################################################################## -# Documentation -############################################################################## - -=head1 NAME - -wallet-report - Report on keytabs in the wallet database - -=head1 SYNOPSIS - -wallet-report [B<-hm>] - -=head1 DESCRIPTION - -Obtains a list of keytab objects in the wallet database and produces a -report of the types of principals contained therein and the total number -of principals registered. This report is sent to standard output by -default, but see B<-m> below. - -The classifications of srvtabs are determined by a set of patterns at the -beginning of this script. Modify it to add new classifications. - -=head1 OPTIONS - -=over 4 - -=item B<-h>, B<--help> - -Print out this documentation (which is done simply by feeding the script to -C). - -=item B<-m>, B<--mail> - -Rather than printing the report to standard output, send the report via -e-mail to the address set at the beginning of this script and also archive -a copy under F. - -=back - -=head1 FILES - -=over 4 - -=item F - -The root directory for archived reports. Archived reports will be saved -under this directory in a subdirectory for the year, the month, and -C, under the name C. In other words, for a report run -in March of 2003, the report will be saved in the file: - - /afs/ir/dept/itss/infrastructure/reports/2003/03/kerberos/srvtabs - -=back - -=head1 NOTES - -Considerably more information could potentially be reported than is -currently here. In particular, keytabs that have never been downloaded -are not distinguished from those that have, the number of keytabs -downloaded is not separately reported, and there aren't any statistics on -how recently the keytabs were downloaded. These could be useful areas of -future development. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/contrib/wallet-summary b/contrib/wallet-summary new file mode 100755 index 0000000..7a51f9e --- /dev/null +++ b/contrib/wallet-summary @@ -0,0 +1,240 @@ +#!/usr/bin/perl -w +# +# wallet-summarize -- Summarize keytabs in the wallet database. +# +# Written by Russ Allbery +# Copyright 2003, 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +############################################################################## +# Site configuration +############################################################################## + +# Path to the infrastructure reports directory. +$REPORTS = '/afs/ir/dept/itss/infrastructure/reports'; + +# Address to which to mail the report. +$ADDRESS = 'nobody@example.com'; + +# The various classification patterns for srvtabs. +@PATTERNS + = ([qr(/cgi\z), '*/cgi', 'CGI users'], + [qr(^(?i)http/), 'HTTP/*', 'HTTP Negotiate-Auth'], + [qr(^cifs/), 'cifs/*', 'CIFS'], + [qr(^host/), 'host/*', 'Host login'], + [qr(^ident/), 'ident/*', 'S/Ident'], + [qr(^imap/), 'imap/*', 'IMAP'], + [qr(^ldap/), 'ldap/*', 'LDAP'], + [qr(^nfs/), 'nfs/*', 'NFS'], + [qr(^pop/), 'pop/*', 'Kerberized POP'], + [qr(^sieve/), 'sieve/*', 'Sieve mail sorting'], + [qr(^smtp/), 'smtp/*', 'SMTP'], + [qr(^webauth/), 'webauth/*', 'WebAuth v3'], + [qr(^service/), 'service/*', 'Service principals']); + +############################################################################## +# Modules and declarations +############################################################################## + +require 5.005; + +use strict; +use vars qw($ADDRESS $DUMPFILE @PATTERNS $REPORTS); + +use Getopt::Long qw(GetOptions); +use File::Path qw(mkpath); +use POSIX qw(strftime); +use Wallet::Admin (); + +############################################################################## +# Database queries +############################################################################## + +# Return a list of keytab objects in the wallet database. Currently, we only +# report on keytab objects; reports for other objects will be added later. +sub list_keytabs { + my $report = Wallet::Report->new; + my @objects = $report->objects; + if (!@objects and $report->error) { + die $report->error; + } + return map { $$_[1] } grep { $$_[0] eq 'keytab' } @objects; +} + +############################################################################## +# Reporting +############################################################################## + +# Used to make heredocs look pretty. +sub unquote { my ($string) = @_; $string =~ s/^:( {0,7}|\t)//gm; $string } + +# Given an array of principal names, classify them into various interesting +# groups and then report on the total number of principals, broken down by the +# individual groups. +sub report_principals { + my @principals = @_; + my (%count, $found); + + # Count the principals in each category. + for (@principals) { + $found = 0; + for my $mapping (@PATTERNS) { + if (/$$mapping[0]/) { + $count{$$mapping[1]}++; + $found = 1; + last; + } + } + $count{OTHER}++ unless $found; + } + my $total = scalar @principals; + + # Find the longest label for any principal type. + my ($taglen, $desclen) = (0, 0); + for (@PATTERNS) { + next unless $count{$$_[1]}; + $taglen = length ($$_[1]) if length ($$_[1]) > $taglen; + $desclen = length ($$_[2]) if length ($$_[2]) > $desclen; + } + $taglen = 6 if $taglen < 6; + + # Print the report. + print unquote (<<"EOM"); +: This is a summary of the current keytab entries in the wallet database, +: which contain entries for every principal that is managed by our +: Kerberos keytab management system. Not all of these principals may +: necessarily be in active use. Principals corresponding to hosts which +: are no longer registered in NetDB are purged periodically. +: +EOM + printf ("%-${taglen}s Count %-${desclen}s\n", 'Type', 'Description'); + print '-' x $taglen, ' ----- ', '-' x $desclen, "\n"; + for (@PATTERNS) { + next unless $count{$$_[1]}; + printf ("%-${taglen}s %5d %s\n", $$_[1], $count{$$_[1]}, $$_[2]); + } + if ($count{OTHER}) { + print "\n"; + printf ("%-${taglen}s %5d %s\n", '', $count{OTHER}, 'Other'); + } + print ' ' x $taglen, ' ', '=====', "\n"; + printf ("%${taglen}s %5d\n", 'Total:', $total); +} + +############################################################################## +# Main routine +############################################################################## + +# Read in command-line options. +my ($help, $mail); +Getopt::Long::config ('no_ignore_case', 'bundling'); +GetOptions ('help|h' => \$help, + 'mail|m' => \$mail) or exit 1; +if ($help) { + print "Feeding myself to perldoc, please wait....\n"; + exec ('perldoc', '-t', $0); +} + +# Clean up $0 for error reporting. +$0 =~ s%.*/%%; + +# If -m was given, save the report into the infrastructure area. +if ($mail) { + my $date = strftime ('%Y/%m', localtime); + mkpath ("$REPORTS/$date/kerberos"); + open (REPORT, "+> $REPORTS/$date/kerberos/wallet") + or die "$0: cannot create $REPORTS/$date/kerberos/wallet: $!\n"; + select REPORT; +} + +# Run the report. +my @principals = read_dump; +report_principals (@principals); + +# If -m was given, take the saved report and mail it as well. +if ($mail) { + seek (REPORT, 0, 0) + or die "$0: cannot rewind generated report: $!\n"; + my $date = strftime ('%Y-%m-%d', localtime); + open (MAIL, '| /usr/lib/sendmail -t -oi -oem') + or die "$0: cannot fork sendmail: $!\n"; + print MAIL "From: root\n"; + print MAIL "To: $ADDRESS\n"; + print MAIL "Subject: wallet keytab report ($date)\n\n"; + print MAIL ; + close MAIL; + if ($? != 0) { + warn "$0: sendmail exited with status ", ($? >> 8), "\n"; + } +} +close REPORT; + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +wallet-summary - Report on keytabs in the wallet database + +=head1 SYNOPSIS + +B [B<-hm>] + +=head1 DESCRIPTION + +Obtains a list of keytab objects in the wallet database and produces a +report of the types of principals contained therein and the total number +of principals registered. This report is sent to standard output by +default, but see B<-m> below. + +The classifications of principals are determined by a set of patterns at +the beginning of this script. Modify it to add new classifications. + +=head1 OPTIONS + +=over 4 + +=item B<-h>, B<--help> + +Print out this documentation (which is done simply by feeding the script to +C). + +=item B<-m>, B<--mail> + +Rather than printing the report to standard output, send the report via +e-mail to the address set at the beginning of this script and also archive +a copy under F. + +=back + +=head1 FILES + +=over 4 + +=item F + +The root directory for archived reports. Archived reports will be saved +under this directory in a subdirectory for the year, the month, and +C, under the name C. In other words, for a report run +in March of 2003, the report will be saved in the file: + + /afs/ir/dept/itss/infrastructure/reports/2003/03/kerberos/srvtabs + +=back + +=head1 NOTES + +Considerably more information could potentially be reported than is +currently here. In particular, keytabs that have never been downloaded +are not distinguished from those that have, the number of keytabs +downloaded is not separately reported, and there aren't any statistics on +how recently the keytabs were downloaded. These could be useful areas of +future development. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index b4b3d86..e835713 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -22,7 +22,7 @@ use Wallet::Schema; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.04'; +$VERSION = '0.05'; ############################################################################## # Constructor, destructor, and accessors @@ -110,256 +110,6 @@ sub destroy { return 1; } -############################################################################## -# Reporting -############################################################################## - -# Given an ACL name, translate it to the ID for that ACL and return it. -# Often this is unneeded and could be done with a join, but by doing it in a -# separate step, we can give an error for the specific case of someone -# searching for a non-existant ACL. -sub acl_name_to_id { - my ($self, $acl) = @_; - my ($id); - eval { - my $sql = 'select ac_id from acls where ac_name = ?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($acl); - while (defined (my $row = $sth->fetchrow_hashref)) { - $id = $row->{ac_id}; - } - $self->{dbh}->commit; - }; - if (!defined $id || $id !~ /^\d+$/) { - $self->error ("could not find the acl $acl"); - return ''; - } - return $id; -} - -# Return the SQL statement to find every object in the database. -sub list_objects_all { - my ($self) = @_; - my $sql = 'select ob_type, ob_name from objects order by ob_type, - ob_name'; - return $sql; -} - -# Return the SQL statement and the search field required to find all objects -# matching a specific type. -sub list_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); -} - -# Return the SQL statement and search field required to find all objects -# owned by a given ACL. If the requested owner is 'null', then we ignore -# this and do a different search for IS NULL. If the requested owner does -# not actually match any ACLs, set an error and return the empty string. -sub list_objects_owner { - my ($self, $owner) = @_; - my ($sth); - if ($owner =~ /^null$/i) { - my $sql = 'select ob_type, ob_name from objects where ob_owner is null - order by objects.ob_type, objects.ob_name'; - return ($sql); - } else { - my $id = $self->acl_name_to_id ($owner); - return '' unless $id; - my $sql = 'select ob_type, ob_name from objects where ob_owner = ? - order by objects.ob_type, objects.ob_name'; - return ($sql, $id); - } -} - -# Return the SQL statement and search field required to find all objects -# that have a specific flag set. -sub list_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); -} - -# Return the SQL statement and search field required to find all objects -# that a given ACL has any permissions on. This expands from -# list_objects_owner in that it will also match any records that have the ACL -# set for get, store, show, destroy, or flags. If the requested owner does -# not actually match any ACLs, set an error and return the empty string. -sub list_objects_acl { - my ($self, $acl) = @_; - my $id = $self->acl_name_to_id ($acl); - return '' unless $id; - 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, $id, $id, $id, $id, $id, $id); -} - -# Returns a list of all objects stored in the wallet database in the form of -# type and name pairs. On error and for an empty database, the empty list -# will be returned. To distinguish between an empty list and an error, call -# error(), which will return undef if there was no error. Farms out specific -# statement to another subroutine for specific search types, but each case -# should return ob_type and ob_name in that order. -sub list_objects { - my ($self, $type, @args) = @_; - undef $self->{error}; - - # Find the SQL statement and the arguments to use. - my $sql = ''; - my @search = (); - if (!defined $type || $type eq '') { - ($sql) = $self->list_objects_all (); - } else { - if (@args != 1) { - $self->error ("object searches require an argument to search"); - } elsif ($type eq 'type') { - ($sql, @search) = $self->list_objects_type (@args); - } elsif ($type eq 'owner') { - ($sql, @search) = $self->list_objects_owner (@args); - } elsif ($type eq 'flag') { - ($sql, @search) = $self->list_objects_flag (@args); - } elsif ($type eq 'acl') { - ($sql, @search) = $self->list_objects_acl (@args); - } else { - $self->error ("do not know search type: $type"); - } - return unless $sql; - } - - my @objects; - eval { - my $object; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (@search); - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@objects, [ @$object ]); - } - $self->{dbh}->commit; - }; - if ($@) { - $self->error ("cannot list objects: $@"); - $self->{dbh}->rollback; - return; - } else { - return @objects; - } -} - -# Returns the SQL statement required to find and return all ACLs in the db. -sub list_acls_all { - my ($self) = @_; - my $sql = 'select ac_id, ac_name from acls order by ac_id'; - return ($sql); -} - -# Returns the SQL statement required to find and returned all empty ACLs in -# the db. -sub list_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'; - return ($sql); -} - -# Returns the SQL statement and the field required to search the ACLs and -# return only those entries which contain a entries with identifiers -# matching a particular given string. -sub list_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'; - $identifier = '%'.$identifier.'%'; - return ($sql, $type, $identifier); -} - -# Returns a list of all ACLs stored in the wallet database as a list of pairs -# of ACL IDs and ACL names. On error and for an empty database, the empty -# list will be returned; however, this is unlikely since any valid database -# will have at least an ADMIN ACL. Still, to distinguish between an empty -# list and an error, call error(), which will return undef if there was no -# error. -sub list_acls { - my ($self, $type, @args) = @_; - undef $self->{error}; - - # Find the SQL statement and the arguments to use. - my $sql = ''; - my @search = (); - if (!defined $type || $type eq '') { - ($sql) = $self->list_acls_all (); - } else { - if ($type eq 'entry') { - if (@args == 0) { - $self->error ("acl searches require an argument to search"); - } else { - ($sql, @search) = $self->list_acls_entry (@args); - } - } elsif ($type eq 'empty') { - ($sql) = $self->list_acls_empty (); - } else { - $self->error ("do not know search type: $type"); - } - return unless $sql; - } - - 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; - } else { - return @acls; - } -} - -# Returns a report of all ACL lines contained in owner ACLs for matching -# objects. Objects are specified by type and name, which may be SQL wildcard -# expressions. Each list member will be a pair of ACL scheme and ACL -# identifier, with duplicates removed. On error and for no matching entries, -# the empty list will be returned. To distinguish between an empty return and -# an error, call error(), which will return undef if there was no error. -sub report_owners { - my ($self, $type, $name) = @_; - undef $self->{error}; - my @lines; - 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 ]); - } - $self->{dbh}->commit; - }; - if ($@) { - $self->error ("cannot report on owners: $@"); - $self->{dbh}->rollback; - return; - } else { - return @lines; - } -} - ############################################################################## # Object registration ############################################################################## @@ -414,7 +164,7 @@ __DATA__ Wallet::Admin - Wallet system administrative interface =for stopwords -ACL hostname ACLs SQL wildcard Allbery +ACL hostname Allbery =head1 SYNOPSIS @@ -478,52 +228,6 @@ initialize() uses C as the hostname and PRINCIPAL as the user when logging the history of the ADMIN ACL creation and for any subsequent actions on the object it returns. -=item list_acls(TYPE, SEARCH) - -Returns a list of all ACLs matching a search type and string in the -database, or all ACLs if no search information is given. 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 "ADMIN" and ID 1 and one -with name "group/admins" and ID 3, list_acls() with no arguments would -return: - - ([ 1, 'ADMIN' ], [ 3, 'group/admins' ]) - -Returns the empty list on failure. Any valid wallet database should have -at least one ACL, but an error can be distinguished from the odd case of a -database with no ACLs by calling error(). error() is guaranteed to return -the error message if there was an error and undef if there was no error. - -There are currently two search types. C takes no arguments and -will return only those ACLs that have no entries within them. C -takes two arguments, an entry scheme and an entry identifier, and will -return any ACLs with an entry that matches the given scheme and contains -the given identifier. - -=item list_objects(TYPE, SEARCH) - -Returns a list of all objects matching a search type and string in the -database, or all objects in the database if no search information is -given. 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 and with values C and C, list_objects() -with no arguments would return: - - ([ 'keytab', 'host/example.com' ], [ 'keytab', 'foo' ]) - -Returns the empty list on failure. To distinguish between this and a -database containing no objects, the caller should call error(). error() -is guaranteed to return the error message if there was an error and undef -if there was no error. - -There are four types of searches currently. C (with a given type) -will return only those entries where the type matches the given type. -C, with a given owner, will only return those objects owned by the -given ACL name. C, with a given flag name, will only return those -items with a flag set to the given value. C operates like C, -but will return only those objects that have the given ACL name on any of -the possible ACL settings, not just owner. - =item register_object (TYPE, CLASS) Register in the database a mapping from the object type TYPE to the class @@ -545,17 +249,6 @@ 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 report_owners(TYPE, NAME) - -Returns a list of all ACL lines contained in owner ACLs for objects -matching TYPE and NAME, which are interpreted as SQL patterns using C<%> -as a wildcard. The return value is a list of references to pairs of -schema and identifier, with duplicates removed. - -Returns the empty list on failure. To distinguish between this and no -matches, the caller should call error(). error() is guaranteed to return -the error message if there was an error and undef if there was no error. - =back =head1 SEE ALSO diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm new file mode 100644 index 0000000..7cd8653 --- /dev/null +++ b/perl/Wallet/Report.pm @@ -0,0 +1,425 @@ +# Wallet::Report -- Wallet system reporting interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Report; +require 5.006; + +use strict; +use vars qw($VERSION); + +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.01'; + +############################################################################## +# Constructor, destructor, and accessors +############################################################################## + +# Create a new wallet report object. Opens a connection to the database that +# will be used for all of the wallet configuration information. Throw an +# exception if anything goes wrong. +sub new { + my ($class) = @_; + my $dbh = Wallet::Database->connect; + my $self = { dbh => $dbh }; + bless ($self, $class); + return $self; +} + +# Returns the database handle (used mostly for testing). +sub dbh { + my ($self) = @_; + return $self->{dbh}; +} + +# Set or return the error stashed in the object. +sub error { + my ($self, @error) = @_; + if (@error) { + my $error = join ('', @error); + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + $self->{error} = $error; + } + return $self->{error}; +} + +# Disconnect the database handle on object destruction to avoid warnings. +sub DESTROY { + my ($self) = @_; + $self->{dbh}->disconnect unless $self->{dbh}->{InactiveDestroy}; +} + +############################################################################## +# Object reports +############################################################################## + +# 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; +} + +# 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); +} + +# Return the SQL statement and search field required to find all objects owned +# by a given ACL. If the requested owner is null, we ignore this and do a +# different search for IS NULL. If the requested owner does not actually +# match any ACLs, set an error and return undef. +sub objects_owner { + my ($self, $owner) = @_; + my ($sth); + 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); + } else { + my $acl = eval { Wallet::ACL->new ($owner, $self->{dbh}) }; + 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); + } +} + +# 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); +} + +# Return the SQL statement and search field required to find all objects that +# a given ACL has any permissions on. This expands from objects_owner in that +# it will also match any records that have the ACL set for get, store, show, +# destroy, or flags. If the requested owner does not actually match any ACLs, +# set an error and return the empty string. +sub objects_acl { + my ($self, $search) = @_; + my $acl = eval { Wallet::ACL->new ($search, $self->{dbh}) }; + 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); +} + +# Returns a list of all objects stored in the wallet database in the form of +# type and name pairs. On error and for an empty database, the empty list +# will be returned. To distinguish between an empty list and an error, call +# error(), which will return undef if there was no error. Farms out specific +# statement to another subroutine for specific search types, but each case +# should return ob_type and ob_name in that order. +sub objects { + my ($self, $type, @args) = @_; + undef $self->{error}; + + # Find the SQL statement and the arguments to use. + my $sql = ''; + my @search = (); + if (!defined $type || $type eq '') { + ($sql) = $self->objects_all; + } else { + if (@args != 1) { + $self->error ("object searches require one argument to search"); + } elsif ($type eq 'type') { + ($sql, @search) = $self->objects_type (@args); + } elsif ($type eq 'owner') { + ($sql, @search) = $self->objects_owner (@args); + } elsif ($type eq 'flag') { + ($sql, @search) = $self->objects_flag (@args); + } elsif ($type eq 'acl') { + ($sql, @search) = $self->objects_acl (@args); + } else { + $self->error ("do not know search type: $type"); + } + return unless $sql; + } + + # Do the search. + my @objects; + eval { + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute (@search); + my $object; + while (defined ($object = $sth->fetchrow_arrayref)) { + push (@objects, [ @$object ]); + } + $self->{dbh}->commit; + }; + if ($@) { + $self->error ("cannot list objects: $@"); + $self->{dbh}->rollback; + return; + } + return @objects; +} + +############################################################################## +# ACL reports +############################################################################## + +# Returns the SQL statement required to find and return all ACLs in the +# database. +sub acls_all { + my ($self) = @_; + my $sql = 'select ac_id, ac_name from acls order by ac_id'; + return ($sql); +} + +# 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'; + return ($sql); +} + +# Returns the SQL statement and the field required to find ACLs containing the +# specified entry. The identifier is automatically surrounded by wildcards to +# do a substring search. +sub acls_entry { + my ($self, $type, $identifier) = @_; + my $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 . '%'); +} + +# Returns a list of all ACLs stored in the wallet database as a list of pairs +# of ACL IDs and ACL names, possibly limited by some criteria. On error and +# for an empty database, the empty list will be returned. To distinguish +# between an empty list and an error, call error(), which will return undef if +# there was no error. +sub acls { + my ($self, $type, @args) = @_; + undef $self->{error}; + + # Find the SQL statement and the arguments to use. + my $sql; + my @search = (); + if (!defined $type || $type eq '') { + ($sql) = $self->acls_all; + } else { + if ($type eq 'entry') { + if (@args == 0) { + $self->error ('ACL searches require an argument to search'); + return; + } else { + ($sql, @search) = $self->acls_entry (@args); + } + } elsif ($type eq 'empty') { + ($sql) = $self->acls_empty; + } else { + $self->error ("do not know 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; +} + +# Returns all ACL entries contained in owner ACLs for matching objects. +# Objects are specified by type and name, which may be SQL wildcard +# expressions. Each list member will be a pair of ACL scheme and ACL +# identifier, with duplicates removed. On error and for no matching entries, +# the empty list will be returned. To distinguish between an empty return and +# an error, call error(), which will return undef if there was no error. +sub owners { + my ($self, $type, $name) = @_; + undef $self->{error}; + my @lines; + 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 ]); + } + $self->{dbh}->commit; + }; + if ($@) { + $self->error ("cannot report on owners: $@"); + $self->{dbh}->rollback; + return; + } + return @lines; +} + +1; +__DATA__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +Wallet::Report - Wallet system reporting interface + +=for stopwords +ACL ACLs wildcard Allbery SQL tuples + +=head1 SYNOPSIS + + use Wallet::Report; + my $report = Wallet::Report->new; + my @objects = $report->objects ('type', 'keytab'); + for my $object (@objects) { + print "@$object\n"; + } + +=head1 DESCRIPTION + +Wallet::Report provides a mechanism to generate lists and reports on the +contents of the wallet database. The format of the results returned +depend on the type of search, but will generally be returned as a list of +tuples identifying objects, ACLs, or ACL entries. + +To use this object, several configuration variables must be set (at least +the database configuration). For information on those variables and how +to set them, see Wallet::Config(3). For more information on the normal +user interface to the wallet server, see Wallet::Server(3). + +=head1 CLASS METHODS + +=over 4 + +=item new() + +Creates a new wallet report object and connects to the database. On any +error, this method throws an exception. + +=back + +=head1 INSTANCE METHODS + +For all methods that can fail, the caller should call error() after a +failure to get the error message. For all methods that return lists, if +they return an empty list, the caller should call error() to distinguish +between an empty report and an error. + +=over 4 + +=item acls([ TYPE [, SEARCH ... ]]) + +Returns a list of all ACLs matching a search type and string in the +database, or all ACLs if no search information is given. There are +currently two search types. C takes no arguments and will return +only those ACLs that have no entries within them. C 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. + +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 and +ID 1 and one with name C and ID 3, acls() with no arguments +would return: + + ([ 1, 'ADMIN' ], [ 3, 'group/admins' ]) + +Returns the empty list on failure. An error can be distinguished from +empty search results by calling error(). error() is guaranteed to return +the error message if there was an error and undef if there was no error. + +=item error() + +Returns the error of the last failing operation or undef if no operations +have failed. Callers should call this function to get the error message +after an undef return from any other instance method. + +=item objects([ TYPE [, SEARCH ... ]]) + +Returns a list of all objects matching a search type and string in the +database, or all objects in the database if no search information is +given. + +There are four types of searches currently. C, with a given type, +will return only those entries where the type matches the given type. +C, with a given owner, will only return those objects owned by the +given ACL name or ID. C, with a given flag name, will only return +those items with a flag set to the given value. C operates like +C, but will return only those objects that have the given ACL name +or ID on any of the possible ACL settings, not just owner. + +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 +and with values C and C, objects() with no +arguments would return: + + ([ 'keytab', 'host/example.com' ], [ 'keytab', 'foo' ]) + +Returns the empty list on failure. To distinguish between this and an +empty search result, the caller should call error(). error() is +guaranteed to return the error message if there was an error and undef if +there was no error. + +=item owners(TYPE, NAME) + +Returns a list of all ACL lines contained in owner ACLs for objects +matching TYPE and NAME, which are interpreted as SQL patterns using C<%> +as a wildcard. The return value is a list of references to pairs of +schema and identifier, with duplicates removed. + +Returns the empty list on failure. To distinguish between this and no +matches, the caller should call error(). error() is guaranteed to return +the error message if there was an error and undef if there was no error. + +=back + +=head1 SEE ALSO + +Wallet::Config(3), Wallet::Server(3) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery and Jon Robertson . + +=cut diff --git a/perl/t/admin.t b/perl/t/admin.t index f94b39b..e22088e 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -3,13 +3,14 @@ # t/admin.t -- Tests for wallet administrative interface. # # Written by Russ Allbery -# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. -use Test::More tests => 83; +use Test::More tests => 16; use Wallet::Admin; +use Wallet::Report; use Wallet::Schema; use Wallet::Server; @@ -25,10 +26,11 @@ is ($admin->initialize ('admin@EXAMPLE.COM'), 1, ' and initialization succeeds'); # We have an empty database, so we should see no objects and one ACL. -my @objects = $admin->list_objects; +my $report = Wallet::Report->new; +my @objects = $report->objects; is (scalar (@objects), 0, 'No objects in the database'); -is ($admin->error, undef, ' and no error'); -my @acls = $admin->list_acls; +is ($report->error, undef, ' and no error'); +my @acls = $report->acls; is (scalar (@acls), 1, 'One ACL in the database'); is ($acls[0][0], 1, ' and that is ACL ID 1'); is ($acls[0][1], 'ADMIN', ' with the right name'); @@ -36,137 +38,20 @@ is ($acls[0][1], 'ADMIN', ' with the right name'); # Register a base object so that we can create a simple object. is ($admin->register_object ('base', 'Wallet::Object::Base'), 1, 'Registering Wallet::Object::Base works'); - -# Create an object. +is ($admin->register_object ('base', 'Wallet::Object::Base'), undef, + ' and cannot be registered twice'); $server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; is ($@, '', 'Creating a server instance did not die'); is ($server->create ('base', 'service/admin'), 1, ' and creating base:service/admin succeeds'); -# Now, we should see one object. -@objects = $admin->list_objects; -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'); - -# Test registering a new ACL type. We don't have a good way of really using -# this right now. +# Test registering a new ACL type. is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), 1, 'Registering Wallet::ACL::Base works'); - -# Create another ACL. -is ($server->acl_create ('first'), 1, 'ACL creation succeeds'); -@acls = $admin->list_acls; -is (scalar (@acls), 2, ' and now there are two ACLs'); -is ($acls[0][0], 1, ' and the first ID is correct'); -is ($acls[0][1], 'ADMIN', ' and the first name is correct'); -is ($acls[1][0], 2, ' and the second ID is correct'); -is ($acls[1][1], 'first', ' and the second name is correct'); - -# Delete that ACL and create another. -is ($server->acl_create ('second'), 1, 'Second ACL creation succeeds'); -is ($server->acl_destroy ('first'), 1, ' and deletion of the first succeeds'); -@acls = $admin->list_acls; -is (scalar (@acls), 2, ' and there are still two ACLs'); -is ($acls[0][0], 1, ' and the first ID is still the same'); -is ($acls[0][1], 'ADMIN', ' and the first name is still the same'); -is ($acls[1][0], 3, ' but the second ID has changed'); -is ($acls[1][1], 'second', ' and the second name is correct'); - -# Currently, we have no owners, so we should get an empty owner report. -my @lines = $admin->report_owners ('%', '%'); -is (scalar (@lines), 0, 'Owner report is currently empty'); -is ($admin->error, undef, ' and there is no error'); - -# Set an owner and make sure we now see something in the report. -is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, - 'Setting an owner works'); -@lines = $admin->report_owners ('%', '%'); -is (scalar (@lines), 1, ' and now there is one owner in the report'); -is ($lines[0][0], 'krb5', ' with the right scheme'); -is ($lines[0][1], 'admin@EXAMPLE.COM', ' and the right identifier'); -@lines = $admin->report_owners ('keytab', '%'); -is (scalar (@lines), 0, 'Owners of keytabs is empty'); -is ($admin->error, undef, ' with no error'); -@lines = $admin->report_owners ('base', 'foo/%'); -is (scalar (@lines), 0, 'Owners of base foo/* objects is empty'); -is ($admin->error, undef, ' with no error'); - -# Create a second object with the same owner. -is ($server->create ('base', 'service/foo'), 1, - 'Creating base:service/foo succeeds'); -is ($server->owner ('base', 'service/foo', 'ADMIN'), 1, - ' and setting the owner to the same value works'); -@lines = $admin->report_owners ('base', 'service/%'); -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'); - -# 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'); -@lines = $admin->report_owners ('base', '%'); -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'); - -# Add a few things to the second ACL to see what happens. -is ($server->acl_add ('second', 'base', 'foo'), 1, - 'Adding an ACL line to the new ACL works'); -is ($server->acl_add ('second', 'base', 'bar'), 1, - ' and adding another ACL line to the new ACL works'); -@lines = $admin->report_owners ('base', '%'); -is (scalar (@lines), 3, ' and now there are three owners in the report'); -is ($lines[0][0], 'base', ' first has the right scheme'); -is ($lines[0][1], 'bar', ' and the right identifier'); -is ($lines[1][0], 'base', ' second has the right scheme'); -is ($lines[1][1], 'foo', ' and the right identifier'); -is ($lines[2][0], 'krb5', ' third has the right scheme'); -is ($lines[2][1], 'admin@EXAMPLE.COM', ' and the right identifier'); - -# Test ownership and other ACL values. Change one keytab to be not owned by -# ADMIN, but have group permission on it. We'll need a third object neither -# owned by ADMIN or with any permissions from it. -is ($server->create ('base', 'service/null'), 1, - 'Creating base:service/null succeeds'); -is ($server->acl ('base', 'service/foo', 'get', 'ADMIN'), 1, - 'Changing the get ACL for the search also does'); -@lines = $admin->list_objects ('owner', 'ADMIN'); -is (scalar (@lines), 1, 'Searching for objects owned by ADMIN finds one'); -is ($lines[0][0], 'base', ' and it has the right type'); -is ($lines[0][1], 'service/admin', ' and the right name'); -@lines = $admin->list_objects ('owner', 'null'); -is (scalar (@lines), 1, 'Searching for objects with no set ownerfinds one'); -is ($lines[0][0], 'base', ' and it has the right type'); -is ($lines[0][1], 'service/null', ' and the right name'); -@lines = $admin->list_objects ('acl', 'ADMIN'); -is (scalar (@lines), 2, 'ADMIN has any rights at all on two objects'); -is ($lines[0][0], 'base', ' and the first has the right type'); -is ($lines[0][1], 'service/admin', ' and the right name'); -is ($lines[1][0], 'base', ' and the second has the right type'); -is ($lines[1][1], 'service/foo', ' and the right name'); - -# Listing objects of a specific type. -@lines = $admin->list_objects ('type', 'base'); -is (scalar (@lines), 3, 'Searching for all objects of type base finds three'); -is ($lines[0][0], 'base', ' and the first has the right type'); -is ($lines[0][1], 'service/admin', ' and the right name'); -is ($lines[1][0], 'base', ' and the second has the right type'); -is ($lines[1][1], 'service/foo', ' and the right name'); -is ($lines[2][0], 'base', ' and the third has the right type'); -is ($lines[2][1], 'service/null', ' and the right name'); -@lines = $admin->list_objects ('type', 'keytab'); -is (scalar (@lines), 0, 'Searching for all objects of type keytab finds none'); - -# Test setting a flag, searching for objects with it, and then clearing it. -is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, - 'Setting a flag works'); -@lines = $admin->list_objects ('flag', 'unchanging'); -is (scalar (@lines), 1, 'Searching for all objects with that flag finds one'); -is ($lines[0][0], 'base', ' and it has the right type'); -is ($lines[0][1], 'service/admin', ' and the right name'); -is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, - 'Clearing the flag works'); +is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), undef, + ' and cannot be registered twice'); +is ($server->acl_add ('ADMIN', 'base', 'foo'), 1, + ' and adding a base ACL now works'); # Clean up. is ($admin->destroy, 1, 'Destruction succeeds'); diff --git a/perl/t/report.t b/perl/t/report.t new file mode 100755 index 0000000..a18b995 --- /dev/null +++ b/perl/t/report.t @@ -0,0 +1,171 @@ +#!/usr/bin/perl -w +# +# t/report.t -- Tests for the wallet reporting interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +use Test::More tests => 83; + +use Wallet::Admin; +use Wallet::Report; +use Wallet::Server; + +use lib 't/lib'; +use Util; + +# Use Wallet::Admin to set up the database. +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Wallet::Admin creation did not die'); +is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, + 'Database initialization succeeded'); +$admin->register_object ('base', 'Wallet::Object::Base'); +$admin->register_verifier ('base', 'Wallet::ACL::Base'); + +# We have an empty database, so we should see no objects and one ACL. +my $report = eval { Wallet::Report->new }; +is ($@, '', 'Wallet::Report creation did not die'); +ok ($report->isa ('Wallet::Report'), ' and returned the right class'); +my @objects = $report->objects; +is (scalar (@objects), 0, 'No objects in the database'); +is ($report->error, undef, ' and no error'); +my @acls = $report->acls; +is (scalar (@acls), 1, 'One ACL in the database'); +is ($acls[0][0], 1, ' and that is ACL ID 1'); +is ($acls[0][1], 'ADMIN', ' with the right name'); + +# Create an object. +$server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; +is ($@, '', 'Creating a server instance did not die'); +is ($server->create ('base', 'service/admin'), 1, + ' and creating base:service/admin succeeds'); + +# Now, we should see one object. +@objects = $report->objects; +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'); + +# Create another ACL. +is ($server->acl_create ('first'), 1, 'ACL creation succeeds'); +@acls = $report->acls; +is (scalar (@acls), 2, ' and now there are two ACLs'); +is ($acls[0][0], 1, ' and the first ID is correct'); +is ($acls[0][1], 'ADMIN', ' and the first name is correct'); +is ($acls[1][0], 2, ' and the second ID is correct'); +is ($acls[1][1], 'first', ' and the second name is correct'); + +# Delete that ACL and create another. +is ($server->acl_create ('second'), 1, 'Second ACL creation succeeds'); +is ($server->acl_destroy ('first'), 1, ' and deletion of the first succeeds'); +@acls = $report->acls; +is (scalar (@acls), 2, ' and there are still two ACLs'); +is ($acls[0][0], 1, ' and the first ID is still the same'); +is ($acls[0][1], 'ADMIN', ' and the first name is still the same'); +is ($acls[1][0], 3, ' but the second ID has changed'); +is ($acls[1][1], 'second', ' and the second name is correct'); + +# Currently, we have no owners, so we should get an empty owner report. +my @lines = $report->owners ('%', '%'); +is (scalar (@lines), 0, 'Owner report is currently empty'); +is ($report->error, undef, ' and there is no error'); + +# Set an owner and make sure we now see something in the report. +is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, + 'Setting an owner works'); +@lines = $report->owners ('%', '%'); +is (scalar (@lines), 1, ' and now there is one owner in the report'); +is ($lines[0][0], 'krb5', ' with the right scheme'); +is ($lines[0][1], 'admin@EXAMPLE.COM', ' and the right identifier'); +@lines = $report->owners ('keytab', '%'); +is (scalar (@lines), 0, 'Owners of keytabs is empty'); +is ($report->error, undef, ' with no error'); +@lines = $report->owners ('base', 'foo/%'); +is (scalar (@lines), 0, 'Owners of base foo/* objects is empty'); +is ($report->error, undef, ' with no error'); + +# Create a second object with the same owner. +is ($server->create ('base', 'service/foo'), 1, + 'Creating base:service/foo succeeds'); +is ($server->owner ('base', 'service/foo', 'ADMIN'), 1, + ' and setting the owner to the same value works'); +@lines = $report->owners ('base', 'service/%'); +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'); + +# 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'); +@lines = $report->owners ('base', '%'); +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'); + +# Add a few things to the second ACL to see what happens. +is ($server->acl_add ('second', 'base', 'foo'), 1, + 'Adding an ACL line to the new ACL works'); +is ($server->acl_add ('second', 'base', 'bar'), 1, + ' and adding another ACL line to the new ACL works'); +@lines = $report->owners ('base', '%'); +is (scalar (@lines), 3, ' and now there are three owners in the report'); +is ($lines[0][0], 'base', ' first has the right scheme'); +is ($lines[0][1], 'bar', ' and the right identifier'); +is ($lines[1][0], 'base', ' second has the right scheme'); +is ($lines[1][1], 'foo', ' and the right identifier'); +is ($lines[2][0], 'krb5', ' third has the right scheme'); +is ($lines[2][1], 'admin@EXAMPLE.COM', ' and the right identifier'); + +# Test ownership and other ACL values. Change one keytab to be not owned by +# ADMIN, but have group permission on it. We'll need a third object neither +# owned by ADMIN or with any permissions from it. +is ($server->create ('base', 'service/null'), 1, + 'Creating base:service/null succeeds'); +is ($server->acl ('base', 'service/foo', 'get', 'ADMIN'), 1, + 'Changing the get ACL for the search also does'); +@lines = $report->objects ('owner', 'ADMIN'); +is (scalar (@lines), 1, 'Searching for objects owned by ADMIN finds one'); +is ($lines[0][0], 'base', ' and it has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +@lines = $report->objects ('owner', 'null'); +is (scalar (@lines), 1, 'Searching for objects with no set ownerfinds one'); +is ($lines[0][0], 'base', ' and it has the right type'); +is ($lines[0][1], 'service/null', ' and the right name'); +@lines = $report->objects ('acl', 'ADMIN'); +is (scalar (@lines), 2, 'ADMIN has any rights at all on two objects'); +is ($lines[0][0], 'base', ' and the first has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +is ($lines[1][0], 'base', ' and the second has the right type'); +is ($lines[1][1], 'service/foo', ' and the right name'); + +# Listing objects of a specific type. +@lines = $report->objects ('type', 'base'); +is (scalar (@lines), 3, 'Searching for all objects of type base finds three'); +is ($lines[0][0], 'base', ' and the first has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +is ($lines[1][0], 'base', ' and the second has the right type'); +is ($lines[1][1], 'service/foo', ' and the right name'); +is ($lines[2][0], 'base', ' and the third has the right type'); +is ($lines[2][1], 'service/null', ' and the right name'); +@lines = $report->objects ('type', 'keytab'); +is (scalar (@lines), 0, 'Searching for all objects of type keytab finds none'); + +# Test setting a flag, searching for objects with it, and then clearing it. +is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, + 'Setting a flag works'); +@lines = $report->objects ('flag', 'unchanging'); +is (scalar (@lines), 1, 'Searching for all objects with that flag finds one'); +is ($lines[0][0], 'base', ' and it has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, + 'Clearing the flag works'); +@lines = $report->objects ('flag', 'unchanging'); +is (scalar (@lines), 0, ' and now there are no objects in the report'); +is ($report->error, undef, ' with no error'); + +# Clean up. +$admin->destroy; +unlink 'wallet-db'; diff --git a/server/wallet-report b/server/wallet-report new file mode 100755 index 0000000..a6b3b8d --- /dev/null +++ b/server/wallet-report @@ -0,0 +1,203 @@ +#!/usr/bin/perl -w +# +# wallet-report -- Wallet server reporting interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +############################################################################## +# Declarations and site configuration +############################################################################## + +use strict; +use Wallet::Report; + +############################################################################## +# Implementation +############################################################################## + +# Parse and execute a command. We wrap this in a subroutine call for easier +# testing. +sub command { + die "Usage: wallet-report [ ...]\n" unless @_; + my $report = Wallet::Report->new; + + # Parse command-line options and dispatch to the appropriate calls. + my ($command, @args) = @_; + if ($command eq 'acls') { + die "too many arguments to acls\n" if @args > 3; + my @acls = $report->acls (@args); + if (!@acls and $report->error) { + die $report->error, "\n"; + } + for my $acl (sort { $$a[1] cmp $$b[1] } @acls) { + print "$$acl[1] (ACL ID: $$acl[0])\n"; + } + } elsif ($command eq 'objects') { + die "too many arguments to objects\n" if @args > 2; + my @objects = $report->objects (@args); + if (!@objects and $report->error) { + die $report->error, "\n"; + } + for my $object (@objects) { + print join (' ', @$object), "\n"; + } + } elsif ($command eq 'owners') { + die "too many arguments to owners\n" if @args > 2; + die "too few arguments to owners\n" if @args < 2; + my @entries = $report->owners (@args); + if (!@entries and $report->error) { + die $report->error, "\n"; + } + for my $entry (@entries) { + print join (' ', @$entry), "\n"; + } + } else { + die "unknown command $command\n"; + } +} +command (@ARGV); +__END__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +wallet-report - Wallet server reporting interface + +=for stopwords +metadata ACL hostname backend acl acls wildcard SQL Allbery remctl + +=head1 SYNOPSIS + +B I [I ...] + +=head1 DESCRIPTION + +B provides a command-line interface for running reports on +the wallet database. It is intended to be run on the wallet server as a +user with access to the wallet database and configuration, but can also be +made available via remctl to users who should have reporting privileges. + +This program is a fairly thin wrapper around Wallet::Report that +translates command strings into method calls and returns the results. + +=head1 OPTIONS + +B takes no traditional options. + +=head1 COMMANDS + +=over 4 + +=item acls + +=item acls empty + +=item acls entry + +Returns a list of ACLs in the database. ACLs will be listed in the form: + + (ACL ID: ) + +where is the human-readable name and is the numeric ID. The +numeric ID is what's used internally by the wallet system. There will be +one line per ACL. + +If no search type is given, all the ACLs in the database will be returned. +If a search type (and possible search arguments) are given, then the ACLs +will be limited to those that match the search. + +The currently supported ACL search types are: + +=over 4 + +=item acls empty + +Returns all ACLs which have no entries, generally so that abandoned ACLs +can be destroyed. + +=item acls entry + +Returns all ACLs containing an entry with given scheme and identifier. +The scheme must be an exact match, but the string will match +any identifier containing that string. + +=back + +=item objects + +=item objects acl + +=item objects flag + +=item objects owner + +=item objects type + +Returns a list of objects in the database. Objects will be listed in the +form: + + + +There will be one line per object. + +If no search type is given, all objects in the database will be returned. +If a search type (and possible search arguments) are given, the objects +will be limited to those that match the search. + +The currently supported object search types are: + +=over 4 + +=item list objects acl + +Returns all objects for which the given ACL name or ID has any +permissions. This includes those objects owned by the ACL as well as +those where that ACL has any other, more limited permissions. + +=item list objects flag + +Returns all objects which have the given flag set. + +=item list objects owner + +Returns all objects owned by the given ACL name or ID. + +=item list objects type + +Returns all objects of the given type. + +=back + +=item owners + +Returns a list of all ACL entries in owner ACLs for all objects matching +both and . These can be the type or name of +objects or they can be patterns using C<%> as the wildcard character +following the normal rules of SQL patterns. + +The output will be one line per ACL line in the form: + + + +with duplicates suppressed. + +=back + +=head1 SEE ALSO + +Wallet::Config(3), Wallet::Report(3), wallet-backend(8) + +This program is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/tests/docs/pod-spelling-t b/tests/docs/pod-spelling-t index 433d841..6993e4c 100755 --- a/tests/docs/pod-spelling-t +++ b/tests/docs/pod-spelling-t @@ -48,7 +48,7 @@ my @pod = map { $pod =~ s,[^/.][^/]*/../,,g; $pod; } qw(client/wallet.pod server/keytab-backend server/wallet-admin - server/wallet-backend); + server/wallet-backend server/wallet-report); plan tests => scalar @pod; # Finally, do the checks. diff --git a/tests/docs/pod-t b/tests/docs/pod-t index 9b6c5d1..f92ba2c 100755 --- a/tests/docs/pod-t +++ b/tests/docs/pod-t @@ -13,7 +13,7 @@ eval 'use Test::Pod 1.00'; plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; my @files = qw(client/wallet.pod server/keytab-backend server/wallet-admin - server/wallet-backend); + server/wallet-backend server/wallet-report); my $total = scalar (@files); plan tests => $total; for my $file (@files) { diff --git a/tests/server/admin-t b/tests/server/admin-t index 570dc52..5bde104 100755 --- a/tests/server/admin-t +++ b/tests/server/admin-t @@ -8,15 +8,14 @@ # See LICENSE for licensing terms. use strict; -use Test::More tests => 64; +use Test::More tests => 36; # Create a dummy class for Wallet::Admin that prints what method was called # with its arguments and returns data for testing. package Wallet::Admin; -use vars qw($empty $error); +use vars qw($error); $error = 0; -$empty = 0; sub error { if ($error) { @@ -44,19 +43,6 @@ sub initialize { return 1; } -sub list_objects { - print "list_objects\n"; - return if ($error or $empty); - return ([ keytab => 'host/windlord.stanford.edu' ], - [ file => 'unix-wallet-password' ]); -} - -sub list_acls { - print "list_acls\n"; - return if ($error or $empty); - return ([ 1, 'ADMIN' ], [ 2, 'group/admins' ], [ 4, 'group/users' ]); -} - sub register_object { shift; print "register_object @_\n"; @@ -71,13 +57,6 @@ sub register_verifier { return 1; } -sub report_owners { - shift; - print "report_owners @_\n"; - return if ($error or $empty); - return ([ krb5 => 'admin@EXAMPLE.COM' ]); -} - # Back to the main package and the actual test suite. Lie about whether the # Wallet::Admin package has already been loaded. package main; @@ -107,9 +86,7 @@ is ($out, "new\n", ' and nothing ran'); # Check too few and too many arguments for every command. my %commands = (destroy => [0, 0], initialize => [1, 1], - list => [1, 4], - register => [3, 3], - report => [1, -1]); + register => [3, 3]); for my $command (sort keys %commands) { my ($min, $max) = @{ $commands{$command} }; if ($min > 0) { @@ -159,22 +136,6 @@ is ($out, "new\n", ' and nothing was run'); is ($err, '', 'Initialize succeeds with a principal'); is ($out, "new\ninitialize rra\@stanford.edu\n", ' and runs the right code'); -# Test list. -($out, $err) = run_admin ('list', 'foo'); -is ($err, "only objects or acls are supported for list\n", - 'List requires a known object'); -is ($out, "new\n", ' and nothing was run'); -($out, $err) = run_admin ('list', 'objects'); -is ($err, '', 'List succeeds for objects'); -is ($out, "new\nlist_objects\n" - . "keytab host/windlord.stanford.edu\nfile unix-wallet-password\n", - ' and returns the right output'); -($out, $err) = run_admin ('list', 'acls'); -is ($err, '', 'List succeeds for ACLs'); -is ($out, "new\nlist_acls\n" - . "ADMIN (ACL ID: 1)\ngroup/admins (ACL ID: 2)\ngroup/users (ACL ID: 4)\n", - ' and returns the right output'); - # Test register. ($out, $err) = run_admin ('register', 'foo', 'foo', 'Foo::Bar'); is ($err, "only object or verifier is supported for register\n", @@ -189,15 +150,6 @@ is ($err, '', 'Register succeeds for verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and returns the right outout'); -# Test report. -($out, $err) = run_admin ('report', 'foo'); -is ($err, "unknown report type foo\n", 'Report requires a known report'); -is ($out, "new\n", ' and nothing was run'); -($out, $err) = run_admin ('report', 'owners', '%', '%'); -is ($err, '', 'Report succeeds for owners'); -is ($out, "new\nreport_owners % %\nkrb5 admin\@EXAMPLE.COM\n", - ' and returns the right output'); - # Test error handling. $Wallet::Admin::error = 1; ($out, $err) = run_admin ('destroy'); @@ -209,12 +161,6 @@ is ($out, "new\n" is ($err, "some error\n", 'Error handling succeeds for initialize'); is ($out, "new\ninitialize rra\@stanford.edu\n", ' and calls the right methods'); -($out, $err) = run_admin ('list', 'objects'); -is ($err, "some error\n", 'Error handling succeeds for list objects'); -is ($out, "new\nlist_objects\n", ' and calls the right methods'); -($out, $err) = run_admin ('list', 'acls'); -is ($err, "some error\n", 'Error handling succeeds for list acls'); -is ($out, "new\nlist_acls\n", ' and calls the right methods'); ($out, $err) = run_admin ('register', 'object', 'foo', 'Foo::Object'); is ($err, "some error\n", 'Error handling succeeds for register object'); is ($out, "new\nregister_object foo Foo::Object\n", @@ -223,19 +169,3 @@ is ($out, "new\nregister_object foo Foo::Object\n", is ($err, "some error\n", 'Error handling succeeds for register verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and calls the right methods'); -($out, $err) = run_admin ('report', 'owners', 'foo', 'bar'); -is ($err, "some error\n", 'Error handling succeeds for report owners'); -is ($out, "new\nreport_owners foo bar\n", ' and calls the right methods'); - -# Test empty lists. -$Wallet::Admin::error = 0; -$Wallet::Admin::empty = 1; -($out, $err) = run_admin ('list', 'objects'); -is ($err, '', 'list objects runs with an empty list with no errors'); -is ($out, "new\nlist_objects\n", ' and calls the right methods'); -($out, $err) = run_admin ('list', 'acls'); -is ($err, '', 'list acls runs with an empty list and no errors'); -is ($out, "new\nlist_acls\n", ' and calls the right methods'); -($out, $err) = run_admin ('report', 'owners', 'foo', 'bar'); -is ($err, '', 'report owners runs with an empty list and no errors'); -is ($out, "new\nreport_owners foo bar\n", ' and calls the right methods'); diff --git a/tests/server/report-t b/tests/server/report-t new file mode 100755 index 0000000..285ee5a --- /dev/null +++ b/tests/server/report-t @@ -0,0 +1,151 @@ +#!/usr/bin/perl -w +# +# Tests for the wallet-report dispatch code. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +use strict; +use Test::More tests => 32; + +# Create a dummy class for Wallet::Report that prints what method was called +# with its arguments and returns data for testing. +package Wallet::Report; + +use vars qw($empty $error); +$error = 0; +$empty = 0; + +sub error { + if ($error) { + return "some error"; + } else { + return; + } +} + +sub new { + print "new\n"; + return bless ({}, 'Wallet::Report'); +} + +sub acls { + shift; + print "acls @_\n"; + return if ($error or $empty); + return ([ 1, 'ADMIN' ], [ 2, 'group/admins' ], [ 4, 'group/users' ]); +} + +sub objects { + shift; + print "objects @_\n"; + return if ($error or $empty); + return ([ keytab => 'host/windlord.stanford.edu' ], + [ file => 'unix-wallet-password' ]); +} + +sub owners { + shift; + print "owners @_\n"; + return if ($error or $empty); + return ([ krb5 => 'admin@EXAMPLE.COM' ]); +} + +# Back to the main package and the actual test suite. Lie about whether the +# Wallet::Report package has already been loaded. +package main; +$INC{'Wallet/Report.pm'} = 'FAKE'; +eval { do "$ENV{SOURCE}/../server/wallet-report" }; + +# Run the wallet report client. This fun hack takes advantage of the fact +# that the wallet report client is written in Perl so that we can substitute +# our own Wallet::Report class. +sub run_report { + my (@args) = @_; + my $result = ''; + open (OUTPUT, '>', \$result) or die "cannot create output string: $!\n"; + select OUTPUT; + local $| = 1; + eval { command (@args) }; + my $error = $@; + select STDOUT; + return ($result, $error); +} + +# Now for the actual tests. First check for unknown commands. +my ($out, $err) = run_report ('foo'); +is ($err, "unknown command foo\n", 'Unknown command'); +is ($out, "new\n", ' and nothing ran'); + +# Check too few and too many arguments for every command. +my %commands = (acls => [0, 3], + objects => [0, 2], + owners => [2, 2]); +for my $command (sort keys %commands) { + my ($min, $max) = @{ $commands{$command} }; + if ($min > 0) { + ($out, $err) = run_report ($command, ('foo') x ($min - 1)); + is ($err, "too few arguments to $command\n", + "Too few arguments for $command"); + is ($out, "new\n", ' and nothing ran'); + } + if ($max >= 0) { + ($out, $err) = run_report ($command, ('foo') x ($max + 1)); + is ($err, "too many arguments to $command\n", + "Too many arguments for $command"); + is ($out, "new\n", ' and nothing ran'); + } +} + +# Test the report methods. +($out, $err) = run_report ('acls'); +is ($err, '', 'List succeeds for ACLs'); +is ($out, "new\nacls \n" + . "ADMIN (ACL ID: 1)\ngroup/admins (ACL ID: 2)\ngroup/users (ACL ID: 4)\n", + ' and returns the right output'); +($out, $err) = run_report ('acls', 'entry', 'foo', 'foo'); +is ($err, '', 'List succeeds for ACLs'); +is ($out, "new\nacls entry foo foo\n" + . "ADMIN (ACL ID: 1)\ngroup/admins (ACL ID: 2)\ngroup/users (ACL ID: 4)\n", + ' and returns the right output'); +($out, $err) = run_report ('objects'); +is ($err, '', 'List succeeds for objects'); +is ($out, "new\nobjects \n" + . "keytab host/windlord.stanford.edu\nfile unix-wallet-password\n", + ' and returns the right output'); +($out, $err) = run_report ('objects', 'type', 'foo'); +is ($err, '', 'List succeeds for objects type foo'); +is ($out, "new\nobjects type foo\n" + . "keytab host/windlord.stanford.edu\nfile unix-wallet-password\n", + ' and returns the right output'); +($out, $err) = run_report ('owners', '%', '%'); +is ($err, '', 'Report succeeds for owners'); +is ($out, "new\nowners % %\nkrb5 admin\@EXAMPLE.COM\n", + ' and returns the right output'); + +# Test error handling. +$Wallet::Report::error = 1; +($out, $err) = run_report ('acls'); +is ($err, "some error\n", 'Error handling succeeds for list acls'); +is ($out, "new\nacls \n", ' and calls the right methods'); +($out, $err) = run_report ('objects'); +is ($err, "some error\n", 'Error handling succeeds for list objects'); +is ($out, "new\nobjects \n", ' and calls the right methods'); +($out, $err) = run_report ('owners', 'foo', 'bar'); +is ($err, "some error\n", 'Error handling succeeds for report owners'); +is ($out, "new\nowners foo bar\n", ' and calls the right methods'); + +# Test empty lists. +$Wallet::Report::error = 0; +$Wallet::Report::empty = 1; +($out, $err) = run_report ('acls'); +is ($err, '', 'list acls runs with an empty list and no errors'); +is ($out, "new\nacls \n", ' and calls the right methods'); +($out, $err) = run_report ('objects'); +is ($err, '', 'list objects runs with an empty list with no errors'); +is ($out, "new\nobjects \n", ' and calls the right methods'); +($out, $err) = run_report ('owners', 'foo', 'bar'); +is ($err, '', 'report owners runs with an empty list and no errors'); +is ($out, "new\nowners foo bar\n", ' and calls the right methods'); -- cgit v1.2.3 From c4234b72a39b25122dbba769e028d1d105a4132e Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Sat, 20 Feb 2010 23:19:50 -0800 Subject: Fix some test numbers in the Perl tests --- perl/t/kadmin.t | 2 +- perl/t/keytab.t | 9 ++++----- 2 files changed, 5 insertions(+), 6 deletions(-) (limited to 'perl/t') diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index b9ac769..bbcb15a 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -72,7 +72,7 @@ SKIP: { # implementation is configured. This retests some things that are also tested # by the keytab test, but specifically through the Wallet::Kadmin API. SKIP: { - skip 'no keytab configuration', 15 unless -f 't/data/test.keytab'; + skip 'no keytab configuration', 14 unless -f 't/data/test.keytab'; # Set up our configuration. $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 4e253eb..046da9c 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -148,7 +148,7 @@ my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); # Basic keytab creation and manipulation tests. SKIP: { - skip 'no keytab configuration', 49 unless -f 't/data/test.keytab'; + skip 'no keytab configuration', 52 unless -f 't/data/test.keytab'; # Set up our configuration. $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; @@ -495,7 +495,7 @@ EOO # since no synchronization targets are supported, but we want to still test # the basic stub code. SKIP: { - skip 'no keytab configuration', 106 unless -f 't/data/test.keytab'; + skip 'no keytab configuration', 18 unless -f 't/data/test.keytab'; # Test setting synchronization attributes, which can also be done without # configuration. @@ -563,9 +563,7 @@ EOO # Tests for enctype restriction. SKIP: { - unless (-f 't/data/test.keytab') { - skip 'no keytab configuration', 36; - } + skip 'no keytab configuration', 36 unless -f 't/data/test.keytab'; # Set up our configuration. $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; @@ -648,6 +646,7 @@ EOO # Now, try testing limiting the enctypes to just one. SKIP: { skip 'insufficient recognized enctypes', 14 unless @enctypes > 1; + is ($one->attr ('enctypes', [ $enctypes[0] ], @trace), 1, 'Setting a single enctype works'); for my $enctype (@enctypes) { -- cgit v1.2.3 From d04d26c6e447727cd43bd2182182117ec7302dc7 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Sun, 21 Feb 2010 20:58:27 -0800 Subject: Fix test suite skip numbering in the kadmin test --- perl/t/kadmin.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'perl/t') diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index bbcb15a..6365ce5 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -56,7 +56,7 @@ for my $good (qw{service service/foo bar foo/bar host/example.org # configuration to get the error. That tests that we can find the Heimdal # module and it dies how it should. SKIP: { - skip 'Heimdal::Kadm5 not installed', 3 unless $heimdal_kadm5; + skip 'Heimdal::Kadm5 not installed', 2 unless $heimdal_kadm5; undef $Wallet::Config::KEYTAB_PRINCIPAL; undef $Wallet::Config::KEYTAB_FILE; undef $Wallet::Config::KEYTAB_REALM; -- cgit v1.2.3 From 69289862465a3bfb3488c1b3a674b6b06c9911ee Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 3 Mar 2010 19:49:46 -0800 Subject: Remove file names from test file headers Coding style update. Don't prefix the file short description with the file name; it's not needed. --- perl/t/acl.t | 2 +- perl/t/admin.t | 2 +- perl/t/config.t | 2 +- perl/t/data/keytab-fake | 2 +- perl/t/data/netdb-fake | 2 +- perl/t/file.t | 2 +- perl/t/init.t | 2 +- perl/t/kadmin.t | 2 +- perl/t/keytab.t | 2 +- perl/t/lib/Util.pm | 4 ++-- perl/t/object.t | 2 +- perl/t/pod-spelling.t | 3 +-- perl/t/report.t | 2 +- perl/t/schema.t | 2 +- perl/t/server.t | 2 +- perl/t/verifier-netdb.t | 10 +++++----- perl/t/verifier.t | 6 +++--- tests/data/fake-kadmin | 3 ++- tests/data/wallet.conf | 2 +- 19 files changed, 27 insertions(+), 27 deletions(-) (limited to 'perl/t') diff --git a/perl/t/acl.t b/perl/t/acl.t index 95aa763..f169eb5 100755 --- a/perl/t/acl.t +++ b/perl/t/acl.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/api.t -- Tests for the wallet ACL API. +# Tests for the wallet ACL API. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/admin.t b/perl/t/admin.t index e22088e..074dbc6 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/admin.t -- Tests for wallet administrative interface. +# Tests for wallet administrative interface. # # Written by Russ Allbery # Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/config.t b/perl/t/config.t index 1377cb8..6b9f226 100755 --- a/perl/t/config.t +++ b/perl/t/config.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/config.t -- Tests for the wallet server configuration. +# Tests for the wallet server configuration. # # Written by Russ Allbery # Copyright 2008, 2010 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/data/keytab-fake b/perl/t/data/keytab-fake index 0ecf264..f4f0fb3 100755 --- a/perl/t/data/keytab-fake +++ b/perl/t/data/keytab-fake @@ -1,6 +1,6 @@ #!/bin/sh # -# keytab-fake -- Fake keytab-backend implementation. +# Fake keytab-backend implementation. # # This keytab-fake script is meant to be run by remctld during testing of # the keytab object implementation. It returns a fixed string for diff --git a/perl/t/data/netdb-fake b/perl/t/data/netdb-fake index ae5be18..9624102 100755 --- a/perl/t/data/netdb-fake +++ b/perl/t/data/netdb-fake @@ -1,6 +1,6 @@ #!/bin/sh # -# netdb-fake -- Fake NetDB remctl interface. +# Fake NetDB remctl interface. # # This netdb-fake script is meant to be run by remctld during testing of # the NetDB ACL verifier. It returns known roles or errors for different diff --git a/perl/t/file.t b/perl/t/file.t index 7ab5d75..a821c4f 100755 --- a/perl/t/file.t +++ b/perl/t/file.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/file.t -- Tests for the file object implementation. +# Tests for the file object implementation. # # Written by Russ Allbery # Copyright 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/init.t b/perl/t/init.t index d0fae9f..213aedf 100755 --- a/perl/t/init.t +++ b/perl/t/init.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/init.t -- Tests for database initialization. +# Tests for database initialization. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index 6365ce5..0b52528 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/kadmin.t -- Tests for the kadmin object implementation. +# Tests for the kadmin object implementation. # # Written by Jon Robertson # Copyright 2009, 2010 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 046da9c..b16cea5 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/keytab.t -- Tests for the keytab object implementation. +# Tests for the keytab object implementation. # # Written by Russ Allbery # Copyright 2007, 2008, 2009, 2010 diff --git a/perl/t/lib/Util.pm b/perl/t/lib/Util.pm index ab88b39..44a4d21 100644 --- a/perl/t/lib/Util.pm +++ b/perl/t/lib/Util.pm @@ -1,4 +1,4 @@ -# Util -- Utility class for wallet tests. +# Utility class for wallet tests. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University @@ -16,7 +16,7 @@ use Wallet::Config; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.02'; +$VERSION = '0.03'; use Exporter (); @ISA = qw(Exporter); diff --git a/perl/t/object.t b/perl/t/object.t index 46e67e5..3949786 100755 --- a/perl/t/object.t +++ b/perl/t/object.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/object.t -- Tests for the basic object implementation. +# Tests for the basic object implementation. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/pod-spelling.t b/perl/t/pod-spelling.t index d3ab858..6d9f7b0 100755 --- a/perl/t/pod-spelling.t +++ b/perl/t/pod-spelling.t @@ -9,8 +9,7 @@ # # Copyright 2008, 2009 Russ Allbery # -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. +# See LICENSE for licensing terms. use strict; use Test::More; diff --git a/perl/t/report.t b/perl/t/report.t index a18b995..a37681a 100755 --- a/perl/t/report.t +++ b/perl/t/report.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/report.t -- Tests for the wallet reporting interface. +# Tests for the wallet reporting interface. # # Written by Russ Allbery # Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/schema.t b/perl/t/schema.t index 559ece4..7f0aea4 100755 --- a/perl/t/schema.t +++ b/perl/t/schema.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/schema.t -- Tests for the wallet schema class. +# Tests for the wallet schema class. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/server.t b/perl/t/server.t index 090387b..7b30053 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/server.t -- Tests for the wallet server API. +# Tests for the wallet server API. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/verifier-netdb.t b/perl/t/verifier-netdb.t index dcbbdd8..6bd4e73 100755 --- a/perl/t/verifier-netdb.t +++ b/perl/t/verifier-netdb.t @@ -1,15 +1,15 @@ #!/usr/bin/perl -w # -# t/verifier-netdb.t -- Tests for the NetDB wallet ACL verifiers. +# Tests for the NetDB wallet ACL verifiers. +# +# This test can only be run by someone local to Stanford with appropriate +# access to the NetDB role server and will be skipped in all other +# environments. # # Written by Russ Allbery # Copyright 2008 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. -# -# This test can only be run by someone local to Stanford with appropriate -# access to the NetDB role server and will be skipped in all other -# environments. use Test::More tests => 4; diff --git a/perl/t/verifier.t b/perl/t/verifier.t index 3243d9c..74d7ba8 100755 --- a/perl/t/verifier.t +++ b/perl/t/verifier.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/verifier.t -- Tests for the basic wallet ACL verifiers. +# Tests for the basic wallet ACL verifiers. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University @@ -39,8 +39,8 @@ 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'); -# Tests for unchanging support. Skip these if we don't have a keytab or if we -# can't find remctld. +# Tests for the NetDB verifiers. Skip these if we don't have a keytab or if +# we can't find remctld. SKIP: { skip 'no keytab configuration', 34 unless -f 't/data/test.keytab'; my @path = (split (':', $ENV{PATH}), '/usr/local/sbin', '/usr/sbin'); diff --git a/tests/data/fake-kadmin b/tests/data/fake-kadmin index 61906a4..4c0ceac 100755 --- a/tests/data/fake-kadmin +++ b/tests/data/fake-kadmin @@ -1,9 +1,10 @@ #!/usr/bin/perl -w # -# fake-kadmin -- Fake kadmin.local used to test the keytab backend. +# Fake kadmin.local used to test the keytab backend. # # Written by Russ Allbery # Copyright 2007 Board of Trustees, Leland Stanford Jr. University +# # See LICENSE for licensing terms. unless ($ARGV[0] eq '-q' && @ARGV == 2) { diff --git a/tests/data/wallet.conf b/tests/data/wallet.conf index 0a232dd..877a16f 100644 --- a/tests/data/wallet.conf +++ b/tests/data/wallet.conf @@ -1,4 +1,4 @@ -# wallet.conf -- Test wallet server configuration. -*- perl -*- +# Test wallet server configuration. -*- perl -*- # Always test with SQLite. $DB_DRIVER = 'SQLite'; -- cgit v1.2.3 From 6c1f7d325239f305b9bf6a4503165cefae1ee3d8 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 3 Mar 2010 21:06:41 -0800 Subject: Verify that an ACL to be deleted is not referenced When deleting an ACL on the server, verify that the ACL is not referenced by any object first. Database referential integrity should also catch this, but not all database backends may enforce referential integrity. This also allows us to return a better error message naming an object that's still using that ACL. --- NEWS | 6 ++++++ perl/Wallet/ACL.pm | 32 +++++++++++++++++++++++--------- perl/t/server.t | 17 ++++++++++++++++- 3 files changed, 45 insertions(+), 10 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index 9800390..e66d1b3 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,12 @@ wallet 0.11 (unreleased) + When deleting an ACL on the server, verify that the ACL is not + referenced by any object first. Database referential integrity should + also catch this, but not all database backends may enforce referential + integrity. This also allows us to return a better error message + naming an object that's still using that ACL. + Fix portability to older Kerberos libraries without krb5_free_error_message. diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm index 76e7354..44a82b2 100644 --- a/perl/Wallet/ACL.pm +++ b/perl/Wallet/ACL.pm @@ -21,7 +21,7 @@ use POSIX qw(strftime); # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.06'; +$VERSION = '0.07'; ############################################################################## # Constructors @@ -191,11 +191,25 @@ sub rename { # Destroy the ACL, deleting it out of the database. Returns true on success, # false on failure. +# +# Checks to ensure that the ACL is not referenced anywhere in the database, +# since we may not have referential integrity enforcement. It's not clear +# that this is the right place to do this; it's a bit of an abstraction +# violation, since it's a query against the object table. sub destroy { my ($self, $user, $host, $time) = @_; $time ||= time; eval { - my $sql = 'delete from acl_entries where ae_id = ?'; + 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]"; + } + $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}); @@ -525,13 +539,13 @@ array context and undef in scalar context. =item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) -Destroys this ACL from the database. Note that this will fail due to -integrity constraint errors if the ACL is still referenced by any object; -the ACL must be removed from all objects first. Returns true on success -and false on failure. On failure, the caller should call error() to get -the error message. PRINCIPAL, HOSTNAME, and DATETIME are stored as -history information. PRINCIPAL should be the user who is destroying the -ACL. If DATETIME isn't given, the current time is used. +Destroys this ACL from the database. Note that this will fail if the ACL +is still referenced by any object; the ACL must be removed from all +objects first. Returns true on success and false on failure. On failure, +the caller should call error() to get the error message. PRINCIPAL, +HOSTNAME, and DATETIME are stored as history information. PRINCIPAL +should be the user who is destroying the ACL. If DATETIME isn't given, +the current time is used. =item error() diff --git a/perl/t/server.t b/perl/t/server.t index 7b30053..2a178e8 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -7,7 +7,7 @@ # # See LICENSE for licensing terms. -use Test::More tests => 341; +use Test::More tests => 349; use POSIX qw(strftime); use Wallet::Admin; @@ -923,6 +923,21 @@ is ($server->error, 'base:host/default.stanford.edu rejected: host' . ' default.stanford.edu not in .example.edu domain', ' with the right error'); +# Ensure that we can't destroy an ACL that's in use. +is ($server->acl_create ('test-destroy'), 1, 'Creating an ACL works'); +is ($server->create ('base', 'service/acl-user'), 1, 'Creating object works'); +is ($server->owner ('base', 'service/acl-user', 'test-destroy'), 1, + ' and setting owner'); +is ($server->acl_destroy ('test-destroy'), undef, + ' and now we cannot destroy that ACL'); +is ($server->error, + 'cannot destroy ACL 9: ACL in use by base:service/acl-user', + ' with the right error'); +is ($server->owner ('base', 'service/acl-user', ''), 1, + ' but after we clear the owner'); +is ($server->acl_destroy ('test-destroy'), 1, ' now we can destroy the ACL'); +is ($server->destroy ('base', 'service/acl-user'), 1, ' and the object'); + # Clean up. $setup->destroy; unlink 'wallet-db'; -- cgit v1.2.3 From a131c767d1eee7b98170962f7f9d4063be69e576 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 3 Mar 2010 22:37:18 -0800 Subject: Add auditing for names that violate the naming policy Add an audit command to wallet-report and one audit: objects name, which returns all objects that do not pass the local naming policy. The corresponding Wallet::Report method is audit(). Wallet::Config::verify_name may now be called with an undefined third argument (normally the user attempting to create an object). This calling convention is used when auditing, and the local policy function should select the correct policy to apply for useful audit results. --- NEWS | 10 ++++++++++ perl/Wallet/Config.pm | 11 ++++++++++- perl/Wallet/Report.pm | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++- perl/t/report.t | 25 +++++++++++++++++++++++- server/wallet-report | 19 ++++++++++++++++++ tests/server/report-t | 32 +++++++++++++++++++++++------- 6 files changed, 141 insertions(+), 10 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index e66d1b3..03fe99b 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,16 @@ wallet 0.11 (unreleased) integrity. This also allows us to return a better error message naming an object that's still using that ACL. + Add an audit command to wallet-report and one audit: objects name, + which returns all objects that do not pass the local naming policy. + The corresponding Wallet::Report method is audit(). + + Wallet::Config::verify_name may now be called with an undefined third + argument (normally the user attempting to create an object). This + calling convention is used when auditing, and the local policy + function should select the correct policy to apply for useful audit + results. + Fix portability to older Kerberos libraries without krb5_free_error_message. diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index 396bf7d..2991361 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -14,7 +14,7 @@ use vars qw($PATH $VERSION); # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -$VERSION = '0.04'; +$VERSION = '0.05'; # Path to the config file to load. $PATH = $ENV{WALLET_CONFIG} || '/etc/wallet/wallet.conf'; @@ -519,6 +519,15 @@ creation. If it returns undef or the empty string, object creation will be allowed. If it returns anything else, object creation is rejected and the return value is used as the error message. +This function is also called for naming audits done via Wallet::Report +to find any existing objects that violate a (possibly updated) naming +policy. In this case, the third argument (the identity of the person +creating the object) will be undef. As a general rule, if the third +argument is undef, the function should apply the most liberal accepted +naming policy so that the audit returns only objects that violate all +naming policies, but some sites may wish different results for their audit +reports. + Please note that this return status is backwards from what one would normally expect. A false value is success; a true value is failure with an error message. diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index 7cd8653..ff4fa8b 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -20,7 +20,7 @@ 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.01'; +$VERSION = '0.02'; ############################################################################## # Constructor, destructor, and accessors @@ -290,6 +290,43 @@ sub owners { return @lines; } +############################################################################## +# Auditing +############################################################################## + +# Audit the database for violations of local policy. Returns a list of +# objects (as type and name pairs) or a list of ACLs. On error and for no +# matching entries, the empty list will be returned. To distinguish between +# an empty return and an error, call error(), which will return undef if there +# was no error. +sub audit { + my ($self, $type, $audit) = @_; + undef $self->{error}; + unless (defined ($type) and defined ($audit)) { + $self->error ("type and audit not specified"); + return; + } + if ($type eq 'objects') { + if ($audit eq 'name') { + return unless defined &Wallet::Config::verify_name; + my @objects = $self->objects; + my @results; + for my $object (@objects) { + my ($type, $name) = @$object; + my $error = Wallet::Config::verify_name ($type, $name); + push (@results, $object) if $error; + } + return @results; + } else { + $self->error ("unknown object audit: $audit"); + return; + } + } else { + $self->error ("unknown audit type: $type"); + return; + } +} + 1; __DATA__ @@ -312,6 +349,7 @@ ACL ACLs wildcard Allbery SQL tuples for my $object (@objects) { print "@$object\n"; } + @objects = $report->audit ('objects', 'name'); =head1 DESCRIPTION @@ -366,6 +404,20 @@ Returns the empty list on failure. An error can be distinguished from empty search results by calling error(). error() is guaranteed to return the error message if there was an error and undef if there was no error. +=item audit(TYPE, AUDIT) + +Audits the wallet database for violations of local policy. TYPE is the +general class of thing to audit, and AUDIT is the specific audit to +perform. Currently, the only implemented type is C and the only +audit is C. This returns a list of all objects, as references to +pairs of type and name, that are not accepted by the verify_name() +function defined in the wallet configuration. See L for +more information. + +Returns the empty list on failure. An error can be distinguished from +empty search results by calling error(). error() is guaranteed to return +the error message if there was an error and undef if there was no error. + =item error() Returns the error of the last failing operation or undef if no operations diff --git a/perl/t/report.t b/perl/t/report.t index a37681a..3b94d00 100755 --- a/perl/t/report.t +++ b/perl/t/report.t @@ -7,7 +7,7 @@ # # See LICENSE for licensing terms. -use Test::More tests => 83; +use Test::More tests => 88; use Wallet::Admin; use Wallet::Report; @@ -166,6 +166,29 @@ is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, is (scalar (@lines), 0, ' and now there are no objects in the report'); is ($report->error, undef, ' with no error'); +# The naming audit returns nothing if there's no naming policy. +@lines = $report->audit ('objects', 'name'); +is (scalar (@lines), 0, 'Searching for naming violations finds none'); +is ($report->error, undef, ' with no error'); + +# Set a naming policy and then look for objects that fail that policy. We +# have to deactivate this policy until now so that it doesn't prevent the +# creation of that name originally, which is the reason for the variable +# reference. +our $naming_active = 1; +package Wallet::Config; +sub verify_name { + my ($type, $name) = @_; + return unless $naming_active; + return 'admin not allowed' if $name eq 'service/admin'; + return; +} +package main; +@lines = $report->audit ('objects', 'name'); +is (scalar (@lines), 1, 'Searching for naming violations finds one'); +is ($lines[0][0], 'base', ' and the first has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); + # Clean up. $admin->destroy; unlink 'wallet-db'; diff --git a/server/wallet-report b/server/wallet-report index a6b3b8d..caa7e2c 100755 --- a/server/wallet-report +++ b/server/wallet-report @@ -35,6 +35,16 @@ sub command { for my $acl (sort { $$a[1] cmp $$b[1] } @acls) { print "$$acl[1] (ACL ID: $$acl[0])\n"; } + } elsif ($command eq 'audit') { + die "too many arguments to audit\n" if @args > 2; + die "too few arguments to audit\n" if @args < 2; + my @objects = $report->audit (@args); + if (!@objects and $report->error) { + die $report->error, "\n"; + } + for my $object (@objects) { + print join (' ', @$object), "\n"; + } } elsif ($command eq 'objects') { die "too many arguments to objects\n" if @args > 2; my @objects = $report->objects (@args); @@ -129,6 +139,15 @@ any identifier containing that string. =back +=item audit objects name + +Returns all objects that violate the current site naming policy. Objects +will be listed in the form: + + + +There will be one line per object. + =item objects =item objects acl diff --git a/tests/server/report-t b/tests/server/report-t index 285ee5a..61cfd9b 100755 --- a/tests/server/report-t +++ b/tests/server/report-t @@ -8,7 +8,7 @@ # See LICENSE for licensing terms. use strict; -use Test::More tests => 32; +use Test::More tests => 42; # Create a dummy class for Wallet::Report that prints what method was called # with its arguments and returns data for testing. @@ -38,6 +38,13 @@ sub acls { return ([ 1, 'ADMIN' ], [ 2, 'group/admins' ], [ 4, 'group/users' ]); } +sub audit { + shift; + print "audit @_\n"; + return if ($error or $empty); + return ([ file => 'unix-wallet-password' ]); +} + sub objects { shift; print "objects @_\n"; @@ -81,6 +88,7 @@ is ($out, "new\n", ' and nothing ran'); # Check too few and too many arguments for every command. my %commands = (acls => [0, 3], + audit => [2, 2], objects => [0, 2], owners => [2, 2]); for my $command (sort keys %commands) { @@ -110,6 +118,10 @@ is ($err, '', 'List succeeds for ACLs'); is ($out, "new\nacls entry foo foo\n" . "ADMIN (ACL ID: 1)\ngroup/admins (ACL ID: 2)\ngroup/users (ACL ID: 4)\n", ' and returns the right output'); +($out, $err) = run_report ('audit', 'objects', 'name'); +is ($err, '', 'Audit report succeeds'); +is ($out, "new\naudit objects name\nfile unix-wallet-password\n", + ' and returns the right output'); ($out, $err) = run_report ('objects'); is ($err, '', 'List succeeds for objects'); is ($out, "new\nobjects \n" @@ -128,24 +140,30 @@ is ($out, "new\nowners % %\nkrb5 admin\@EXAMPLE.COM\n", # Test error handling. $Wallet::Report::error = 1; ($out, $err) = run_report ('acls'); -is ($err, "some error\n", 'Error handling succeeds for list acls'); +is ($err, "some error\n", 'Error handling succeeds for acls'); is ($out, "new\nacls \n", ' and calls the right methods'); +($out, $err) = run_report ('audit', 'objects', 'name'); +is ($err, "some error\n", 'Error handling succeeds for audit'); +is ($out, "new\naudit objects name\n", ' and calls the right methods'); ($out, $err) = run_report ('objects'); -is ($err, "some error\n", 'Error handling succeeds for list objects'); +is ($err, "some error\n", 'Error handling succeeds for objects'); is ($out, "new\nobjects \n", ' and calls the right methods'); ($out, $err) = run_report ('owners', 'foo', 'bar'); -is ($err, "some error\n", 'Error handling succeeds for report owners'); +is ($err, "some error\n", 'Error handling succeeds for owners'); is ($out, "new\nowners foo bar\n", ' and calls the right methods'); # Test empty lists. $Wallet::Report::error = 0; $Wallet::Report::empty = 1; ($out, $err) = run_report ('acls'); -is ($err, '', 'list acls runs with an empty list and no errors'); +is ($err, '', 'acls runs with an empty list and no errors'); is ($out, "new\nacls \n", ' and calls the right methods'); +($out, $err) = run_report ('audit', 'objects', 'name'); +is ($err, '', 'audit runs with an empty list and no errors'); +is ($out, "new\naudit objects name\n", ' and calls the right methods'); ($out, $err) = run_report ('objects'); -is ($err, '', 'list objects runs with an empty list with no errors'); +is ($err, '', 'objects runs with an empty list with no errors'); is ($out, "new\nobjects \n", ' and calls the right methods'); ($out, $err) = run_report ('owners', 'foo', 'bar'); -is ($err, '', 'report owners runs with an empty list and no errors'); +is ($err, '', 'owners runs with an empty list and no errors'); is ($out, "new\nowners foo bar\n", ' and calls the right methods'); -- cgit v1.2.3 From 2948d66c4c074651820004856284faf7d018a3ee Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 5 Mar 2010 14:18:10 -0800 Subject: Don't clobber the user ticket cache in the kadmin test --- perl/t/kadmin.t | 3 +++ 1 file changed, 3 insertions(+) (limited to 'perl/t') diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index 0b52528..e5fb2fa 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -81,6 +81,9 @@ SKIP: { $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); $Wallet::Config::KEYTAB_TMP = '.'; + # Don't destroy the user's Kerberos ticket cache. + $ENV{KRB5CCNAME} = 'krb5cc_test'; + # Create the object and clean up the principal we're going to use. $kadmin = eval { Wallet::Kadmin->new }; ok (defined $kadmin, 'Creating Wallet::Kadmin object succeeds'); -- cgit v1.2.3 From 0e3df4c4159650e6de7fdcf6a0f0b661f25c03f7 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 5 Mar 2010 16:56:47 -0800 Subject: Add a report of unused ACLs Add the acls unused report to wallet-report and Wallet::Report, returning all ACLs not referenced by any database objects. --- NEWS | 3 +++ perl/Wallet/Report.pm | 24 ++++++++++++++++++++---- perl/t/report.t | 37 ++++++++++++++++++++++++++++++++++++- server/wallet-report | 7 +++++++ 4 files changed, 66 insertions(+), 5 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index 03fe99b..e41b86e 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,9 @@ wallet 0.11 (unreleased) which returns all objects that do not pass the local naming policy. The corresponding Wallet::Report method is audit(). + Add the acls unused report to wallet-report and Wallet::Report, + returning all ACLs not referenced by any database objects. + Wallet::Config::verify_name may now be called with an undefined third argument (normally the user attempting to create an object). This calling convention is used when auditing, and the local policy diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index 462cd6f..f6e6753 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -195,7 +195,8 @@ sub acls_all { 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'; + on (acls.ac_id = acl_entries.ae_id) where ae_id is null order by + ac_id'; return ($sql); } @@ -210,6 +211,18 @@ sub acls_entry { return ($sql, $type, '%' . $identifier . '%'); } +# 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)"; + } + return ($sql); +} + # 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 @@ -234,8 +247,10 @@ sub acls { } } elsif ($type eq 'empty') { ($sql) = $self->acls_empty; + } elsif ($type eq 'unused') { + ($sql) = $self->acls_unused; } else { - $self->error ("do not know search type: $type"); + $self->error ("unknown search type: $type"); return; } } @@ -387,11 +402,12 @@ 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 two search types. C takes no arguments and will return +currently three search types. C takes no arguments and will return only those ACLs that have no entries within them. C 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. +identifier containing that value. C 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 and diff --git a/perl/t/report.t b/perl/t/report.t index 3b94d00..b283576 100755 --- a/perl/t/report.t +++ b/perl/t/report.t @@ -7,7 +7,7 @@ # # See LICENSE for licensing terms. -use Test::More tests => 88; +use Test::More tests => 148; use Wallet::Admin; use Wallet::Report; @@ -166,6 +166,41 @@ is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, is (scalar (@lines), 0, ' and now there are no objects in the report'); is ($report->error, undef, ' with no error'); +# All of our ACLs should be in use. +@lines = $report->acls ('unused'); +is (scalar (@lines), 0, 'Searching for unused ACLs returns nothing'); +is ($report->error, undef, ' with no error'); + +# Create some unused ACLs that should show up in the report. +is ($server->acl_create ('third'), 1, 'Creating an empty ACL succeeds'); +is ($server->acl_create ('fourth'), 1, ' and creating another succeeds'); +@lines = $report->acls ('unused'); +is (scalar (@lines), 2, ' and now we see two unused ACLs'); +is ($server->error, undef, ' with no error'); +is ($lines[0][0], 4, ' and the first has the right ID'); +is ($lines[0][1], 'third', ' and the right name'); +is ($lines[1][0], 5, ' and the second has the right ID'); +is ($lines[1][1], 'fourth', ' and the right name'); + +# Use one of those ACLs and ensure it drops out of the report. Test that we +# try all of the possible ACL types. +for my $type (qw/get store show destroy flags/) { + is ($server->acl ('base', 'service/admin', $type, 'fourth'), 1, + "Setting ACL $type to fourth succeeds"); + @lines = $report->acls ('unused'); + is (scalar (@lines), 1, ' and now we see only one unused ACL'); + is ($lines[0][0], 4, ' with the right ID'); + is ($lines[0][1], 'third', ' and the right name'); + is ($server->acl ('base', 'service/admin', $type, ''), 1, + ' and clearing the ACL succeeds'); + @lines = $report->acls ('unused'); + is (scalar (@lines), 2, ' and now we see two unused ACLs'); + is ($lines[0][0], 4, ' and the first has the right ID'); + is ($lines[0][1], 'third', ' and the right name'); + is ($lines[1][0], 5, ' and the second has the right ID'); + is ($lines[1][1], 'fourth', ' and the right name'); +} + # The naming audit returns nothing if there's no naming policy. @lines = $report->audit ('objects', 'name'); is (scalar (@lines), 0, 'Searching for naming violations finds none'); diff --git a/server/wallet-report b/server/wallet-report index 610e278..2b7cd45 100755 --- a/server/wallet-report +++ b/server/wallet-report @@ -110,6 +110,8 @@ B takes no traditional options. =item acls entry +=item acls unused + Returns a list of ACLs in the database. ACLs will be listed in the form: (ACL ID: ) @@ -137,6 +139,11 @@ Returns all ACLs containing an entry with given scheme and identifier. The scheme must be an exact match, but the string will match any identifier containing that string. +=item acls unused + +Returns all ACLs that are not referenced by any of the objects in the +wallet database, either as an owner or on one of the more specific ACLs. + =back =item audit objects name -- cgit v1.2.3 From fd7f47ed7dccb3ee01ddaa7e24b8bd7bffb6a1c6 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 5 Mar 2010 17:25:50 -0800 Subject: Allow naming policy enforcement for ACL names Wallet::Config now supports an additional local function, verify_acl_name, which can be used to enforce ACL naming policies. If set, it is called for any ACL creation or rename and can reject the new ACL name. --- NEWS | 5 +++++ perl/Wallet/Config.pm | 41 ++++++++++++++++++++++++++++++++++++++--- perl/Wallet/Server.pm | 18 ++++++++++++++++-- perl/t/server.t | 24 ++++++++++++++++++++++-- 4 files changed, 81 insertions(+), 7 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index e41b86e..1f63e07 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,11 @@ wallet 0.11 (unreleased) integrity. This also allows us to return a better error message naming an object that's still using that ACL. + Wallet::Config now supports an additional local function, + verify_acl_name, which can be used to enforce ACL naming policies. If + set, it is called for any ACL creation or rename and can reject the + new ACL name. + Add an audit command to wallet-report and one audit: objects name, which returns all objects that do not pass the local naming policy. The corresponding Wallet::Report method is audit(). diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index c86fb80..e4014a1 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -513,8 +513,8 @@ By default, wallet permits administrators to create objects of any name (unless the object backend rejects the name). However, naming standards for objects can be enforced, even for administrators, by defining a Perl function in the configuration file named verify_name. If such a function -exists, it will be called for any object creation and given the type of -object, the object name, and the identity of the person doing the +exists, it will be called for any object creation and will be passed the +type of object, the object name, and the identity of the person doing the creation. If it returns undef or the empty string, object creation will be allowed. If it returns anything else, object creation is rejected and the return value is used as the error message. @@ -549,7 +549,42 @@ keytab objects for particular principals have fully-qualified hostnames: } Objects that aren't of type C or which aren't for a host-based key -have no naming requirements enforced. +have no naming requirements enforced by this example. + +=head1 ACL NAMING ENFORCEMENT + +Similar to object names, by default wallet permits administrators to +create ACLs with any name. However, naming standards for ACLs can be +enforced by defining a Perl function in the configuration file named +verify_acl_name. If such a function exists, it will be called for any ACL +creation or rename and will be passed given the new ACL name and the +identity of the person doing the creation. If it returns undef or the +empty string, object creation will be allowed. If it returns anything +else, object creation is rejected and the return value is used as the +error message. + +Please note that this return status is backwards from what one would +normally expect. A false value is success; a true value is failure with +an error message. + +For example, the following verify_acl_name function would ensure that any +ACLs created contain a slash and the part before the slash be one of +C, C, C, or C. + + sub verify_acl_name { + my ($name, $user) = @_; + return 'ACL names must contain a slash' unless $name =~ m,/,; + my ($first, $rest) = split ('/', $name, 2); + my %types = map { $_ => 1 } qw(host group user service); + unless ($types{$first}) { + return "unknown ACL type $first"; + } + return; + } + +Obvious improvements could be made, such as checking that the part after +the slash for a C ACL looked like a host name and the part after a +slash for a C ACL look like a user name. =head1 ENVIRONMENT diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm index d525fe3..185bf23 100644 --- a/perl/Wallet/Server.pm +++ b/perl/Wallet/Server.pm @@ -23,7 +23,7 @@ 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.08'; +$VERSION = '0.09'; ############################################################################## # Utility methods @@ -536,9 +536,16 @@ sub acl_create { $self->error ("$self->{user} not authorized to create ACL"); return; } - my $dbh = $self->{dbh}; my $user = $self->{user}; my $host = $self->{host}; + if (defined (&Wallet::Config::verify_acl_name)) { + my $error = Wallet::Config::verify_acl_name ($name, $user); + if ($error) { + $self->error ("$name rejected: $error"); + return; + } + } + my $dbh = $self->{dbh}; my $acl = eval { Wallet::ACL->create ($name, $dbh, $user, $host) }; if ($@) { $self->error ($@); @@ -620,6 +627,13 @@ sub acl_rename { $self->error ('cannot rename the ADMIN ACL'); return; } + if (defined (&Wallet::Config::verify_acl_name)) { + my $error = Wallet::Config::verify_acl_name ($name, $self->{user}); + if ($error) { + $self->error ("$name rejected: $error"); + return; + } + } unless ($acl->rename ($name)) { $self->error ($acl->error); return; diff --git a/perl/t/server.t b/perl/t/server.t index 2a178e8..ed92d6e 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -3,11 +3,11 @@ # Tests for the wallet server API. # # Written by Russ Allbery -# 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 => 349; +use Test::More tests => 355; use POSIX qw(strftime); use Wallet::Admin; @@ -938,6 +938,26 @@ is ($server->owner ('base', 'service/acl-user', ''), 1, is ($server->acl_destroy ('test-destroy'), 1, ' now we can destroy the ACL'); is ($server->destroy ('base', 'service/acl-user'), 1, ' and the object'); +# Test ACL naming enforcement. Require that ACL names not contain a slash. +package Wallet::Config; +sub verify_acl_name { + my ($name, $user) = @_; + return 'ACL names may not contain slash' if $name =~ m,/,; + return; +} +package main; +is ($server->acl_create ('test/naming'), undef, + 'Creating an ACL with a disallowed name fails'); +is ($server->error, 'test/naming rejected: ACL names may not contain slash', + ' with the right error message'); +is ($server->acl_create ('test-naming'), 1, + 'Creating test-naming succeeds'); +is ($server->acl_rename ('test-naming', 'test/naming'), undef, + ' but renaming it fails'); +is ($server->error, 'test/naming rejected: ACL names may not contain slash', + ' with the right error message'); +is ($server->acl_destroy ('test-naming'), 1, 'Destroying it succeeds'); + # Clean up. $setup->destroy; unlink 'wallet-db'; -- cgit v1.2.3 From bc105004b8e88e1ede75dae0028d3ef10c15b57a Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Mon, 8 Mar 2010 10:19:03 -0800 Subject: Add an ACL name audit to wallet-report and Wallet::Report Parallel to objects name, add an acls name audit that returns all ACLs that do not follow the site naming standard. --- NEWS | 7 ++++--- perl/Wallet/Config.pm | 8 ++++++++ perl/Wallet/Report.pm | 33 ++++++++++++++++++++++++--------- perl/t/report.t | 17 ++++++++++++++++- server/wallet-report | 26 +++++++++++++++++++------- tests/server/report-t | 16 +++++++++++++--- 6 files changed, 84 insertions(+), 23 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index 1f63e07..6744475 100644 --- a/NEWS +++ b/NEWS @@ -13,9 +13,10 @@ wallet 0.11 (unreleased) set, it is called for any ACL creation or rename and can reject the new ACL name. - Add an audit command to wallet-report and one audit: objects name, - which returns all objects that do not pass the local naming policy. - The corresponding Wallet::Report method is audit(). + Add an audit command to wallet-report and two audits: acls name, which + returns all ACLs that do not pass the local naming policy, and objects + name, which does the same for objects. The corresponding + Wallet::Report method is audit(). Add the acls unused report to wallet-report and Wallet::Report, returning all ACLs not referenced by any database objects. diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index e4014a1..23a051d 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -563,6 +563,14 @@ empty string, object creation will be allowed. If it returns anything else, object creation is rejected and the return value is used as the error message. +This function is also called for naming audits done via Wallet::Report to +find any existing objects that violate a (possibly updated) naming policy. +In this case, the second argument (the identity of the person creating the +ACL) will be undef. As a general rule, if the second argument is undef, +the function should apply the most liberal accepted naming policy so that +the audit returns only ACLs that violate all naming policies, but some +sites may wish different results for their audit reports. + Please note that this return status is backwards from what one would normally expect. A false value is success; a true value is failure with an error message. diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index f6e6753..c743060 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -310,10 +310,10 @@ sub owners { ############################################################################## # Audit the database for violations of local policy. Returns a list of -# objects (as type and name pairs) or a list of ACLs. On error and for no -# matching entries, the empty list will be returned. To distinguish between -# an empty return and an error, call error(), which will return undef if there -# was no error. +# objects (as type and name pairs) or a list of ACLs (as ID and name pairs). +# On error and for no matching entries, the empty list will be returned. To +# distinguish between an empty return and an error, call error(), which will +# return undef if there was no error. sub audit { my ($self, $type, $audit) = @_; undef $self->{error}; @@ -336,6 +336,20 @@ sub audit { $self->error ("unknown object audit: $audit"); return; } + } elsif ($type eq 'acls') { + if ($audit eq 'name') { + return unless defined &Wallet::Config::verify_acl_name; + my @acls = $self->acls; + my @results; + for my $acl (@acls) { + my $error = Wallet::Config::verify_acl_name ($acl->[1]); + push (@results, $acl) if $error; + } + return @results; + } else { + $self->error ("unknown acl audit: $audit"); + return; + } } else { $self->error ("unknown audit type: $type"); return; @@ -424,11 +438,12 @@ the error message if there was an error and undef if there was no error. Audits the wallet database for violations of local policy. TYPE is the general class of thing to audit, and AUDIT is the specific audit to -perform. Currently, the only implemented type is C and the only -audit is C. This returns a list of all objects, as references to -pairs of type and name, that are not accepted by the verify_name() -function defined in the wallet configuration. See L for -more information. +perform. TYPE may be either C or C. Currently, the only +implemented audit is C. This returns a list of all objects, as +references to pairs of type and name, or ACLs, as references to pairs of +ID and name, that are not accepted by the verify_name() or +verify_acl_name() function defined in the wallet configuration. See +L for more information. Returns the empty list on failure. An error can be distinguished from empty search results by calling error(). error() is guaranteed to return diff --git a/perl/t/report.t b/perl/t/report.t index b283576..1dc69f7 100755 --- a/perl/t/report.t +++ b/perl/t/report.t @@ -7,7 +7,7 @@ # # See LICENSE for licensing terms. -use Test::More tests => 148; +use Test::More tests => 151; use Wallet::Admin; use Wallet::Report; @@ -224,6 +224,21 @@ is (scalar (@lines), 1, 'Searching for naming violations finds one'); is ($lines[0][0], 'base', ' and the first has the right type'); is ($lines[0][1], 'service/admin', ' and the right name'); +# Set an ACL naming policy and then look for objects that fail that policy. +# Use the same deactivation trick as above. +package Wallet::Config; +sub verify_acl_name { + my ($name) = @_; + return unless $naming_active; + return 'second not allowed' if $name eq 'second'; + return; +} +package main; +@lines = $report->audit ('acls', 'name'); +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'); + # Clean up. $admin->destroy; unlink 'wallet-db'; diff --git a/server/wallet-report b/server/wallet-report index 2b7cd45..435fb73 100755 --- a/server/wallet-report +++ b/server/wallet-report @@ -38,12 +38,16 @@ sub command { } elsif ($command eq 'audit') { die "too many arguments to audit\n" if @args > 2; die "too few arguments to audit\n" if @args < 2; - my @objects = $report->audit (@args); - if (!@objects and $report->error) { + my @result = $report->audit (@args); + if (!@result and $report->error) { die $report->error, "\n"; } - for my $object (@objects) { - print join (' ', @$object), "\n"; + for my $item (@result) { + if ($args[0] eq 'acls') { + print "$$item[1] (ACL ID: $$item[0])\n"; + } else { + print join (' ', @$item), "\n"; + } } } elsif ($command eq 'objects') { die "too many arguments to objects\n" if @args > 2; @@ -146,14 +150,22 @@ wallet database, either as an owner or on one of the more specific ACLs. =back +=item audit acls name + =item audit objects name -Returns all objects that violate the current site naming policy. Objects -will be listed in the form: +Returns all ACLs or objects that violate the current site naming policy. +Objects will be listed in the form: -There will be one line per object. +and ACLs in the form: + + (ACL ID: ) + +where is the human-readable name and is the numeric ID. The +numeric ID is what's used internally by the wallet system. There will be +one line per object or ACL. =item objects diff --git a/tests/server/report-t b/tests/server/report-t index 61cfd9b..394a869 100755 --- a/tests/server/report-t +++ b/tests/server/report-t @@ -8,7 +8,7 @@ # See LICENSE for licensing terms. use strict; -use Test::More tests => 42; +use Test::More tests => 44; # Create a dummy class for Wallet::Report that prints what method was called # with its arguments and returns data for testing. @@ -42,7 +42,13 @@ sub audit { shift; print "audit @_\n"; return if ($error or $empty); - return ([ file => 'unix-wallet-password' ]); + if ($_[0] eq 'objects') { + return ([ file => 'unix-wallet-password' ]); + } elsif ($_[0] eq 'acls') { + return ([ 2, 'group/admins' ]); + } else { + return; + } } sub objects { @@ -119,9 +125,13 @@ is ($out, "new\nacls entry foo foo\n" . "ADMIN (ACL ID: 1)\ngroup/admins (ACL ID: 2)\ngroup/users (ACL ID: 4)\n", ' and returns the right output'); ($out, $err) = run_report ('audit', 'objects', 'name'); -is ($err, '', 'Audit report succeeds'); +is ($err, '', 'Object audit report succeeds'); is ($out, "new\naudit objects name\nfile unix-wallet-password\n", ' and returns the right output'); +($out, $err) = run_report ('audit', 'acls', 'name'); +is ($err, '', 'ACL audit report succeeds'); +is ($out, "new\naudit acls name\ngroup/admins (ACL ID: 2)\n", + ' and returns the right output'); ($out, $err) = run_report ('objects'); is ($err, '', 'List succeeds for objects'); is ($out, "new\nobjects \n" -- cgit v1.2.3 From 7bed6b6110af7532fc4a49cdb425f7f668e17c21 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 12 May 2010 11:32:31 -0700 Subject: Add a report of all objects that have never been downloaded Add a objects unused report to wallet-report and Wallet::Report, returning all objects that have never been downloaded (in other words, have never been the target of a get command). --- NEWS | 6 ++++++ TODO | 2 +- perl/Wallet/Report.pm | 20 ++++++++++++++++---- perl/t/report.t | 51 ++++++++++++++++++++++++++++++++++++++++++++++++++- server/wallet-report | 7 +++++++ 5 files changed, 80 insertions(+), 6 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index f9d4a9a..79a24d1 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,11 @@ User-Visible wallet Changes +wallet 0.12 (unreleased) + + Add a objects unused report to wallet-report and Wallet::Report, + returning all objects that have never been downloaded (in other words, + have never been the target of a get command). + wallet 0.11 (2010-03-08) When deleting an ACL on the server, verify that the ACL is not diff --git a/TODO b/TODO index 1e9f3c9..06521cd 100644 --- a/TODO +++ b/TODO @@ -137,7 +137,7 @@ Reports: previous versions before ACL deletion was checked with database backends that don't do referential integrity. - * Add report for all objects that have never been stored or downloaded. + * Add report for all objects that have never been stored. * Add report of all ACLs with identical contents. diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index c743060..64418ee 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -20,7 +20,7 @@ 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 +128,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 +153,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 +163,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"); } @@ -461,13 +472,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, with a given type, +There are five types of searches currently. C, with a given type, will return only those entries where the type matches the given type. C, with a given owner, will only return those objects owned by the given ACL name or ID. C, with a given flag name, will only return those items with a flag set to the given value. C operates like C, 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 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 diff --git a/perl/t/report.t b/perl/t/report.t index 1dc69f7..00636db 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 => 179; 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,41 @@ 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'); + # Clean up. $admin->destroy; unlink 'wallet-db'; +system ('rm -r test-files') == 0 or die "cannot remove test-files\n"; diff --git a/server/wallet-report b/server/wallet-report index 435fb73..28d5b9a 100755 --- a/server/wallet-report +++ b/server/wallet-report @@ -177,6 +177,8 @@ one line per object or ACL. =item objects type +=item objects unused + Returns a list of objects in the database. Objects will be listed in the form: @@ -210,6 +212,11 @@ Returns all objects owned by the given ACL name or ID. Returns all objects of the given type. +=item objects unused + +Returns all objects that have never been downloaded (have never been the +target of a get command). + =back =item owners -- cgit v1.2.3 From 4dbf126b079d87639d0a463770c3e72b5b53d5d1 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 18 May 2010 16:44:38 -0700 Subject: Add acls duplicate report Add an acls duplicate report to wallet-report and Wallet::Report, returning sets of ACLs that have exactly the same entries. --- NEWS | 3 ++ perl/Wallet/Report.pm | 81 +++++++++++++++++++++++++++++++++++++++++++-------- perl/t/report.t | 36 ++++++++++++++++++++++- server/wallet-report | 25 ++++++++++++++-- tests/server/report-t | 10 ++++++- 5 files changed, 138 insertions(+), 17 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index 79a24d1..738459b 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,9 @@ wallet 0.12 (unreleased) returning all objects that have never been downloaded (in other words, have never been the target of a get command). + Add an acls duplicate report to wallet-report and Wallet::Report, + returning sets of ACLs that have exactly the same entries. + wallet 0.11 (2010-03-08) When deleting an ACL on the server, verify that the ACL is not diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index 64418ee..5a8dc52 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -15,6 +15,7 @@ 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 @@ -234,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 @@ -249,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; @@ -427,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 takes no arguments and will return -only those ACLs that have no entries within them. C 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 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 and -ID 1 and one with name C and ID 3, acls() with no arguments -would return: +currently four search types. C returns sets of duplicate ACLs +(ones with exactly the same entries). C takes no arguments and +will return only those ACLs that have no entries within them. C +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 returns all ACLs +that are not referenced by any object. + +The return value for everything except C 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 and ID 1 and one with name +C and ID 3, acls() with no arguments would return: ([ 1, 'ADMIN' ], [ 3, 'group/admins' ]) +The return value for the C search is sets of ACL names that are +duplicates (have the same entries). For example, if C, C, and +C are all duplicates, and C and C 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. diff --git a/perl/t/report.t b/perl/t/report.t index 00636db..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 => 179; +use Test::More tests => 197; use Wallet::Admin; use Wallet::Report; @@ -287,6 +287,40 @@ 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'; diff --git a/server/wallet-report b/server/wallet-report index 28d5b9a..466fe46 100755 --- a/server/wallet-report +++ b/server/wallet-report @@ -32,8 +32,14 @@ sub command { if (!@acls and $report->error) { die $report->error, "\n"; } - for my $acl (sort { $$a[1] cmp $$b[1] } @acls) { - print "$$acl[1] (ACL ID: $$acl[0])\n"; + if (@args && $args[0] eq 'duplicate') { + for my $group (@acls) { + print join (' ', @$group), "\n"; + } + } else { + for my $acl (sort { $$a[1] cmp $$b[1] } @acls) { + print "$$acl[1] (ACL ID: $$acl[0])\n"; + } } } elsif ($command eq 'audit') { die "too many arguments to audit\n" if @args > 2; @@ -110,13 +116,16 @@ B takes no traditional options. =item acls +=item acls duplicate + =item acls empty =item acls entry =item acls unused -Returns a list of ACLs in the database. ACLs will be listed in the form: +Returns a list of ACLs in the database. Except for the C +report, ACLs will be listed in the form: (ACL ID: ) @@ -124,6 +133,10 @@ where is the human-readable name and is the numeric ID. The numeric ID is what's used internally by the wallet system. There will be one line per ACL. +For the C report, the output will instead be one duplicate set +per line. This will be a set of ACLs that all have the same entries. +Only the names will be given, separated by spaces. + If no search type is given, all the ACLs in the database will be returned. If a search type (and possible search arguments) are given, then the ACLs will be limited to those that match the search. @@ -132,6 +145,12 @@ The currently supported ACL search types are: =over 4 +=item acls duplicate + +Returns all sets of ACLs that are duplicates, meaning that they contain +exactly the same entries. Each line will be the names of the ACLs in a +set of duplicates, separated by spaces. + =item acls empty Returns all ACLs which have no entries, generally so that abandoned ACLs diff --git a/tests/server/report-t b/tests/server/report-t index 394a869..0771946 100755 --- a/tests/server/report-t +++ b/tests/server/report-t @@ -8,7 +8,7 @@ # See LICENSE for licensing terms. use strict; -use Test::More tests => 44; +use Test::More tests => 48; # Create a dummy class for Wallet::Report that prints what method was called # with its arguments and returns data for testing. @@ -35,6 +35,7 @@ sub acls { shift; print "acls @_\n"; return if ($error or $empty); + return ([ qw/d1 d2 d3/ ], [ qw/o1 o2/ ]) if (@_ && $_[0] eq 'duplicate'); return ([ 1, 'ADMIN' ], [ 2, 'group/admins' ], [ 4, 'group/users' ]); } @@ -119,6 +120,10 @@ is ($err, '', 'List succeeds for ACLs'); is ($out, "new\nacls \n" . "ADMIN (ACL ID: 1)\ngroup/admins (ACL ID: 2)\ngroup/users (ACL ID: 4)\n", ' and returns the right output'); +($out, $err) = run_report ('acls', 'duplicate'); +is ($err, '', 'Duplicate report succeeds for ACLs'); +is ($out, "new\nacls duplicate\nd1 d2 d3\no1 o2\n", + ' and returns the right output'); ($out, $err) = run_report ('acls', 'entry', 'foo', 'foo'); is ($err, '', 'List succeeds for ACLs'); is ($out, "new\nacls entry foo foo\n" @@ -168,6 +173,9 @@ $Wallet::Report::empty = 1; ($out, $err) = run_report ('acls'); is ($err, '', 'acls runs with an empty list and no errors'); is ($out, "new\nacls \n", ' and calls the right methods'); +($out, $err) = run_report ('acls', 'duplicate'); +is ($err, '', 'acls duplicate runs with an empty list and no errors'); +is ($out, "new\nacls duplicate\n", ' and calls the right methods'); ($out, $err) = run_report ('audit', 'objects', 'name'); is ($err, '', 'audit runs with an empty list and no errors'); is ($out, "new\naudit objects name\n", ' and calls the right methods'); -- cgit v1.2.3 From 1e28788f0b0f5cae3dd815f07d39ad70e7da0ce2 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 18 May 2010 16:47:31 -0700 Subject: Fix error handling for klist with Heimdal user space The check for the enctypes of created keytabs tries klist for MIT first and then Heimdal ktutil. The klist options are invalid for Heimdal. Suppress the resulting complaining to standard error. --- perl/t/keytab.t | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'perl/t') 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 () { next unless /^ *\d+ /; -- cgit v1.2.3 From e6bbf534bd4195a0330a7cad02f996677a19d4d2 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 18 May 2010 16:48:54 -0700 Subject: Clean up the ticket cache from the kadmin test --- perl/t/kadmin.t | 2 ++ 1 file changed, 2 insertions(+) (limited to 'perl/t') 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'; } -- cgit v1.2.3 From 906f0f88d64c4df501c2b84dbf6b7102de36d491 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 29 Jun 2010 15:38:31 -0700 Subject: Update test suite for the addition of krb5-regex --- perl/t/schema.t | 2 +- perl/t/verifier.t | 20 ++++++++++++++++++-- tests/server/backend-t | 18 +++++++++++++----- 3 files changed, 32 insertions(+), 8 deletions(-) (limited to 'perl/t') 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 -# 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: { diff --git a/tests/server/backend-t b/tests/server/backend-t index b58d02c..a618391 100755 --- a/tests/server/backend-t +++ b/tests/server/backend-t @@ -289,11 +289,19 @@ for my $command (sort keys %acl_commands) { my @args = @base; $args[$arg] = 'foo;bar'; ($out, $err) = run_backend ('acl', $command, @args); - is ($err, "invalid characters in argument: foo;bar\n", - "Invalid arguments for acl $command $arg"); - is ($OUTPUT, "error for admin (1.2.3.4): invalid characters in" - . " argument: foo;bar\n", ' and syslog correct'); - is ($out, "$new\n", ' and nothing ran'); + if (($command eq 'add' or $command eq 'remove') and $arg == 2) { + is ($err, '', 'Add/remove allows any characters'); + is ($OUTPUT, "command acl $command @args[0..2] from admin" + . " (1.2.3.4) succeeded\n", ' and success logged'); + is ($out, "$new\nacl_$command @args[0..2]\n", + ' and calls the right method'); + } else { + is ($err, "invalid characters in argument: foo;bar\n", + "Invalid arguments for acl $command $arg"); + is ($OUTPUT, "error for admin (1.2.3.4): invalid characters in" + . " argument: foo;bar\n", ' and syslog correct'); + is ($out, "$new\n", ' and nothing ran'); + } } } for my $command (sort keys %flag_commands) { -- cgit v1.2.3 From 7f1ccd1cb73cc36668821238661ead1004fe1406 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 17 May 2011 15:28:13 -0700 Subject: Add metadata table to the wallet database Add a metadata table whose only column, currently, is a version number. We will store the version of the schema in this table and use that to know what to do during upgrades. --- perl/Wallet/Schema.pm | 20 +++++++++++++++++--- perl/t/schema.t | 14 +++++++++++--- 2 files changed, 28 insertions(+), 6 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index 25d48cf..07e5ffe 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -1,7 +1,8 @@ # Wallet::Schema -- Database schema for the wallet system. # # Written by Russ Allbery -# 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. @@ -20,7 +21,7 @@ use DBI; # 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'; +$VERSION = '0.07'; ############################################################################## # Data manipulation @@ -135,7 +136,7 @@ Wallet::Schema - Database schema for the wallet system =for stopwords SQL ACL API APIs enums Enums Keytab Backend keytab backend enctypes -enctype Allbery +enctype Allbery Metadata metadata =head1 SYNOPSIS @@ -190,6 +191,19 @@ empty database. =head1 SCHEMA +=head2 Metadata Tables + +This table is used to store metadata about the wallet database, used for +upgrades and in similar situations: + + create table metadata + (md_version integer); + insert into metadata (md_version) values (1); + +This table will normally only have one row. md_version holds the version +number of the schema (which does not necessarily have any relationship to +the version number of wallet itself). + =head2 Normalization Tables The following are normalization tables used to constrain the values in diff --git a/perl/t/schema.t b/perl/t/schema.t index 40759db..11774d6 100755 --- a/perl/t/schema.t +++ b/perl/t/schema.t @@ -3,11 +3,12 @@ # Tests for the wallet schema class. # # Written by Russ Allbery -# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. -use Test::More tests => 8; +use Test::More tests => 11; use DBI; use Wallet::Config; @@ -21,7 +22,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), 29, ' and returns the right number of statements'); +is (scalar (@sql), 31, ' and returns the right number of statements'); # Connect to a database and test create. db_setup; @@ -37,6 +38,13 @@ $dbh->{PrintError} = 0; eval { $schema->create ($dbh) }; is ($@, '', "create() doesn't die"); +# Check that the version number is correct. +my $sql = "select md_version from metadata"; +my $version = $dbh->selectall_arrayref ($sql); +is (@$version, 1, 'metadata has correct number of rows'); +is (@{ $version->[0] }, 1, ' and correct number of columns'); +is ($version->[0][0], 1, ' and the schema version is correct'); + # Test dropping the database. eval { $schema->drop ($dbh) }; is ($@, '', "drop() doesn't die"); -- cgit v1.2.3 From deaa5c140e85d8e1248d910f0721c9e00a46e439 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 17 May 2011 15:53:41 -0700 Subject: Support database upgrades from version 0 Version 0 is the version without the metadata table. Add a new upgrade method to Wallet::Schema and support upgrading the database to version 1. (Version 1 is not yet finalized.) --- perl/Wallet/Schema.pm | 81 ++++++++++++++++++++++++++++++++++++++------------- perl/t/schema.t | 11 ++++++- 2 files changed, 70 insertions(+), 22 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index 07e5ffe..911d7a9 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -67,23 +67,13 @@ sub 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}; +# Run a set of SQL commands, forcing a transaction, rolling back on error, and +# throwing an exception if anything fails. +sub _run_sql { + my ($self, $dbh, @sql) = @_; 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; @@ -94,6 +84,24 @@ sub create { } } +# 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}; + my @create = map { + if ($driver eq 'SQLite') { + s/auto_increment primary key/primary key autoincrement/; + } elsif ($driver eq 'mysql' and /^\s*create\s+table\s/) { + s/;$/ engine=InnoDB;/; + } + $_; + } @{ $self->{sql} }; + $self->_run_sql ($dbh, @create); +} + # 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. @@ -106,17 +114,42 @@ sub drop { (); } } reverse @{ $self->{sql} }; + $self->_run_sql ($dbh, @drop); +} + +# Given an open database handle, determine the current database schema +# version. If we can't read the version number, we currently assume a version +# 0 database. This will change in the future. +sub _schema_version { + my ($self, $dbh) = @_; + my $version; eval { - $dbh->begin_work if $dbh->{AutoCommit}; - for my $sql (@drop) { - $dbh->do ($sql, { RaiseError => 1, PrintError => 0 }); - } - $dbh->commit; + my $sql = 'select md_version from metadata'; + my $result = $dbh->selectrow_arrayref ($sql); + $version = $result->[0][0]; }; if ($@) { - $dbh->rollback; - die "$@\n"; + $version = 0; + } + return $version; +} + +# Given a database handle, try to upgrade the schema of that database to the +# current version while preserving all data. Do this in a transaction +# regardless of the database settings and throw an exception if this fails. +sub upgrade { + my ($self, $dbh) = @_; + my $version = $self->_schema_version ($dbh); + my @sql; + if ($version == 1) { + return; + } elsif ($version == 0) { + @sql = ('create table metadata (md_version integer)', + 'insert into metadata (md_version) values (1)'); + } else { + die "unknown database version $version\n"; } + $self->_run_sql ($dbh, @sql); } ############################################################################## @@ -187,6 +220,12 @@ 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. +=item upgrade(DBH) + +Given a connected database handle, runs the SQL commands necessary to +upgrade that database to the current schema version. On any error, this +method will throw a database exception. + =back =head1 SCHEMA diff --git a/perl/t/schema.t b/perl/t/schema.t index 11774d6..c66ad59 100755 --- a/perl/t/schema.t +++ b/perl/t/schema.t @@ -8,7 +8,7 @@ # # See LICENSE for licensing terms. -use Test::More tests => 11; +use Test::More tests => 15; use DBI; use Wallet::Config; @@ -45,6 +45,15 @@ is (@$version, 1, 'metadata has correct number of rows'); is (@{ $version->[0] }, 1, ' and correct number of columns'); is ($version->[0][0], 1, ' and the schema version is correct'); +# Test upgrading the database from version 0. +$dbh->do ("drop table metadata"); +eval { $schema->upgrade ($dbh) }; +is ($@, '', "upgrade() doesn't die"); +$version = $dbh->selectall_arrayref ($sql); +is (@$version, 1, ' and metadata has correct number of rows'); +is (@{ $version->[0] }, 1, ' and correct number of columns'); +is ($version->[0][0], 1, ' and the schema version is correct'); + # Test dropping the database. eval { $schema->drop ($dbh) }; is ($@, '', "drop() doesn't die"); -- cgit v1.2.3 From 4ee50d93cf99f55a503d0ca788e6c1a468eeacf6 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 17 May 2011 16:11:06 -0700 Subject: Add wallet-admin upgrade command to upgrade the database Hook the new upgrade method of Wallet::Schema into Wallet::Admin and the wallet-admin wrapper script. --- NEWS | 6 ++++++ README | 4 ++++ perl/Wallet/Admin.pm | 29 ++++++++++++++++++++++++----- perl/Wallet/Schema.pm | 2 +- perl/t/admin.t | 7 +++++-- server/wallet-admin | 11 ++++++++++- tests/server/admin-t | 22 +++++++++++++++++++--- 7 files changed, 69 insertions(+), 12 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index c11bff9..9e2fa3b 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,11 @@ User-Visible wallet Changes +wallet 1.0 (unreleased) + + wallet-admin has a new sub-command, upgrade, which upgrades the wallet + database to the latest schema version. This command should be run + when deploying any new version of the wallet server. + wallet 0.12 (2010-08-25) New client program wallet-rekey that, given a list of keytabs on the diff --git a/README b/README index 5eae7fd..c981272 100644 --- a/README +++ b/README @@ -131,6 +131,10 @@ BUILD AND INSTALLATION make make install + If you are upgrading the wallet server from an earlier installed + version, run wallet-admin upgrade after installation to upgrade the + database schema. See the wallet-admin manual page for more information. + Pass --enable-silent-rules to configure for a quieter build (similar to the Linux kernel). Use make warnings instead of make to build with full GCC compiler warnings (requires a relatively current version of GCC). diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index f208e13..8fb49af 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 -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -22,7 +23,7 @@ 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.06'; ############################################################################## # Constructor, destructor, and accessors @@ -110,6 +111,19 @@ sub destroy { return 1; } +# Upgrade the database to the latest schema version. Returns true on success +# and false on failure. +sub upgrade { + my ($self) = @_; + my $schema = Wallet::Schema->new; + eval { $schema->upgrade ($self->{dbh}) }; + if ($@) { + $self->error ($@); + return; + } + return 1; +} + ############################################################################## # Object registration ############################################################################## @@ -204,12 +218,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 +254,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 +263,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/Schema.pm b/perl/Wallet/Schema.pm index 911d7a9..0f6c53f 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -126,7 +126,7 @@ sub _schema_version { eval { my $sql = 'select md_version from metadata'; my $result = $dbh->selectrow_arrayref ($sql); - $version = $result->[0][0]; + $version = $result->[0]; }; if ($@) { $version = 0; diff --git a/perl/t/admin.t b/perl/t/admin.t index 074dbc6..6250f8e 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -3,11 +3,12 @@ # Tests for wallet administrative interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. -use Test::More tests => 16; +use Test::More tests => 18; use Wallet::Admin; use Wallet::Report; @@ -24,6 +25,8 @@ is ($@, '', 'Wallet::Admin creation did not die'); ok ($admin->isa ('Wallet::Admin'), ' and returned the right class'); is ($admin->initialize ('admin@EXAMPLE.COM'), 1, ' and initialization succeeds'); +is ($admin->upgrade, 1, ' and upgrade succeeds (should do nothing)'); +is ($admin->error, undef, ' and there is no error'); # We have an empty database, so we should see no objects and one ACL. my $report = Wallet::Report->new; diff --git a/server/wallet-admin b/server/wallet-admin index f81c195..fbab72b 100755 --- a/server/wallet-admin +++ b/server/wallet-admin @@ -3,7 +3,8 @@ # wallet-admin -- Wallet server administrative commands. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -56,6 +57,9 @@ sub command { } else { die "only object or verifier is supported for register\n"; } + } elsif ($command eq 'upgrade') { + die "too many arguments to upgrade\n" if @args; + $admin->upgrade or die $admin->error, "\n"; } else { die "unknown command $command\n"; } @@ -133,6 +137,11 @@ default as part of database initialization, so this command is used primarily to register local implementations of additional object types or ACL schemes. +=item upgrade + +Upgrades the database to the latest schema version, preserving data as +much as possible. + =back =head1 SEE ALSO diff --git a/tests/server/admin-t b/tests/server/admin-t index 5bde104..6846609 100755 --- a/tests/server/admin-t +++ b/tests/server/admin-t @@ -3,12 +3,13 @@ # Tests for the wallet-admin dispatch code. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. use strict; -use Test::More tests => 36; +use Test::More tests => 42; # Create a dummy class for Wallet::Admin that prints what method was called # with its arguments and returns data for testing. @@ -57,6 +58,12 @@ sub register_verifier { return 1; } +sub upgrade { + print "upgrade\n"; + return if $error; + return 1; +} + # Back to the main package and the actual test suite. Lie about whether the # Wallet::Admin package has already been loaded. package main; @@ -86,7 +93,8 @@ is ($out, "new\n", ' and nothing ran'); # Check too few and too many arguments for every command. my %commands = (destroy => [0, 0], initialize => [1, 1], - register => [3, 3]); + register => [3, 3], + upgrade => [0, 0]); for my $command (sort keys %commands) { my ($min, $max) = @{ $commands{$command} }; if ($min > 0) { @@ -150,6 +158,11 @@ is ($err, '', 'Register succeeds for verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and returns the right outout'); +# Test upgrade. +($out, $err) = run_admin ('upgrade'); +is ($err, '', 'Upgrade succeeds'); +is ($out, "new\nupgrade\n", ' and runs the right code'); + # Test error handling. $Wallet::Admin::error = 1; ($out, $err) = run_admin ('destroy'); @@ -169,3 +182,6 @@ is ($out, "new\nregister_object foo Foo::Object\n", is ($err, "some error\n", 'Error handling succeeds for register verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and calls the right methods'); +($out, $err) = run_admin ('upgrade'); +is ($err, "some error\n", 'Error handling succeeds for initialize'); +is ($out, "new\nupgrade\n", ' and calls the right methods'); -- cgit v1.2.3 From 74ed6945f9c7839603764327f0187897525db453 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Mon, 20 Jun 2011 16:15:35 -0700 Subject: Add a comment field to objects Add a comment field to objects and corresponding commands to wallet-backend and wallet to set and retrieve it. The comment field can only be set by the owner or wallet administrators but can be seen by anyone on the show ACL. --- NEWS | 5 ++++ TODO | 2 -- client/wallet.pod | 25 ++++++++++++++------ perl/Wallet/Object/Base.pm | 39 +++++++++++++++++++++++++++++-- perl/Wallet/Schema.pm | 5 +++- perl/Wallet/Server.pm | 53 +++++++++++++++++++++++++++++++++++------- perl/t/object.t | 32 +++++++++++++++++++++++-- perl/t/schema.t | 31 +++++++++++++++++++++---- perl/t/server.t | 58 +++++++++++++++++++++++++++++++++++++++++++--- server/wallet-backend | 45 +++++++++++++++++++++++++++-------- tests/server/backend-t | 32 +++++++++++++++++++------ 11 files changed, 280 insertions(+), 47 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index 9e2fa3b..42fb3e7 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,11 @@ wallet 1.0 (unreleased) database to the latest schema version. This command should be run when deploying any new version of the wallet server. + Add a comment field to objects and corresponding commands to + wallet-backend and wallet to set and retrieve it. The comment field + can only be set by the owner or wallet administrators but can be seen + by anyone on the show ACL. + wallet 0.12 (2010-08-25) New client program wallet-rekey that, given a list of keytabs on the diff --git a/TODO b/TODO index 361d242..0323cc9 100644 --- a/TODO +++ b/TODO @@ -45,8 +45,6 @@ Server Interface: * Support limiting returned history information by timestamp. - * Add a comment field for objects that can be set by the owner. - * Provide a REST implementation of the wallet server. * Provide a CGI implementation of the wallet server. diff --git a/client/wallet.pod b/client/wallet.pod index 45969b2..fdfe37f 100644 --- a/client/wallet.pod +++ b/client/wallet.pod @@ -154,11 +154,13 @@ As mentioned above, most commands are only available to wallet administrators. The exceptions are C, C, C, C, C, C, C, C, and C. All of those commands have their own ACLs except C and C, -which use the C ACL, and C, which uses the C ACL. -If the appropriate ACL is set, it alone is checked to see if the user has -access. Otherwise, C, C, C, C, C, and -C access is permitted if the user is authorized by the owner ACL -of the object. +which use the C ACL, C, which uses the C ACL, and +C, which uses the owner or C ACL depending on whether one +is setting or retrieving the comment. If the appropriate ACL is set, it +alone is checked to see if the user has access. Otherwise, C, +C, C, C, C, C, and C +access is permitted if the user is authorized by the owner ACL of the +object. Administrators can run any command on any object or ACL except for C and C. For C and C, they must still be authorized by @@ -167,8 +169,8 @@ either the appropriate specific ACL or the owner ACL. If the locked flag is set on an object, no commands can be run on that object that change data except the C commands, nor can the C command be used on that object. C, C, C, -C, and C or C without an argument can still be -used on that object. +C, and C, C, or C without an argument +can still be used on that object. For more information on attributes, see L. @@ -238,6 +240,15 @@ already exist. Check whether an object of type and name already exists. If it does, prints C; if not, prints C. +=item comment [] + +If is not given, displays the current comment for the object +identified by and , or C if none is set. + +If is given, sets the comment on the object identified by + and to . If is the empty string, clears +the comment. + =item create Create a new object of type with name . With some backends, diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm index 5097729..28ec6b9 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 -# 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,6 +18,7 @@ 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 @@ -169,7 +171,7 @@ 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"; } @@ -291,6 +293,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. @@ -565,6 +580,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' ], @@ -592,7 +608,14 @@ 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. + # The comment should be word-wrapped at 80 columns. for my $i (0 .. $#data) { + if ($attrs[$i][0] eq 'ob_comment' && length ($data[$i]) > 79 - 17) { + local $Text::Wrap::columns = 80; + local $Text::Wrap::unexpand = 0; + $data[$i] = wrap (' ' x 17, ' ' x 17, $data[$i]); + $data[$i] =~ s/^ {17}//; + } if ($attrs[$i][0] eq 'ob_created_by') { my @flags = $self->flag_list; if (not @flags and $self->error) { @@ -778,6 +801,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/Schema.pm b/perl/Wallet/Schema.pm index 0f6c53f..7400776 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -145,7 +145,9 @@ sub upgrade { return; } elsif ($version == 0) { @sql = ('create table metadata (md_version integer)', - 'insert into metadata (md_version) values (1)'); + 'insert into metadata (md_version) values (1)', + 'alter table objects add ob_comment varchar(255) default null' + ); } else { die "unknown database version $version\n"; } @@ -367,6 +369,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); diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm index 185bf23..7b3fb8f 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 -# 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. @@ -23,7 +24,7 @@ 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.10'; ############################################################################## # Utility methods @@ -276,7 +277,9 @@ sub object_error { # set the ACL accordingly. sub acl_check { 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,10 +291,10 @@ 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' and $action ne 'destroy') { $id = $object->owner; } unless (defined $id) { @@ -365,6 +368,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_check ($object, 'comment'); + $result = $object->comment ($comment, $self->{user}, $self->{host}); + } else { + return unless $self->acl_check ($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) = @_; @@ -895,6 +918,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 @@ -933,12 +970,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, 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. diff --git a/perl/t/object.t b/perl/t/object.t index 3949786..2d60dd2 100755 --- a/perl/t/object.t +++ b/perl/t/object.t @@ -3,12 +3,13 @@ # Tests for the basic object implementation. # # Written by Russ Allbery -# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 131; +use Test::More tests => 137; use Wallet::ACL; use Wallet::Admin; @@ -99,6 +100,23 @@ if ($object->expires ('', @trace)) { is ($object->expires, undef, ' at which point it is cleared'); is ($object->expires ($now, @trace), 1, ' and setting it again works'); +# Comment. +is ($object->comment, undef, 'Comment is not set to start'); +if ($object->comment ('this is a comment', @trace)) { + ok (1, ' and setting it works'); +} else { + is ($object->error, '', ' and setting it works'); +} +is ($object->comment, 'this is a comment', ' at which point it matches'); +if ($object->comment ('', @trace)) { + ok (1, ' and clearing it works'); +} else { + is ($object->error, '', ' and clearing it works'); +} +is ($object->comment, undef, ' at which point it is cleared'); +is ($object->comment (join (' ', ('this is a comment') x 5), @trace), 1, + ' and setting it again works'); + # ACLs. for my $type (qw/get store show destroy flags/) { is ($object->acl ($type), undef, "ACL $type is not set to start"); @@ -203,6 +221,8 @@ my $output = <<"EOO"; Destroy ACL: ADMIN Flags ACL: ADMIN Expires: $now + Comment: this is a comment this is a comment this is a comment this is + a comment this is a comment Flags: unchanging Created by: $user Created from: $host @@ -223,6 +243,8 @@ $output = <<"EOO"; Destroy ACL: ADMIN Flags ACL: ADMIN Expires: $now + Comment: this is a comment this is a comment this is a comment this is + a comment this is a comment Flags: locked unchanging Created by: $user Created from: $host @@ -267,6 +289,12 @@ $date unset expires (was $now) by $user from $host $date set expires to $now by $user from $host +$date set comment to this is a comment + by $user from $host +$date unset comment (was this is a comment) + by $user from $host +$date set comment to this is a comment this is a comment this is a comment this is a comment this is a comment + by $user from $host $date set acl_get to ADMIN (1) by $user from $host $date unset acl_get (was ADMIN (1)) diff --git a/perl/t/schema.t b/perl/t/schema.t index c66ad59..ce8a62a 100755 --- a/perl/t/schema.t +++ b/perl/t/schema.t @@ -8,11 +8,12 @@ # # See LICENSE for licensing terms. -use Test::More tests => 15; +use Test::More tests => 16; -use DBI; -use Wallet::Config; -use Wallet::Schema; +use DBI (); +use POSIX qw(strftime); +use Wallet::Config (); +use Wallet::Schema (); use lib 't/lib'; use Util; @@ -45,14 +46,34 @@ is (@$version, 1, 'metadata has correct number of rows'); is (@{ $version->[0] }, 1, ' and correct number of columns'); is ($version->[0][0], 1, ' and the schema version is correct'); -# Test upgrading the database from version 0. +# Test upgrading the database from version 0. SQLite cannot drop table +# columns, so we have to kill the table and then recreate it. $dbh->do ("drop table metadata"); +if (lc ($Wallet::Config::DB_DRIVER) eq 'sqlite') { + ($sql) = grep { /create table objects/ } $schema->sql; + $sql =~ s/ob_comment .*,//; + $dbh->do ("drop table objects") + or die "cannot drop objects table: $DBI::errstr\n"; + $dbh->do ($sql) + or die "cannot recreate objects table: $DBI::errstr\n"; +} else { + $dbh->do ("alter table objects drop column ob_comment") + or die "cannot drop ob_comment column: $DBI::errstr\n"; +} eval { $schema->upgrade ($dbh) }; is ($@, '', "upgrade() doesn't die"); +$sql = "select md_version from metadata"; $version = $dbh->selectall_arrayref ($sql); is (@$version, 1, ' and metadata has correct number of rows'); is (@{ $version->[0] }, 1, ' and correct number of columns'); is ($version->[0][0], 1, ' and the schema version is correct'); +$sql = "insert into objects (ob_type, ob_name, ob_created_by, ob_created_from, + ob_created_on, ob_comment) values ('file', 'test', 'test', + 'test.example.org', ?, 'a test comment')"; +$dbh->do ($sql, undef, strftime ('%Y-%m-%d %T', localtime time)); +$sql = "select ob_comment from objects where ob_name = 'test'"; +my ($comment) = $dbh->selectrow_array ($sql); +is ($comment, 'a test comment', ' and ob_comment was added to objects'); # Test dropping the database. eval { $schema->drop ($dbh) }; diff --git a/perl/t/server.t b/perl/t/server.t index ed92d6e..ad16151 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -3,11 +3,12 @@ # Tests for the wallet server API. # # Written by Russ Allbery -# 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. -use Test::More tests => 355; +use Test::More tests => 377; use POSIX qw(strftime); use Wallet::Admin; @@ -199,6 +200,24 @@ is ($server->check ('base', 'service/test'), 0, is ($server->destroy ('base', 'service/test'), undef, ' but not twice'); is ($server->error, 'cannot find base:service/test', ' with the right error'); +# Test manipulating comments. +is ($server->comment ('base', 'service/test'), undef, + 'Retrieving comment on an unknown object fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->comment ('base', 'service/test', 'this is a comment'), undef, + ' and setting it also fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->comment ('base', 'service/admin'), undef, + 'Retrieving comment for the right object returns undef'); +is ($server->error, undef, ' but there is no error'); +is ($server->comment ('base', 'service/admin', 'this is a comment'), 1, + ' and we can set it'); +is ($server->comment ('base', 'service/admin'), 'this is a comment', + ' and get the value back'); +is ($server->comment ('base', 'service/admin', ''), 1, ' and clear it'); +is ($server->comment ('base', 'service/admin'), undef, ' and now it is gone'); +is ($server->error, undef, ' and still no error'); + # Test manipulating expires. my $now = strftime ('%Y-%m-%d %T', localtime time); is ($server->expires ('base', 'service/test'), undef, @@ -393,6 +412,10 @@ is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, $history = <<"EOO"; DATE create by $admin from $host +DATE set comment to this is a comment + by $admin from $host +DATE unset comment (was this is a comment) + by $admin from $host DATE set expires to $now by $admin from $host DATE unset expires (was $now) @@ -510,12 +533,15 @@ is ($server->store ('base', 'service/user1', 'stuff'), undef, is ($server->error, "cannot store base:service/user1: object type is immutable", ' and the method is called'); +is ($server->comment ('base', 'service/user1', 'this is a comment'), 1, + ' and set a comment'); $show = $server->show ('base', 'service/user1'); $show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; $expected = <<"EOO"; Type: base Name: service/user1 Owner: user1 + Comment: this is a comment Created by: $admin Created from: $host Created on: 0 @@ -529,6 +555,8 @@ DATE create by $admin from $host DATE set owner to user1 (2) by $admin from $host +DATE set comment to this is a comment + by $user1 from $host EOO $seen = $server->history ('base', 'service/user1'); $seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; @@ -566,6 +594,11 @@ is ($server->attr ('base', 'service/user2', 'foo', ''), undef, is ($server->error, "$user1 not authorized to set attributes for base:service/user2", ' with the right error'); +is ($server->comment ('base', 'service/user2', 'this is a comment'), undef, + ' and set comment'); +is ($server->error, + "$user1 not authorized to set comment for base:service/user2", + ' with the right error'); # And only some things on an object we own with some ACLs. $result = eval { $server->get ('base', 'service/both') }; @@ -702,8 +735,27 @@ is ($server->history ('base', 'service/user1'), undef, ' or see history for it'); is ($server->error, "$user2 not authorized to show base:service/user1", ' with the right error'); +is ($server->comment ('base', 'service/user1', 'this is a comment'), undef, + ' or set a comment for it'); +is ($server->error, + "$user2 not authorized to set comment for base:service/user1", + ' with the right error'); -# And only some things on an object we own with some ACLs. +# Test that setting a comment is controlled by the owner but retrieving it is +# controlled by the show ACL. +$result = eval { $server->get ('base', 'service/both') }; +is ($result, undef, 'We can get an object we jointly own'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' and the method is called'); +is ($server->comment ('base', 'service/both', 'this is a comment'), 1, + ' and can set a comment on it'); +is ($server->error, undef, ' with no error'); +is ($server->comment ('base', 'service/both'), undef, + ' but cannot see the comment on it'); +is ($server->error, "$user2 not authorized to show base:service/both", + ' with the right error'); + +# And can only do some things on an object we own with some ACLs. $result = eval { $server->get ('base', 'service/both') }; is ($result, undef, 'We can get an object we jointly own'); is ($@, "Do not instantiate Wallet::Object::Base directly\n", diff --git a/server/wallet-backend b/server/wallet-backend index 52e9857..9850c0e 100755 --- a/server/wallet-backend +++ b/server/wallet-backend @@ -3,7 +3,8 @@ # wallet-backend -- Wallet server for storing and retrieving secure data. # # Written by Russ Allbery -# 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. @@ -191,6 +192,20 @@ sub command { } else { print $status ? "yes\n" : "no\n"; } + } elsif ($command eq 'comment') { + check_args (2, 3, [], @args); + if (@args > 2) { + $server->comment (@args) or failure ($server->error, @_); + } else { + my $output = $server->comment (@args); + if (defined $output) { + print $output, "\n"; + } elsif (not $server->error) { + print "No comment set\n"; + } else { + failure ($server->error, @_); + } + } } elsif ($command eq 'create') { check_args (2, 2, [], @args); $server->create (@args) or failure ($server->error, @_); @@ -364,13 +379,14 @@ Most commands are only available to wallet administrators (users on the C ACL). The exceptions are C, C, C, C, C, C, C, C, C, and C. All of those commands have their own ACLs except -C and C, which use the C ACL, and C, -which uses the C ACL. If the appropriate ACL is set, it alone is -checked to see if the user has access. Otherwise, C, C, -C, C, C, and C access is permitted if the -user is authorized by the owner ACL of the object. C is -permitted if the user is listed in the default ACL for an object for that -name. +C and C, which use the C ACL, C, which +uses the C ACL, and C, which uses the owner or C +ACL depending on whether one is setting or retrieving the comment. If the +appropriate ACL is set, it alone is checked to see if the user has access. +Otherwise, C, C, C, C, C, C, +and C access is permitted if the user is authorized by the owner +ACL of the object. C is permitted if the user is listed in +the default ACL for an object for that name. Administrators can run any command on any object or ACL except for C and C. For C and C, they must still be authorized by @@ -379,8 +395,8 @@ either the appropriate specific ACL or the owner ACL. If the locked flag is set on an object, no commands can be run on that object that change data except the C commands, nor can the C command be used on that object. C, C, C, -C, and C or C without an argument can still be -used on that object. +C, and C, C, or C without an argument +can still be used on that object. For more information on attributes, see L. @@ -437,6 +453,15 @@ object will be created with that default ACL set as the object owner. Check whether an object of type and name already exists. If it does, prints C; if not, prints C. +=item comment [] + +If is not given, displays the current comment for the object +identified by and , or C if none is set. + +If is given, sets the comment on the object identified by + and to . If is the empty string, clears +the comment. + =item create Create a new object of type with name . With some backends, diff --git a/tests/server/backend-t b/tests/server/backend-t index a618391..3e377a1 100755 --- a/tests/server/backend-t +++ b/tests/server/backend-t @@ -3,13 +3,13 @@ # Tests for the wallet-backend dispatch code. # # Written by Russ Allbery -# Copyright 2006, 2007, 2008, 2009, 2010 -# Board of Trustees, Leland Stanford Jr. University +# Copyright 2006, 2007, 2008, 2009, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. use strict; -use Test::More tests => 1269; +use Test::More tests => 1296; # Create a dummy class for Wallet::Server that prints what method was called # with its arguments and returns data for testing. @@ -110,6 +110,19 @@ sub check { } } +sub comment { + shift; + print "comment @_\n"; + if ($_[0] eq 'error') { + return; + } elsif ($_[1] eq 'empty') { + $okay = 1; + return; + } else { + return 'comment'; + } +} + sub expires { shift; print "expires @_\n"; @@ -216,6 +229,7 @@ is ($out, "$new\n", ' and nothing ran'); # Check too few, too many, and bad arguments for every command. my %commands = (autocreate => [2, 2], check => [2, 2], + comment => [2, 3], create => [2, 2], destroy => [2, 2], expires => [2, 4], @@ -363,7 +377,8 @@ for my $command (qw/autocreate create destroy setacl setattr store/) { ' and ran the right method'); $error++; } -for my $command (qw/check expires get getacl getattr history owner show/) { +for my $command (qw/check comment expires get getacl getattr history owner + show/) { my $method = { getacl => 'acl', getattr => 'attr' }->{$command}; $method ||= $command; my @extra = ('foo') x ($commands{$command}[0] - 2); @@ -384,7 +399,8 @@ for my $command (qw/check expires get getacl getattr history owner show/) { is ($out, "$new\n$method type name$extra\n$method$newline", ' and ran the right method with output'); } - if ($command eq 'expires' or $command eq 'owner') { + if ($command eq 'expires' or $command eq 'owner' + or $command eq 'comment') { ($out, $err) = run_backend ($command, 'type', 'name', @extra, 'foo'); my $ran = "$command type name" . (@extra ? " @extra" : '') . ' foo'; is ($err, '', "Command $command ran with no errors (setting)"); @@ -393,14 +409,16 @@ for my $command (qw/check expires get getacl getattr history owner show/) { is ($out, "$new\n$method type name$extra foo\n", ' and ran the right method'); } - if ($command eq 'expires' or $command eq 'getacl' or $command eq 'owner') { + if ($command eq 'expires' or $command eq 'getacl' + or $command eq 'owner' or $command eq 'comment') { ($out, $err) = run_backend ($command, 'type', 'empty', @extra); my $ran = "$command type empty" . (@extra ? " @extra" : ''); is ($err, '', "Command $command ran with no errors (empty)"); is ($OUTPUT, "command $ran from admin (1.2.3.4) succeeded\n", ' and success logged'); my $desc; - if ($command eq 'expires') { $desc = 'expiration' } + if ($command eq 'comment') { $desc = 'comment' } + elsif ($command eq 'expires') { $desc = 'expiration' } elsif ($command eq 'getacl') { $desc = 'ACL' } elsif ($command eq 'owner') { $desc = 'owner' } is ($out, "$new\n$method type empty$extra\nNo $desc set\n", -- cgit v1.2.3 From f1eab726c10be66e94f6984418babfa9d68993b0 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 3 Apr 2012 20:40:01 -0700 Subject: Add initial LDAP attribute ACL verifier A new ACL type, ldap-attr (Wallet::ACL::LDAP::Attribute), is now supported. This ACL type grants access if the LDAP entry corresponding to the principal contains the attribute name and value specified in the ACL. The Net::LDAP and Authen::SASL Perl modules are required to use this ACL type. New configuration settings are required as well; see Wallet::Config for more information. To enable this ACL type for an existing wallet database, use wallet-admin to register the new verifier. --- NEWS | 9 ++ README | 4 + TODO | 10 +- perl/Wallet/ACL/LDAP/Attribute.pm | 258 ++++++++++++++++++++++++++++++++++++++ perl/Wallet/Config.pm | 79 ++++++++++++ perl/Wallet/Schema.pm | 2 + perl/t/schema.t | 2 +- perl/t/verifier-ldap-attr.t | 66 ++++++++++ 8 files changed, 426 insertions(+), 4 deletions(-) create mode 100644 perl/Wallet/ACL/LDAP/Attribute.pm create mode 100755 perl/t/verifier-ldap-attr.t (limited to 'perl/t') diff --git a/NEWS b/NEWS index 42fb3e7..d08cb14 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,15 @@ wallet 1.0 (unreleased) database to the latest schema version. This command should be run when deploying any new version of the wallet server. + A new ACL type, ldap-attr (Wallet::ACL::LDAP::Attribute), is now + supported. This ACL type grants access if the LDAP entry + corresponding to the principal contains the attribute name and value + specified in the ACL. The Net::LDAP and Authen::SASL Perl modules are + required to use this ACL type. New configuration settings are + required as well; see Wallet::Config for more information. To enable + this ACL type for an existing wallet database, use wallet-admin to + register the new verifier. + Add a comment field to objects and corresponding commands to wallet-backend and wallet to set and retrieve it. The comment field can only be set by the owner or wallet administrators but can be seen diff --git a/README b/README index c981272..c440b8c 100644 --- a/README +++ b/README @@ -95,6 +95,10 @@ REQUIREMENTS binary that supports the -norandkey option to ktadd. This option is included in MIT Kerberos 1.7 and later. + To support the LDAP attribute ACL verifier, the Authen::SASL and + Net::LDAP Perl modules must be installed on the server. This verifier + only works with LDAP servers that support GSS-API binds. + To support the NetDB ACL verifier (only of interest at sites using NetDB to manage DNS), the Net::Remctl Perl module must be installed on the server. diff --git a/TODO b/TODO index b0b4652..b019903 100644 --- a/TODO +++ b/TODO @@ -63,8 +63,6 @@ ACLs: * Error messages from ACL operations should refer to the ACLs by name instead of by ID. - * Write the LDAP entitlement ACL verifier. - * Write the PTS ACL verifier. * Rename Wallet::ACL::* to Wallet::Verifier::*. Add Wallet::ACL as a @@ -81,7 +79,8 @@ ACLs: * A group-in-groups ACL schema. * Provide an API for verifiers to syntax-check the values before an ACL - is set and implement syntax checking for the Krb5 verifier. + is set and implement syntax checking for the krb5 and ldap-attr + verifiers. * Investigate how best to support client authentication using anonymous PKINIT for things like initial system keying. @@ -195,6 +194,11 @@ Code Style and Cleanup: Test Suite: + * The ldap-attr verifier test case is awful and completely specific to + people with admin access to the Stanford LDAP tree. Write a real test. + + * Rename the tests to use a subdirectory organization. + * Add POD coverage testing using Test::POD::Coverage for the server modules. diff --git a/perl/Wallet/ACL/LDAP/Attribute.pm b/perl/Wallet/ACL/LDAP/Attribute.pm new file mode 100644 index 0000000..7a54546 --- /dev/null +++ b/perl/Wallet/ACL/LDAP/Attribute.pm @@ -0,0 +1,258 @@ +# 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 + +=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. 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 for details on those configuration parameters and +information about how to set wallet configuration. + +=head1 METHODS + +=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: + +=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. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index 23a051d..3f53f74 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -378,6 +378,85 @@ our $KEYTAB_REMCTL_PORT; =back +=head1 LDAP ACL CONFIGURATION + +These configuration variables are only needed if you intend to use the +C 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. + +=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 attribute in the directory, set LDAP_FILTER_ATTR to C 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/Schema.pm b/perl/Wallet/Schema.pm index 7400776..5c6b9ca 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -276,6 +276,8 @@ Holds the supported ACL schemes and their corresponding Perl classes: 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) diff --git a/perl/t/schema.t b/perl/t/schema.t index ce8a62a..5dd90d1 100755 --- a/perl/t/schema.t +++ b/perl/t/schema.t @@ -23,7 +23,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), 31, ' and returns the right number of statements'); +is (scalar (@sql), 32, ' and returns the right number of statements'); # Connect to a database and test create. db_setup; diff --git a/perl/t/verifier-ldap-attr.t b/perl/t/verifier-ldap-attr.t new file mode 100755 index 0000000..1c84fac --- /dev/null +++ b/perl/t/verifier-ldap-attr.t @@ -0,0 +1,66 @@ +#!/usr/bin/perl -w +# +# Tests for the LDAP attribute ACL verifier. +# +# This test can only be run by someone local to Stanford with appropriate +# access to the LDAP server and will be skipped in all other environments. +# +# Written by Russ Allbery +# Copyright 2012 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 10; + +use lib 't/lib'; +use Util; + +BEGIN { use_ok ('Wallet::ACL::LDAP::Attribute') }; + +my $host = 'ldap.stanford.edu'; +my $base = 'cn=people,dc=stanford,dc=edu'; +my $filter = 'uid'; +my $user = 'rra@stanford.edu'; +my $attr = 'suPrivilegeGroup'; +my $value = 'stanford:stanford'; + +# Remove the realm from principal names. +package Wallet::Config; +sub ldap_map_principal { + my ($principal) = @_; + $principal =~ s/\@.*//; + return $principal; +} +package main; + +# Determine the local principal. +my $klist = `klist 2>&1` || ''; +SKIP: { + skip "tests useful only with Stanford Kerberos tickets", 4 + unless ($klist =~ /[Pp]rincipal: \S+\@stanford\.edu$/m); + + # Set up our configuration. + $Wallet::Config::LDAP_HOST = $host; + $Wallet::Config::LDAP_CACHE = $ENV{KRB5CCNAME}; + $Wallet::Config::LDAP_BASE = $base; + $Wallet::Config::LDAP_FILTER_ATTR = $filter; + + # Finally, we can test. + my $verifier = eval { Wallet::ACL::LDAP::Attribute->new }; + isa_ok ($verifier, 'Wallet::ACL::LDAP::Attribute'); + is ($verifier->check ($user, "$attr=$value"), 1, + "Checking $attr=$value succeeds"); + is ($verifier->error, undef, '...with no error'); + is ($verifier->check ($user, "$attr=BOGUS"), 0, + "Checking $attr=BOGUS fails"); + is ($verifier->error, undef, '...with no error'); + is ($verifier->check ($user, "BOGUS=$value"), undef, + "Checking BOGUS=$value fails with error"); + is ($verifier->error, + 'cannot check LDAP attribute BOGUS for rra: Undefined attribute type', + '...with correct error'); + is ($verifier->check ('user-does-not-exist', "$attr=$value"), 0, + "Checking for nonexistent user fails"); + is ($verifier->error, undef, '...with no error'); +} -- cgit v1.2.3 From 47680970fb76105a45ca889a3e98a9664af5eb7a Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Thu, 30 Aug 2012 14:09:26 -0700 Subject: Attempt kinit --no-afslog first in Perl test suite Avoid tromping on the user's AFS credentials if using Heimdal user space. --- perl/t/lib/Util.pm | 1 + 1 file changed, 1 insertion(+) (limited to 'perl/t') diff --git a/perl/t/lib/Util.pm b/perl/t/lib/Util.pm index 44a4d21..8bbefc4 100644 --- a/perl/t/lib/Util.pm +++ b/perl/t/lib/Util.pm @@ -74,6 +74,7 @@ sub db_setup { sub getcreds { my ($file, $principal) = @_; my @commands = ( + "kinit --no-afslog -k -t $file $principal >/dev/null 2>&1 /dev/null 2>&1 /dev/null 2>&1 /dev/null 2>&1 Date: Thu, 30 Aug 2012 14:44:44 -0700 Subject: Display the error message on the first kadmin test failure --- perl/t/kadmin.t | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'perl/t') diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index a1f2876..778bc45 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -3,12 +3,13 @@ # Tests for the kadmin object implementation. # # Written by Jon Robertson -# Copyright 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2009, 2010, 2012 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 32; +use Test::More tests => 33; BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } @@ -94,6 +95,7 @@ SKIP: { # Create the principal and check that keytab returns something. We'll # check the details of the return in the keytab check. is ($kadmin->create ('wallet/one'), 1, 'Creating wallet/one works'); + is ($kadmin->error, undef, ' with no error message'); is ($kadmin->exists ('wallet/one'), 1, ' and it now exists'); my $data = $kadmin->keytab_rekey ('wallet/one'); ok (defined ($data), ' and retrieving a keytab works'); -- cgit v1.2.3 From e43dd833852f40fb6e9356e7ff8904455d1646ea Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Thu, 30 Aug 2012 14:56:08 -0700 Subject: Fix test counts and an error in the MIT keytab test suite --- perl/t/keytab.t | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'perl/t') diff --git a/perl/t/keytab.t b/perl/t/keytab.t index fabdc5b..68cd2b4 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -9,7 +9,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 135; +use Test::More tests => 139; BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } @@ -399,15 +399,15 @@ SKIP: { # Finally we can test. First the MIT Kerberos tests. SKIP: { - skip 'skipping MIT unchanging tests for Heimdal', 12 + skip 'skipping MIT unchanging tests for Heimdal', 16 if (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'heimdal'); # We need remctld and Net::Remctl. my @path = (split (':', $ENV{PATH}), '/usr/local/sbin', '/usr/sbin'); my ($remctld) = grep { -x $_ } map { "$_/remctld" } @path; - skip 'remctld not found', 12 unless $remctld; + skip 'remctld not found', 16 unless $remctld; eval { require Net::Remctl }; - skip 'Net::Remctl not available', 12 if $@; + skip 'Net::Remctl not available', 16 if $@; # Now spawn our remctld server and get a ticket cache. remctld_spawn ($remctld, $principal, 't/data/test.keytab', @@ -441,7 +441,7 @@ SKIP: { ' and we get the same thing the second time'); is ($one->flag_clear ('unchanging', @trace), 1, 'Clearing the unchanging flag works'); - my $data = $object->get (@trace); + my $data = $one->get (@trace); ok (defined ($data), ' and getting the keytab works'); ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); is ($two->get (@trace), undef, 'Get for wallet/two does not work'); -- cgit v1.2.3 From c82a0a11a1306a805a3db5813e26bef72984db4c Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Thu, 30 Aug 2012 14:57:44 -0700 Subject: Clean up a file created by the MIT keytab tests --- perl/t/keytab.t | 1 + 1 file changed, 1 insertion(+) (limited to 'perl/t') diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 68cd2b4..01def75 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -451,6 +451,7 @@ SKIP: { is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); is ($two->destroy (@trace), 1, ' as does destroying wallet/two'); remctld_stop; + unlink 'krb5cc_good'; } # Now Heimdal. Since the keytab contains timestamps, before testing for -- cgit v1.2.3 From d2b811335137ad10ca9489582f31d2d5c595f7f7 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Sun, 4 Nov 2012 09:30:58 -0800 Subject: Minor improvement to the Wallet::Kadmin test suite --- perl/t/kadmin.t | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'perl/t') diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index 778bc45..cefd80d 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -9,7 +9,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 33; +use Test::More tests => 34; BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } @@ -73,7 +73,7 @@ SKIP: { # implementation is configured. This retests some things that are also tested # by the keytab test, but specifically through the Wallet::Kadmin API. SKIP: { - skip 'no keytab configuration', 14 unless -f 't/data/test.keytab'; + skip 'no keytab configuration', 15 unless -f 't/data/test.keytab'; # Set up our configuration. $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; @@ -91,6 +91,7 @@ SKIP: { is ($@, '', ' and there is no error'); is ($kadmin->destroy ('wallet/one'), 1, 'Deleting wallet/one works'); is ($kadmin->exists ('wallet/one'), 0, ' and it does not exist'); + is ($kadmin->error, undef, ' with no error message'); # Create the principal and check that keytab returns something. We'll # check the details of the return in the keytab check. -- cgit v1.2.3 From 357532f312aea30ab5b3e459ccf19f1580b29262 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Sun, 4 Nov 2012 10:38:29 -0800 Subject: Add new acl check command Add a new acl check command which, given an ACL ID, prints yes if that ACL already exists and no otherwise. This is parallel to the check command for objects. Also fix some documentation errors in the wallet client documentation, saying that the check command doesn't require any ACL and fixing one place where "show" was used instead of "store". --- NEWS | 4 ++++ TODO | 3 --- client/wallet.pod | 30 ++++++++++++++++++------------ perl/Wallet/Server.pm | 40 ++++++++++++++++++++++++++++------------ perl/t/server.t | 10 +++++++--- server/wallet-backend | 31 ++++++++++++++++++++++--------- tests/server/backend-t | 30 +++++++++++++++++++++++++++--- 7 files changed, 106 insertions(+), 42 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index 6f20133..b948d91 100644 --- a/NEWS +++ b/NEWS @@ -15,6 +15,10 @@ wallet 1.0 (unreleased) this ACL type for an existing wallet database, use wallet-admin to register the new verifier. + Add a new acl check command which, given an ACL ID, prints yes if that + ACL already exists and no otherwise. This is parallel to the check + command for objects. + Add a comment field to objects and corresponding commands to wallet-backend and wallet to set and retrieve it. The comment field can only be set by the owner or wallet administrators but can be seen diff --git a/TODO b/TODO index fd49abc..2fc17b5 100644 --- a/TODO +++ b/TODO @@ -29,9 +29,6 @@ Client: Server Interface: - * WALLET-12: Add check command for ACLs similar to the check command for - objects. - * WALLET-13: Provide a way to get history for deleted objects and ACLs. * WALLET-14: Provide an interface to mass-change all instances of one ACL diff --git a/client/wallet.pod b/client/wallet.pod index a0785a5..23e4e7c 100644 --- a/client/wallet.pod +++ b/client/wallet.pod @@ -151,19 +151,20 @@ options and commands are ignored. =head1 COMMANDS As mentioned above, most commands are only available to wallet -administrators. The exceptions are C, C, C, C, -C, C, C, C, and C. All -of those commands have their own ACLs except C and C, -which use the C ACL, C, which uses the C ACL, and -C, which uses the owner or C ACL depending on whether one -is setting or retrieving the comment. If the appropriate ACL is set, it -alone is checked to see if the user has access. Otherwise, C, -C, C, C, C, C, and C -access is permitted if the user is authorized by the owner ACL of the -object. +administrators. The exceptions are C, C, C, +C, C, C, C, C, C, +C, and C. C and C can be run by +anyone. All of the rest of those commands have their own ACLs except +C and C, which use the C ACL, C, which +uses the C ACL, and C, which uses the owner or C ACL +depending on whether one is setting or retrieving the comment. If the +appropriate ACL is set, it alone is checked to see if the user has access. +Otherwise, C, C, C, C, C, C, +and C access is permitted if the user is authorized by the owner +ACL of the object. Administrators can run any command on any object or ACL except for C -and C. For C and C, they must still be authorized by +and C. For C and C, they must still be authorized by either the appropriate specific ACL or the owner ACL. If the locked flag is set on an object, no commands can be run on that @@ -178,9 +179,14 @@ For more information on attributes, see L. =item acl add -Adds an entry with and to the ACL . may be +Add an entry with and to the ACL . may be either the name of an ACL or its numeric identifier. +=item acl check + +Check whether an ACL with the ID already exists. If it does, prints +C; if not, prints C. + =item acl create Create a new, empty ACL with name . When setting an ACL on an diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm index b2bae2c..dfb7dbb 100644 --- a/perl/Wallet/Server.pm +++ b/perl/Wallet/Server.pm @@ -275,7 +275,7 @@ 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) = @_; my %actions = map { $_ => 1 } qw(get store show destroy flags setattr getattr comment); @@ -349,7 +349,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 = (); } @@ -357,7 +357,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); @@ -376,10 +376,10 @@ sub comment { return unless defined $object; my $result; if (defined $comment) { - return unless $self->acl_check ($object, 'comment'); + return unless $self->acl_verify ($object, 'comment'); $result = $object->comment ($comment, $self->{user}, $self->{host}); } else { - return unless $self->acl_check ($object, 'show'); + return unless $self->acl_verify ($object, 'show'); $result = $object->comment; } if (not defined ($result) and $object->error) { @@ -456,7 +456,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; @@ -471,7 +471,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; @@ -488,7 +488,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; @@ -501,7 +501,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; @@ -513,7 +513,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; @@ -529,7 +529,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; @@ -541,7 +541,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; @@ -551,6 +551,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->{dbh}) }; + 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 { diff --git a/perl/t/server.t b/perl/t/server.t index ad16151..8e0a30d 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -3,12 +3,12 @@ # Tests for the wallet server API. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011 +# Copyright 2007, 2008, 2010, 2011, 2012 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. -use Test::More tests => 377; +use Test::More tests => 381; use POSIX qw(strftime); use Wallet::Admin; @@ -66,7 +66,9 @@ is ($result, $history, ' including by number'); is ($server->acl_create (3), undef, 'Cannot create ACL with a numeric name'); is ($server->error, 'ACL name may not be all numbers', ' and returns the right error'); +is ($server->acl_check ('user1'), 0, 'user1 ACL does not exist'); is ($server->acl_create ('user1'), 1, 'Can create regular ACL'); +is ($server->acl_check ('user1'), 1, 'user1 now exists'); is ($server->acl_show ('user1'), "Members of ACL user1 (id: 2) are:\n", ' and show works'); is ($server->acl_create ('user1'), undef, ' but not twice'); @@ -95,8 +97,10 @@ is ($server->acl_history ('test'), undef, ' and history fails'); is ($server->error, 'ACL test not found', ' and returns the right error'); is ($server->acl_destroy ('test'), undef, 'Destroying the old name fails'); is ($server->error, 'ACL test not found', ' and returns the right error'); -is ($server->acl_destroy ('test2'), 1, ' but destroying another one works'); +is ($server->acl_check ('test2'), 1, ' but the other ACL exists'); +is ($server->acl_destroy ('test2'), 1, ' and destroying it works'); is ($server->acl_destroy ('test2'), undef, ' but not twice'); +is ($server->acl_check ('test2'), 0, ' and now it does not exist'); is ($server->error, 'ACL test2 not found', ' and returns the right error'); is ($server->acl_add ('user1', 'krb4', $user1), undef, 'Adding with a bad scheme fails'); diff --git a/server/wallet-backend b/server/wallet-backend index 9850c0e..948b47c 100755 --- a/server/wallet-backend +++ b/server/wallet-backend @@ -3,7 +3,7 @@ # wallet-backend -- Wallet server for storing and retrieving secure data. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011 +# Copyright 2007, 2008, 2010, 2011, 2012 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -150,6 +150,14 @@ sub command { if ($action eq 'add') { check_args (3, 3, [3], @args); $server->acl_add (@args) or failure ($server->error, @_); + } elsif ($action eq 'check') { + check_args (1, 1, [], @args); + my $status = $server->acl_check (@args); + if (!defined ($status)) { + failure ($server->error, @_); + } else { + print $status ? "yes\n" : "no\n"; + } } elsif ($action eq 'create') { check_args (1, 1, [], @args); $server->acl_create (@args) or failure ($server->error, @_); @@ -376,17 +384,17 @@ syslog. =head1 COMMANDS Most commands are only available to wallet administrators (users on the -C ACL). The exceptions are C, C, C, -C, C, C, C, C, C, -and C. All of those commands have their own ACLs except +C ACL). The exceptions are C, C, C, +C, C, C, C, C, C, +C, and C. C and C can be run by +anyone. All of the rest of those commands have their own ACLs except C and C, which use the C ACL, C, which -uses the C ACL, and C, which uses the owner or C -ACL depending on whether one is setting or retrieving the comment. If the +uses the C ACL, and C, which uses the owner or C ACL +depending on whether one is setting or retrieving the comment. If the appropriate ACL is set, it alone is checked to see if the user has access. Otherwise, C, C, C, C, C, C, and C access is permitted if the user is authorized by the owner -ACL of the object. C is permitted if the user is listed in -the default ACL for an object for that name. +ACL of the object. Administrators can run any command on any object or ACL except for C and C. For C and C, they must still be authorized by @@ -404,9 +412,14 @@ For more information on attributes, see L. =item acl add -Adds an entry with and to the ACL . may be +Add an entry with and to the ACL . may be either the name of an ACL or its numeric identifier. +=item acl check + +Check whether an ACL with the ID already exists. If it does, prints +C; if not, prints C. + =item acl create Create a new, empty ACL with name . When setting an ACL on an diff --git a/tests/server/backend-t b/tests/server/backend-t index 3e377a1..50131b7 100755 --- a/tests/server/backend-t +++ b/tests/server/backend-t @@ -3,13 +3,13 @@ # Tests for the wallet-backend dispatch code. # # Written by Russ Allbery -# Copyright 2006, 2007, 2008, 2009, 2010, 2011 +# Copyright 2006, 2007, 2008, 2009, 2010, 2011, 2012 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. use strict; -use Test::More tests => 1296; +use Test::More tests => 1314; # Create a dummy class for Wallet::Server that prints what method was called # with its arguments and returns data for testing. @@ -45,6 +45,18 @@ sub acl_remove sub acl_rename { shift; print "acl_rename @_\n"; ($_[0] eq 'error') ? undef : 1 } +sub acl_check { + shift; + print "acl_check @_\n"; + if ($_[0] eq 'error') { + return; + } elsif ($_[0] eq 'unknown') { + return 0; + } else { + return 1; + } +} + sub acl_history { shift; print "acl_history @_\n"; @@ -243,6 +255,7 @@ my %commands = (autocreate => [2, 2], show => [2, 2], store => [2, 3]); my %acl_commands = (add => [3, 3], + check => [1, 1], create => [1, 1], destroy => [1, 1], history => [1, 1], @@ -460,7 +473,9 @@ for my $command (sort keys %acl_commands) { is ($OUTPUT, "command $ran from admin (1.2.3.4) succeeded\n", ' and success logged'); my $expected; - if ($command eq 'show') { + if ($command eq 'check') { + $expected = "$new\nacl_$command name$extra\nyes\n"; + } elsif ($command eq 'show') { $expected = "$new\nacl_$command name$extra\nacl_show"; } elsif ($command eq 'history') { $expected = "$new\nacl_$command name$extra\nacl_history"; @@ -476,6 +491,15 @@ for my $command (sort keys %acl_commands) { is ($out, "$new\nacl_$command error$extra\n", ' and ran the right method'); $error++; + if ($command eq 'check') { + ($out, $err) = run_backend ('acl', $command, 'unknown'); + my $ran = "acl $command unknown"; + is ($err, '', "Command $command ran with no errors (unknown)"); + is ($OUTPUT, "command $ran from admin (1.2.3.4) succeeded\n", + ' and success logged'); + is ($out, "$new\nacl_$command unknown\nno\n", + ' and ran the right method with output'); + } } for my $command (sort keys %flag_commands) { my @extra = ('foo') x ($flag_commands{$command}[0] - 2); -- cgit v1.2.3 From 355201e953c4476454a322b277a7247320ed036a Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 8 Jan 2013 15:06:55 -0800 Subject: Add a test for WAKeyring objects Change-Id: Id360aebe8f0a3911a7d628feafef9b3110801124 Reviewed-on: https://gerrit.stanford.edu/715 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/t/wa-keyring.t | 175 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 175 insertions(+) create mode 100755 perl/t/wa-keyring.t (limited to 'perl/t') diff --git a/perl/t/wa-keyring.t b/perl/t/wa-keyring.t new file mode 100755 index 0000000..703b7fe --- /dev/null +++ b/perl/t/wa-keyring.t @@ -0,0 +1,175 @@ +#!/usr/bin/perl +# +# Tests for the WebAuth keyring object implementation. +# +# Written by Russ Allbery +# Copyright 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use strict; +use warnings; + +use POSIX qw(strftime); +use Test::More tests => 68; +use WebAuth 3.06 qw(WA_KEY_AES WA_AES_128); +use WebAuth::Key 1.01 (); +use WebAuth::Keyring 1.02 (); + +BEGIN { + use_ok('Wallet::Admin'); + use_ok('Wallet::Config'); + use_ok('Wallet::Object::WAKeyring'); +} + +use lib 't/lib'; +use Util; + +# Some global defaults to use. +my $user = 'admin@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($user, $host, time); + +# Flush all output immediately. +$| = 1; + +# Use Wallet::Admin to set up the database. +system ('rm -rf test-keyrings') == 0 or die "cannot remove test-keyrings\n"; +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); +my $dbh = $admin->dbh; + +# Create a WebAuth context to use. +my $wa = WebAuth->new; + +# Test error handling in the absence of configuration. +my $object = eval { + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $dbh, @trace) + }; +ok (defined ($object), 'Creating a basic WebAuth keyring object succeeds'); +ok ($object->isa ('Wallet::Object::WAKeyring'), ' and is the right class'); +is ($object->get (@trace), undef, ' and get fails'); +is ($object->error, 'WebAuth keyring support not configured', + ' with the right error'); +is ($object->store (@trace), undef, ' and store fails'); +is ($object->error, 'WebAuth keyring support not configured', + ' with the right error'); +is ($object->destroy (@trace), 1, ' but destroy succeeds'); + +# Set up our configuration. +mkdir 'test-keyrings' or die "cannot create test-keyrings: $!\n"; +$Wallet::Config::WAKEYRING_BUCKET = 'test-keyrings'; + +# Okay, now we can test. First, the basic object without store. +$object = eval { + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $dbh, @trace) + }; +ok (defined ($object), 'Creating a basic WebAuth keyring object succeeds'); +ok ($object->isa ('Wallet::Object::WAKeyring'), ' and is the right class'); +my $data = $object->get (@trace); +ok ($data, ' and get succeeds'); +my $keyring = WebAuth::Keyring->decode ($wa, $data); +ok ($keyring->isa ('WebAuth::Keyring'), ' and resulting keyring decodes'); +my @entries = $keyring->entries; +is (scalar (@entries), 3, ' and has three entries'); +is ($entries[0]->creation, 0, 'First has good creation'); +is ($entries[0]->key->type, WA_KEY_AES, ' and key type'); +is ($entries[0]->key->length, WA_AES_128, ' and key length'); +is ($entries[0]->valid_after, 0, ' and validity'); +ok ((time - $entries[1]->creation) < 2, 'Second has good creation'); +is ($entries[1]->key->type, WA_KEY_AES, ' and key type'); +is ($entries[1]->key->length, WA_AES_128, ' and key length'); +ok (($entries[1]->valid_after - time) <= 60 * 60 * 24, + ' and validity (upper)'); +ok (($entries[1]->valid_after - time) > 60 * 60 * 24 - 2, + ' and validity (lower)'); +ok ((time - $entries[2]->creation) < 2, 'Third has good creation'); +is ($entries[2]->key->type, WA_KEY_AES, ' and key type'); +is ($entries[2]->key->length, WA_AES_128, ' and key length'); +ok (($entries[2]->valid_after - time) <= 2 * 60 * 60 * 24, + ' and validity (upper)'); +ok (($entries[2]->valid_after - time) > 2 * 60 * 60 * 24 - 2, + ' and validity (lower)'); +my $data2 = $object->get (@trace); +is ($data2, $data, 'Getting the object again returns the same data'); +is ($object->error, undef, ' with no error'); +is ($object->destroy (@trace), 1, 'Destroying the object succeeds'); + +# Now store something and be sure that we get something reasonable. +$object = eval { + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $dbh, @trace) + }; +ok (defined ($object), 'Recreating the object succeeds'); +my $key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); +$keyring = WebAuth::Keyring->new ($wa, $key); +$data = $keyring->encode; +is ($object->store ($data, @trace), 1, ' and storing data in it succeeds'); +ok (-d 'test-keyrings/09', ' and the hash bucket was created'); +ok (-f 'test-keyrings/09/test', ' and the file exists'); +is (contents ('test-keyrings/09/test'), $data, ' with the right contents'); +$data = $object->get (@trace); +$keyring = WebAuth::Keyring->decode ($wa, $data); +ok ($keyring->isa ('WebAuth::Keyring'), ' and get returns a valid keyring'); +@entries = $keyring->entries; +is (scalar (@entries), 2, ' and has three entries'); +is ($entries[0]->creation, 0, 'First has good creation'); +is ($entries[0]->key->type, WA_KEY_AES, ' and key type'); +is ($entries[0]->key->length, WA_AES_128, ' and key length'); +is ($entries[0]->valid_after, 0, ' and validity'); +is ($entries[0]->key->data, $key->data, ' and matches the original key'); +ok ((time - $entries[1]->creation) < 2, 'Second has good creation'); +is ($entries[1]->key->type, WA_KEY_AES, ' and key type'); +is ($entries[1]->key->length, WA_AES_128, ' and key length'); +ok (($entries[1]->valid_after - time) <= 2 * 60 * 60 * 24, + ' and validity (upper)'); +ok (($entries[1]->valid_after - time) > 2 * 60 * 60 * 24 - 2, + ' and validity (lower)'); + +# Test pruning. Add another old key and a couple of more current keys to the +# current keyring. +$key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); +$keyring->add (0, 0, $key); +$key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); +$keyring->add (time - 24 * 60 * 60, time - 24 * 60 * 60, $key); +$key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); +$keyring->add (time, time, $key); +$data = $keyring->encode; +is ($object->store ($data, @trace), 1, 'Storing modified keyring succeeds'); +$data = $object->get (@trace); +$keyring = WebAuth::Keyring->decode ($wa, $data); +ok ($keyring->isa ('WebAuth::Keyring'), ' and get returns a valid keyring'); +@entries = $keyring->entries; +is (scalar (@entries), 3, ' and has three entries'); +ok ((time - $entries[0]->creation) < 2, 'First has good creation'); +ok (($entries[0]->valid_after - time) <= 2 * 60 * 60 * 24, + ' and validity (upper)'); +ok (($entries[0]->valid_after - time) > 2 * 60 * 60 * 24 - 2, + ' and validity (lower)'); +ok ((time - $entries[1]->creation) < 24 * 60 * 60 + 2, + 'Second has good creation'); +ok ((time - $entries[1]->valid_after) <= 60 * 60 * 24 + 2, + ' and validity'); +ok ((time - $entries[2]->creation) < 2, 'Third has good creation'); +ok ((time - $entries[2]->valid_after) < 2, ' and validity'); +is ($object->destroy (@trace), 1, 'Destroying the object succeeds'); + +# Test error handling in the file store. +system ('rm -r test-keyrings') == 0 or die "cannot remove test-keyrings\n"; +$object = eval { + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $dbh, @trace) + }; +ok (defined ($object), 'Recreating the object succeeds'); +is ($object->get (@trace), undef, ' but retrieving it fails'); +like ($object->error, qr/^cannot create keyring bucket 09: /, + ' with the right error'); +is ($object->store ("foo\n", @trace), undef, ' and store fails'); +like ($object->error, qr/^cannot create keyring bucket 09: /, + ' with the right error'); +is ($object->destroy (@trace), 1, ' but destroying the object succeeds'); + +# Clean up. +$admin->destroy; +unlink ('wallet-db'); -- cgit v1.2.3 From 593e9b1e100ace54d1d9da7eb16e60f4e37c34ff Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Sun, 2 Dec 2012 22:07:16 -0800 Subject: Moved the Perl wallet modules and tests to DBIx::Class Moved all the Perl code to use DBIx::Class for the database interface. This includes updating all database calls, how the schema is generated and maintained, and the tests in places where some output has changed. We also remove the schema.t test, as the tests for it are more covered in the admin.t tests now. Change-Id: Ie5083432d09a0d9fe364a61c31378b77aa7b3cb7 Reviewed-on: https://gerrit.stanford.edu/598 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/ACL.pm | 196 +++++++++-------- perl/Wallet/Admin.pm | 102 +++++++-- perl/Wallet/Config.pm | 10 + perl/Wallet/Database.pm | 27 +-- perl/Wallet/Object/Base.pm | 318 ++++++++++++++++------------ perl/Wallet/Object/Keytab.pm | 116 +++++----- perl/Wallet/Report.pm | 298 +++++++++++++++++--------- perl/Wallet/Schema.pm | 282 ++++++------------------ perl/Wallet/Schema/Result/Acl.pm | 99 +++++++++ perl/Wallet/Schema/Result/AclEntry.pm | 63 ++++++ perl/Wallet/Schema/Result/AclHistory.pm | 101 +++++++++ perl/Wallet/Schema/Result/AclScheme.pm | 73 +++++++ perl/Wallet/Schema/Result/Enctype.pm | 34 +++ perl/Wallet/Schema/Result/Flag.pm | 54 +++++ perl/Wallet/Schema/Result/KeytabEnctype.pm | 42 ++++ perl/Wallet/Schema/Result/KeytabSync.pm | 42 ++++ perl/Wallet/Schema/Result/Object.pm | 258 ++++++++++++++++++++++ perl/Wallet/Schema/Result/ObjectHistory.pm | 127 +++++++++++ perl/Wallet/Schema/Result/SyncTarget.pm | 40 ++++ perl/Wallet/Schema/Result/Type.pm | 64 ++++++ perl/Wallet/Server.pm | 19 +- perl/create-ddl | 93 ++++++++ perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql | 7 + perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql | 6 + perl/sql/Wallet-Schema-0.07-MySQL.sql | 211 ++++++++++++++++++ perl/sql/Wallet-Schema-0.07-SQLite.sql | 219 +++++++++++++++++++ perl/sql/Wallet-Schema-0.08-MySQL.sql | 193 +++++++++++++++++ perl/sql/Wallet-Schema-0.08-PostgreSQL.sql | 201 ++++++++++++++++++ perl/sql/Wallet-Schema-0.08-SQLite.sql | 201 ++++++++++++++++++ perl/t/admin.t | 21 +- perl/t/lib/Util.pm | 5 + perl/t/report.t | 2 +- perl/t/schema.t | 111 ---------- perl/t/server.t | 2 +- server/wallet-admin | 23 ++ 35 files changed, 2886 insertions(+), 774 deletions(-) create mode 100644 perl/Wallet/Schema/Result/Acl.pm create mode 100644 perl/Wallet/Schema/Result/AclEntry.pm create mode 100644 perl/Wallet/Schema/Result/AclHistory.pm create mode 100644 perl/Wallet/Schema/Result/AclScheme.pm create mode 100644 perl/Wallet/Schema/Result/Enctype.pm create mode 100644 perl/Wallet/Schema/Result/Flag.pm create mode 100644 perl/Wallet/Schema/Result/KeytabEnctype.pm create mode 100644 perl/Wallet/Schema/Result/KeytabSync.pm create mode 100644 perl/Wallet/Schema/Result/Object.pm create mode 100644 perl/Wallet/Schema/Result/ObjectHistory.pm create mode 100644 perl/Wallet/Schema/Result/SyncTarget.pm create mode 100644 perl/Wallet/Schema/Result/Type.pm create mode 100755 perl/create-ddl create mode 100644 perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql create mode 100644 perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql create mode 100644 perl/sql/Wallet-Schema-0.07-MySQL.sql create mode 100644 perl/sql/Wallet-Schema-0.07-SQLite.sql create mode 100644 perl/sql/Wallet-Schema-0.08-MySQL.sql create mode 100644 perl/sql/Wallet-Schema-0.08-PostgreSQL.sql create mode 100644 perl/sql/Wallet-Schema-0.08-SQLite.sql delete mode 100755 perl/t/schema.t (limited to 'perl/t') diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm index 2a06442..4f51c70 100644 --- a/perl/Wallet/ACL.pm +++ b/perl/Wallet/ACL.pm @@ -33,26 +33,24 @@ $VERSION = '0.07'; # doesn't exist, throws an exception. sub new { my ($class, $id, $dbh) = @_; - my ($sql, $data, $name); + 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 = $dbh->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, + id => $data->ac_id, + name => $data->ac_name, }; bless ($self, $class); return $self; @@ -69,18 +67,27 @@ sub create { $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 = $dbh->txn_scope_guard; + + # Create the new record. + my %record = (ac_name => $name); + my $acl = $dbh->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 = $dbh->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 = { @@ -126,13 +133,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->{dbh}->resultset('AclScheme') + ->find (\%search); + $class = $scheme_rec->as_class; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } if (defined $class) { @@ -155,11 +162,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->{dbh}->resultset('AclHistory')->create (\%record); } ############################################################################## @@ -176,13 +186,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->{dbh}->txn_scope_guard; + my %search = (ac_id => $self->{id}); + my $acls = $self->{dbh}->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 +212,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->{dbh}->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->{dbh}->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->{dbh}->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->{dbh}->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->{dbh}->resultset('AclHistory')->create (\%record); + $guard->commit; }; if ($@) { $self->error ("cannot destroy ACL $self->{id}: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -239,15 +268,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->{dbh}->txn_scope_guard; + my %record = (ae_id => $self->{id}, + ae_scheme => $scheme, + ae_identifier => $identifier); + my $entry = $self->{dbh}->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 +290,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->{dbh}->txn_scope_guard; + my %search = (ae_id => $self->{id}, + ae_scheme => $scheme, + ae_identifier => $identifier); + my $entry = $self->{dbh}->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 +322,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->{dbh}->txn_scope_guard; + my %search = (ae_id => $self->{id}); + my @entry_recs = $self->{dbh}->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 +364,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->{dbh}->txn_scope_guard; + my %search = (ah_acl => $self->{id}); + my %options = (order_by => 'ah_on'); + my @data = $self->{dbh}->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; @@ -487,7 +515,7 @@ references. =item new(ACL, DBH) 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. diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index a1aef83..511916d 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -1,7 +1,7 @@ # Wallet::Admin -- Wallet system administrative interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2011 +# Copyright 2008, 2009, 2010, 2011, 2012 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -17,13 +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.06'; +$VERSION = '0.07'; ############################################################################## # Constructor, destructor, and accessors @@ -34,7 +33,7 @@ $VERSION = '0.06'; # Throw an exception if anything goes wrong. sub new { my ($class) = @_; - my $dbh = Wallet::Database->connect; + my $dbh = Wallet::Schema->connect; my $self = { dbh => $dbh }; bless ($self, $class); return $self; @@ -61,7 +60,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->{dbh}->storage->dbh->disconnect; } ############################################################################## @@ -75,17 +74,49 @@ 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->{dbh}->deploy ({}, $Wallet::Config::DB_DDL_DIRECTORY); if ($@) { $self->error ($@); return; } + $self->default_data; + + # Create a default admin ACL. my $acl = Wallet::ACL->create ('ADMIN', $self->{dbh}, $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->{dbh}->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->{dbh}->resultset('Type')->populate (\@record); + warn "default Type not installed" unless defined $r1; + return 1; } @@ -102,12 +133,31 @@ sub reinitialize { # false on failure. sub destroy { my ($self) = @_; - my $schema = Wallet::Schema->new; - eval { $schema->drop ($self->{dbh}) }; - if ($@) { - $self->error ($@); - return; + + # Get an actual DBI handle and use it to delete all tables. + my $real_dbh = $self->{dbh}->storage->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"; + $real_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->{dbh}->create_ddl_dir (\@dbs, $version, + $Wallet::Config::DB_DDL_DIRECTORY, + $oldversion); + return 1; } @@ -115,12 +165,16 @@ sub destroy { # and false on failure. sub upgrade { my ($self) = @_; - my $schema = Wallet::Schema->new; - eval { $schema->upgrade ($self->{dbh}) }; + + if ($self->{dbh}->get_db_version) { + eval { $self->{dbh}->upgrade; }; + } if ($@) { $self->error ($@); + warn $@; return; } + return 1; } @@ -135,13 +189,14 @@ sub upgrade { 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->{dbh}->txn_scope_guard; + my %record = (ty_name => $type, + ty_class => $class); + $self->{dbh}->resultset('Type')->create (\%record); + $guard->commit; }; if ($@) { $self->error ("cannot register $class for $type: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -154,13 +209,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->{dbh}->txn_scope_guard; + my %record = (as_name => $scheme, + as_class => $class); + $self->{dbh}->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; diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index 71f6e0f..98dae03 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -167,6 +167,16 @@ backends, particularly SQLite, do not need this. our $DB_PASSWORD; +=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. + +=cut + +our $DB_DDL_DIRECTORY; + =back =head1 FILE OBJECT CONFIGURATION diff --git a/perl/Wallet/Database.pm b/perl/Wallet/Database.pm index 7daab9f..8df338a 100644 --- a/perl/Wallet/Database.pm +++ b/perl/Wallet/Database.pm @@ -1,12 +1,12 @@ # 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 -# Copyright 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008-2012 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -14,32 +14,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 +54,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/Object/Base.pm b/perl/Wallet/Object/Base.pm index 87506f4..5bd89a7 100644 --- a/perl/Wallet/Object/Base.pm +++ b/perl/Wallet/Object/Base.pm @@ -24,7 +24,7 @@ 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 @@ -37,10 +37,11 @@ $VERSION = '0.05'; # 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 %search = (ob_type => $type, + ob_name => $name); + my $object = $dbh->resultset('Object')->find (\%search); + die "cannot find ${type}:${name}\n" + unless ($object and $object->ob_name eq $name); my $self = { dbh => $dbh, name => $name, @@ -59,18 +60,27 @@ sub create { $time ||= time; die "invalid object type\n" unless $type; die "invalid object name\n" unless $name; + my $guard = $dbh->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)); + $dbh->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)); + $dbh->resultset('ObjectHistory')->create (\%record); + + $guard->commit; }; if ($@) { - $dbh->rollback; die "cannot create object ${type}:${name}: $@\n"; } my $self = { @@ -126,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->{dbh}->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->{dbh}->resultset('ObjectHistory')->create (\%record); + + my %search = (ob_type => $self->{type}, + ob_name => $self->{name}); + my $object = $self->{dbh}->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; @@ -175,12 +191,18 @@ sub log_set { 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->{dbh}->resultset('ObjectHistory')->create (\%record); } ############################################################################## @@ -202,20 +224,21 @@ sub _set_internal { $self->error ("cannot modify ${type}:${name}: object is locked"); return; } + + my $guard = $self->{dbh}->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->{dbh}->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; @@ -236,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->{dbh}->resultset('Object')->find (\%search); + $value = $object->get_column ($attr); }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } return $value; @@ -356,14 +378,18 @@ sub flag_check { my $dbh = $self->{dbh}; 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 = $dbh->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; @@ -378,22 +404,21 @@ sub flag_clear { my $name = $self->{name}; my $type = $self->{type}; my $dbh = $self->{dbh}; + my $guard = $dbh->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 = $dbh->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; @@ -407,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->{dbh}->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; @@ -435,22 +458,21 @@ sub flag_set { my $name = $self->{name}; my $type = $self->{type}; my $dbh = $self->{dbh}; + my $guard = $dbh->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 = $dbh->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 = $dbh->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; @@ -466,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->{dbh}->resultset('Acl')->find (\%search); + if (defined $acl_rs) { + $name = $acl_rs->ac_name . " ($id)"; } return $name; @@ -483,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->{dbh}->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)) { @@ -507,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)) { @@ -519,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)) { @@ -529,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; @@ -592,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->{dbh}->resultset('Object')->find (\%search); }; if ($@) { $self->error ("cannot retrieve data for ${type}:${name}: $@"); - $self->{dbh}->rollback; return; } my $output = ''; @@ -609,15 +632,18 @@ 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. # The comment should be word-wrapped at 80 columns. - for my $i (0 .. $#data) { - next unless defined $data[$i]; - if ($attrs[$i][0] eq 'ob_comment' && length ($data[$i]) > 79 - 17) { + 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; - $data[$i] = wrap (' ' x 17, ' ' x 17, $data[$i]); - $data[$i] =~ s/^ {17}//; + $value = wrap (' ' x 17, ' ' x 17, $value); + $value =~ s/^ {17}//; } - if ($attrs[$i][0] eq 'ob_created_by') { + if ($field eq 'ob_created_by') { my @flags = $self->flag_list; if (not @flags and $self->error) { return; @@ -631,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->{dbh}) }; 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; @@ -663,20 +688,31 @@ sub destroy { $self->error ("cannot destroy ${type}:${name}: object is locked"); return; } + my $guard = $self->{dbh}->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->{dbh}->resultset('Flag')->search (\%search)->delete; + + # Remove any object records + %search = (ob_type => $type, + ob_name => $name); + $self->{dbh}->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->{dbh}->resultset('ObjectHistory')->create (\%record); + $guard->commit; }; if ($@) { $self->error ("cannot destroy ${type}:${name}: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -733,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]) diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index fd3001f..083dae6 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -40,21 +40,29 @@ sub enctypes_set { my @trace = ($user, $host, $time); my $name = $self->{name}; my %enctypes = map { $_ => 1 } @$enctypes; + my $guard = $self->{dbh}->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->{dbh}->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->{dbh}->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->{dbh}->('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->{dbh}->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->{dbh}->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->{dbh}->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->dbh->resultset('KeytabSync') + ->search (\%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->dbh->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; @@ -247,11 +248,6 @@ sub new { 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->{kadmin} = $kadmin; return $self; @@ -271,11 +267,6 @@ sub create { 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"; } @@ -292,16 +283,21 @@ sub destroy { $self->error ("cannot destroy $id: object is locked"); return; } + my $dbh = $self->{dbh}; + my $guard = $dbh->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 = $dbh->resultset('KeytabSync')->search (\%search); + $sync_rs->delete_all if defined $sync_rs; + + %search = (ke_name => $self->{name}); + my $enctype_rs = $dbh->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}; diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index 5a8dc52..ea8cd2f 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -16,12 +16,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,7 +32,7 @@ $VERSION = '0.03'; # exception if anything goes wrong. sub new { my ($class) = @_; - my $dbh = Wallet::Database->connect; + my $dbh = Wallet::Schema->connect; my $self = { dbh => $dbh }; bless ($self, $class); return $self; @@ -59,7 +59,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->{dbh}->storage->dbh->disconnect; } ############################################################################## @@ -69,18 +69,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 +97,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}) }; 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 +136,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 $dbh = $self->{dbh}; + my $acl = eval { Wallet::ACL->new ($search, $dbh) }; 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 +177,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 $dbh = $self->{dbh}; eval { - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (@search); - my $object; - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@objects, [ @$object ]); + my @objects_rs = $dbh->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 +226,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 $dbh = $self->{dbh}; + my %search = (); + my %options = (order_by => [ qw/ac_id/ ], + select => [ qw/ac_id ac_name/ ]); + + eval { + my @acls_rs = $dbh->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 $dbh = $self->{dbh}; + 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 = $dbh->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,22 +278,69 @@ 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 $dbh = $self->{dbh}; + 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 = $dbh->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 $dbh = $self->{dbh}; + 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 = $dbh->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 @@ -290,11 +398,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 +410,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 +433,32 @@ sub acls { sub owners { my ($self, $type, $name) = @_; undef $self->{error}; - my @lines; + my $dbh = $self->{dbh}; + + 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 = $dbh->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 9a7fe44..d36b7ac 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -1,262 +1,85 @@ -# Wallet::Schema -- Database schema for the wallet system. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - package Wallet::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.07'; +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 () { - 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 -############################################################################## - -# Run a set of SQL commands, forcing a transaction, rolling back on error, and -# throwing an exception if anything fails. -sub _run_sql { - my ($self, $dbh, @sql) = @_; - eval { - $dbh->begin_work if $dbh->{AutoCommit}; - for my $sql (@sql) { - $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 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}; - my @create = map { - if ($driver eq 'SQLite') { - s/auto_increment primary key/primary key autoincrement/; - } elsif ($driver eq 'mysql' and /^\s*create\s+table\s/) { - s/;$/ engine=InnoDB;/; - } - $_; - } @{ $self->{sql} }; - $self->_run_sql ($dbh, @create); -} - -# 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} }; - $self->_run_sql ($dbh, @drop); -} - -# Given an open database handle, determine the current database schema -# version. If we can't read the version number, we currently assume a version -# 0 database. This will change in the future. -sub _schema_version { - my ($self, $dbh) = @_; - my $version; - eval { - my $sql = 'select md_version from metadata'; - my $result = $dbh->selectrow_arrayref ($sql); - $version = $result->[0]; - }; + my $user = $Wallet::Config::DB_USER; + my $pass = $Wallet::Config::DB_PASSWORD; + my %attrs = (PrintError => 0, RaiseError => 1); + my $dbh = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) }; if ($@) { - $version = 0; + die "cannot connect to database: $@\n"; } - return $version; + return $dbh; } -# Given a database handle, try to upgrade the schema of that database to the -# current version while preserving all data. Do this in a transaction -# regardless of the database settings and throw an exception if this fails. -sub upgrade { - my ($self, $dbh) = @_; - my $version = $self->_schema_version ($dbh); - my @sql; - if ($version == 1) { - return; - } elsif ($version == 0) { - @sql = ('create table metadata (md_version integer)', - 'insert into metadata (md_version) values (1)', - 'alter table objects add ob_comment varchar(255) default null' - ); - } else { - die "unknown database version $version\n"; - } - $self->_run_sql ($dbh, @sql); -} +__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__ - =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 Metadata metadata verifier +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 $dbh = 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. +documentation you're reading explains and comments the schema. The +class runs using the DBIx::Class module. -This schema attempts to be portable SQL, but it is designed for use with -MySQL and may require some modifications for other databases. - -=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. - -=item upgrade(DBH) - -Given a connected database handle, runs the SQL commands necessary to -upgrade that database to the current schema version. On any error, this -method will throw a database exception. - -=back +connect() will obtain the database connection information from the wallet +configuration; see L 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 Metadata Tables - -This table is used to store metadata about the wallet database, used for -upgrades and in similar situations: - - create table metadata - (md_version integer); - insert into metadata (md_version) values (1); - -This table will normally only have one row. md_version holds the version -number of the schema (which does not necessarily have any relationship to -the version number of wallet itself). - =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 @@ -390,8 +213,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); @@ -477,9 +300,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. diff --git a/perl/Wallet/Schema/Result/Acl.pm b/perl/Wallet/Schema/Result/Acl.pm new file mode 100644 index 0000000..60a357b --- /dev/null +++ b/perl/Wallet/Schema/Result/Acl.pm @@ -0,0 +1,99 @@ +package Wallet::Schema::Result::Acl; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::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..99105a0 --- /dev/null +++ b/perl/Wallet/Schema/Result/AclEntry.pm @@ -0,0 +1,63 @@ +package Wallet::Schema::Result::AclEntry; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::AclEntry + +=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..2ad56ff --- /dev/null +++ b/perl/Wallet/Schema/Result/AclHistory.pm @@ -0,0 +1,101 @@ +package Wallet::Schema::Result::AclHistory; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("InflateColumn::DateTime"); + +=head1 NAME + +Wallet::Schema::Result::AclHistory + +=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..96db79d --- /dev/null +++ b/perl/Wallet/Schema/Result/AclScheme.pm @@ -0,0 +1,73 @@ +package Wallet::Schema::Result::AclScheme; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; +__PACKAGE__->load_components (qw//); + +=head1 NAME + +Wallet::Schema::Result::AclScheme + +=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..be41b84 --- /dev/null +++ b/perl/Wallet/Schema/Result/Enctype.pm @@ -0,0 +1,34 @@ +package Wallet::Schema::Result::Enctype; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::Enctype + +=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..b38e85f --- /dev/null +++ b/perl/Wallet/Schema/Result/Flag.pm @@ -0,0 +1,54 @@ +package Wallet::Schema::Result::Flag; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::Flag + +=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..ae40c52 --- /dev/null +++ b/perl/Wallet/Schema/Result/KeytabEnctype.pm @@ -0,0 +1,42 @@ +package Wallet::Schema::Result::KeytabEnctype; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::KeytabEnctype + +=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..92ab6b8 --- /dev/null +++ b/perl/Wallet/Schema/Result/KeytabSync.pm @@ -0,0 +1,42 @@ +package Wallet::Schema::Result::KeytabSync; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::KeytabSync + +=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..17c51e2 --- /dev/null +++ b/perl/Wallet/Schema/Result/Object.pm @@ -0,0 +1,258 @@ +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 + +=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..067712f --- /dev/null +++ b/perl/Wallet/Schema/Result/ObjectHistory.pm @@ -0,0 +1,127 @@ +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 + +=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..17f4320 --- /dev/null +++ b/perl/Wallet/Schema/Result/SyncTarget.pm @@ -0,0 +1,40 @@ +package Wallet::Schema::Result::SyncTarget; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::SyncTarget + +=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..89fb4c3 --- /dev/null +++ b/perl/Wallet/Schema/Result/Type.pm @@ -0,0 +1,64 @@ +package Wallet::Schema::Result::Type; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::Type + +=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 dfb7dbb..402fbe0 100644 --- a/perl/Wallet/Server.pm +++ b/perl/Wallet/Server.pm @@ -18,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.10'; +$VERSION = '0.11'; ############################################################################## # Utility methods @@ -38,7 +37,7 @@ $VERSION = '0.10'; # for various things. Throw an exception if anything goes wrong. sub new { my ($class, $user, $host) = @_; - my $dbh = Wallet::Database->connect; + my $dbh = Wallet::Schema->connect; my $acl = Wallet::ACL->new ('ADMIN', $dbh); my $self = { dbh => $dbh, @@ -71,8 +70,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->{dbh}) { + $self->{dbh}->storage->dbh->disconnect; } } @@ -86,13 +86,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->{dbh}->txn_scope_guard; + my %search = (ty_name => $type); + my $type_rec = $self->{dbh}->resultset('Type')->find (\%search); + $class = $type_rec->ty_class; + $guard->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } if (defined $class) { diff --git a/perl/create-ddl b/perl/create-ddl new file mode 100755 index 0000000..62deb86 --- /dev/null +++ b/perl/create-ddl @@ -0,0 +1,93 @@ +#!/usr/bin/perl -w +# +# create-ddl - Create DDL files for Wallet +# +# Written by Jon Robertson +# Copyright 2012 Board of Trustees, Leland Stanford Jr. University + +############################################################################# +# Modules and declarations +############################################################################# + +use strict; +use vars qw(); + +use Getopt::Long; +use Wallet::Admin; + +############################################################################# +# Main routine +############################################################################# + +# Get errors and output in the same order. +$| = 0; + +# Clean up the path name. +my $fullpath = $0; +$0 =~ s%^.*/%%; + +# Parse command-line options. +my ($help); +my $oldversion = ''; +Getopt::Long::config ('bundling'); +GetOptions ('h|help' => \$help, + 'o|oldversion=s' => \$oldversion) or exit 1; +if ($help) { + print "Feeding myself to perldoc, please wait....\n"; + exec ('perldoc', '-t', $fullpath); +} + +# Default wallet settings, for Wallet::Admin. +$Wallet::Config::DB_DDL_DIRECTORY = 'sql/'; +$Wallet::Config::DB_DRIVER = 'SQLite'; +$Wallet::Config::DB_INFO = 'wallet-db'; + +# Create a Wallet::Admin object and run the backup. +my $admin = Wallet::Admin->new; +$admin->backup ($oldversion); + +exit(0); + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +create-ddl - Create DDL files for Wallet + +=head1 SYNOPSIS + +create-ddl [B<--help>] [B<--oldversion>] + +=head1 DESCRIPTION + +create-ddl is used to create DDL files for the various DBIx::Class +Wallet::Schema modules. It simply is an interface for the backup command +in Wallet::Admin, which does the work via DBIx::Class. The end result +is a number of files that can be used to load the database for each +supported database server. + +These files can be modified after creation to customize the database +load, though should only be done when necessary to prevent confusion +for the schema modules not matching the actual table definitions. This +is currently only done in the case of SQLite databases, due to the +SQLite parser creating keys without AUTOINCREMENT. + +=head1 OPTIONS + +B<--help> + +Prints the perldoc information (this document) for the script. + +B<--oldversion>= + +The version number of the previous version. If there are existing DDL +files for this version, then we will also create diff files to upgrade +a database from the old version to the current. + +=head1 AUTHORS + +Jon Robertson + +=cut diff --git a/perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql b/perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql new file mode 100644 index 0000000..ed0bde1 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql @@ -0,0 +1,7 @@ +BEGIN; +ALTER TABLE flags MODIFY `fl_flag` enum('locked', 'unchanging') NOT NULL; +DROP TABLE IF EXISTS flag_names; +DROP TABLE IF EXISTS metadata; +ALTER TABLE objects ADD ob_comment varchar(255) default null; +COMMIT; + diff --git a/perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql b/perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql new file mode 100644 index 0000000..3e600b0 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql @@ -0,0 +1,6 @@ +BEGIN; +DROP TABLE IF EXISTS flag_names; +DROP TABLE IF EXISTS metadata; +ALTER TABLE objects ADD ob_comment varchar(255) default null; +COMMIT; + diff --git a/perl/sql/Wallet-Schema-0.07-MySQL.sql b/perl/sql/Wallet-Schema-0.07-MySQL.sql new file mode 100644 index 0000000..1bd38b3 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.07-MySQL.sql @@ -0,0 +1,211 @@ +-- +-- Created by SQL::Translator::Producer::MySQL +-- Created on Fri Jan 25 14:12:02 2013 +-- +SET foreign_key_checks=0; + +DROP TABLE IF EXISTS `acl_history`; + +-- +-- Table: `acl_history` +-- +CREATE TABLE `acl_history` ( + `ah_id` integer NOT NULL auto_increment, + `ah_acl` integer NOT NULL, + `ah_action` varchar(16) NOT NULL, + `ah_scheme` varchar(32), + `ah_identifier` varchar(255), + `ah_by` varchar(255) NOT NULL, + `ah_from` varchar(255) NOT NULL, + `ah_on` datetime NOT NULL, + PRIMARY KEY (`ah_id`) +); + +DROP TABLE IF EXISTS `acl_schemes`; + +-- +-- Table: `acl_schemes` +-- +CREATE TABLE `acl_schemes` ( + `as_name` varchar(32) NOT NULL, + `as_class` varchar(64), + PRIMARY KEY (`as_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `acls`; + +-- +-- Table: `acls` +-- +CREATE TABLE `acls` ( + `ac_id` integer NOT NULL auto_increment, + `ac_name` varchar(255) NOT NULL, + PRIMARY KEY (`ac_id`), + UNIQUE `ac_name` (`ac_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `enctypes`; + +-- +-- Table: `enctypes` +-- +CREATE TABLE `enctypes` ( + `en_name` varchar(255) NOT NULL, + PRIMARY KEY (`en_name`) +); + +DROP TABLE IF EXISTS `flags`; + +-- +-- Table: `flags` +-- +CREATE TABLE `flag_names` ( + `fn_name` varchar(32) NOT NULL, + PRIMARY KEY (`fn_name`) +); + +DROP TABLE IF EXISTS `flags`; + +-- +-- Table: `flags` +-- +CREATE TABLE `flags` ( + `fl_type` varchar(16) NOT NULL, + `fl_name` varchar(255) NOT NULL, + `fl_flag` varchar(32) NOT NULL, + PRIMARY KEY (`fl_type`, `fl_name`, `fl_flag`) +); + +DROP TABLE IF EXISTS `keytab_enctypes`; + +-- +-- Table: `keytab_enctypes` +-- +CREATE TABLE `keytab_enctypes` ( + `ke_name` varchar(255) NOT NULL, + `ke_enctype` varchar(255) NOT NULL, + PRIMARY KEY (`ke_name`, `ke_enctype`) +); + +DROP TABLE IF EXISTS `keytab_sync`; + +-- +-- Table: `keytab_sync` +-- +CREATE TABLE `keytab_sync` ( + `ks_name` varchar(255) NOT NULL, + `ks_target` varchar(255) NOT NULL, + PRIMARY KEY (`ks_name`, `ks_target`) +); + +DROP TABLE IF EXISTS `metadata`; + +-- +-- Table: `metadata` +-- +CREATE TABLE `metadata` ( + `md_version` integer +); + +DROP TABLE IF EXISTS `sync_targets`; + +-- +-- Table: `sync_targets` +-- +CREATE TABLE `sync_targets` ( + `st_name` varchar(255) NOT NULL, + PRIMARY KEY (`st_name`) +); + +DROP TABLE IF EXISTS `types`; + +-- +-- Table: `types` +-- +CREATE TABLE `types` ( + `ty_name` varchar(16) NOT NULL, + `ty_class` varchar(64), + PRIMARY KEY (`ty_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `acl_entries`; + +-- +-- Table: `acl_entries` +-- +CREATE TABLE `acl_entries` ( + `ae_id` integer NOT NULL, + `ae_scheme` varchar(32) NOT NULL, + `ae_identifier` varchar(255) NOT NULL, + INDEX `acl_entries_idx_ae_scheme` (`ae_scheme`), + INDEX `acl_entries_idx_ae_id` (`ae_id`), + PRIMARY KEY (`ae_id`, `ae_scheme`, `ae_identifier`), + CONSTRAINT `acl_entries_fk_ae_scheme` FOREIGN KEY (`ae_scheme`) REFERENCES `acl_schemes` (`as_name`), + CONSTRAINT `acl_entries_fk_ae_id` FOREIGN KEY (`ae_id`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `objects`; + +-- +-- Table: `objects` +-- +CREATE TABLE `objects` ( + `ob_type` varchar(16) NOT NULL, + `ob_name` varchar(255) NOT NULL, + `ob_owner` integer, + `ob_acl_get` integer, + `ob_acl_store` integer, + `ob_acl_show` integer, + `ob_acl_destroy` integer, + `ob_acl_flags` integer, + `ob_expires` datetime, + `ob_created_by` varchar(255) NOT NULL, + `ob_created_from` varchar(255) NOT NULL, + `ob_created_on` datetime NOT NULL, + `ob_stored_by` varchar(255), + `ob_stored_from` varchar(255), + `ob_stored_on` datetime, + `ob_downloaded_by` varchar(255), + `ob_downloaded_from` varchar(255), + `ob_downloaded_on` datetime, + INDEX `objects_idx_ob_acl_destroy` (`ob_acl_destroy`), + INDEX `objects_idx_ob_acl_flags` (`ob_acl_flags`), + INDEX `objects_idx_ob_acl_get` (`ob_acl_get`), + INDEX `objects_idx_ob_owner` (`ob_owner`), + INDEX `objects_idx_ob_acl_show` (`ob_acl_show`), + INDEX `objects_idx_ob_acl_store` (`ob_acl_store`), + INDEX `objects_idx_ob_type` (`ob_type`), + PRIMARY KEY (`ob_name`, `ob_type`), + CONSTRAINT `objects_fk_ob_acl_destroy` FOREIGN KEY (`ob_acl_destroy`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_flags` FOREIGN KEY (`ob_acl_flags`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_get` FOREIGN KEY (`ob_acl_get`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_owner` FOREIGN KEY (`ob_owner`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_show` FOREIGN KEY (`ob_acl_show`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_store` FOREIGN KEY (`ob_acl_store`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_type` FOREIGN KEY (`ob_type`) REFERENCES `types` (`ty_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `object_history`; + +-- +-- Table: `object_history` +-- +CREATE TABLE `object_history` ( + `oh_id` integer NOT NULL auto_increment, + `oh_type` varchar(16) NOT NULL, + `oh_name` varchar(255) NOT NULL, + `oh_action` varchar(16) NOT NULL, + `oh_field` varchar(16), + `oh_type_field` varchar(255), + `oh_old` varchar(255), + `oh_new` varchar(255), + `oh_by` varchar(255) NOT NULL, + `oh_from` varchar(255) NOT NULL, + `oh_on` datetime NOT NULL, + INDEX `object_history_idx_oh_type_oh_name` (`oh_type`, `oh_name`), + PRIMARY KEY (`oh_id`), + CONSTRAINT `object_history_fk_oh_type_oh_name` FOREIGN KEY (`oh_type`, `oh_name`) REFERENCES `objects` (`ob_type`, `ob_name`) +) ENGINE=InnoDB; + +SET foreign_key_checks=1; + diff --git a/perl/sql/Wallet-Schema-0.07-SQLite.sql b/perl/sql/Wallet-Schema-0.07-SQLite.sql new file mode 100644 index 0000000..e24ea15 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.07-SQLite.sql @@ -0,0 +1,219 @@ +-- +-- Created by SQL::Translator::Producer::SQLite +-- Created on Fri Jan 25 14:12:02 2013 +-- + +BEGIN TRANSACTION; + +-- +-- Table: acl_history +-- +DROP TABLE IF EXISTS acl_history; + +CREATE TABLE acl_history ( + ah_id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + ah_acl integer NOT NULL, + ah_action varchar(16) NOT NULL, + ah_scheme varchar(32), + ah_identifier varchar(255), + ah_by varchar(255) NOT NULL, + ah_from varchar(255) NOT NULL, + ah_on datetime NOT NULL +); + +-- +-- Table: acl_schemes +-- +DROP TABLE IF EXISTS acl_schemes; + +CREATE TABLE acl_schemes ( + as_name varchar(32) NOT NULL, + as_class varchar(64), + PRIMARY KEY (as_name) +); + +-- +-- Table: acls +-- +DROP TABLE IF EXISTS acls; + +CREATE TABLE acls ( + ac_id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + ac_name varchar(255) NOT NULL +); + +CREATE UNIQUE INDEX ac_name ON acls (ac_name); + +-- +-- Table: enctypes +-- +DROP TABLE IF EXISTS enctypes; + +CREATE TABLE enctypes ( + en_name varchar(255) NOT NULL, + PRIMARY KEY (en_name) +); + +-- +-- Table: flags +-- +DROP TABLE IF EXISTS flag_names; + +CREATE TABLE flag_names ( + fn_name varchar(32) NOT NULL, + PRIMARY KEY (fn_name) +); + +-- +-- Table: flags +-- +DROP TABLE IF EXISTS flags; + +CREATE TABLE flags ( + fl_type varchar(16) NOT NULL, + fl_name varchar(255) NOT NULL, + fl_flag varchar(32) NOT NULL, + PRIMARY KEY (fl_type, fl_name, fl_flag) +); + +-- +-- Table: keytab_enctypes +-- +DROP TABLE IF EXISTS keytab_enctypes; + +CREATE TABLE keytab_enctypes ( + ke_name varchar(255) NOT NULL, + ke_enctype varchar(255) NOT NULL, + PRIMARY KEY (ke_name, ke_enctype) +); + +-- +-- Table: keytab_sync +-- +DROP TABLE IF EXISTS keytab_sync; + +CREATE TABLE keytab_sync ( + ks_name varchar(255) NOT NULL, + ks_target varchar(255) NOT NULL, + PRIMARY KEY (ks_name, ks_target) +); + +-- +-- Table: metadata +-- +DROP TABLE IF EXISTS metadata; + +CREATE TABLE metadata ( + md_version integer +); + +-- +-- Table: sync_targets +-- +DROP TABLE IF EXISTS sync_targets; + +CREATE TABLE sync_targets ( + st_name varchar(255) NOT NULL, + PRIMARY KEY (st_name) +); + +-- +-- Table: types +-- +DROP TABLE IF EXISTS types; + +CREATE TABLE types ( + ty_name varchar(16) NOT NULL, + ty_class varchar(64), + PRIMARY KEY (ty_name) +); + +-- +-- Table: acl_entries +-- +DROP TABLE IF EXISTS acl_entries; + +CREATE TABLE acl_entries ( + ae_id integer NOT NULL, + ae_scheme varchar(32) NOT NULL, + ae_identifier varchar(255) NOT NULL, + PRIMARY KEY (ae_id, ae_scheme, ae_identifier), + FOREIGN KEY(ae_scheme) REFERENCES acl_schemes(as_name), + FOREIGN KEY(ae_id) REFERENCES acls(ac_id) +); + +CREATE INDEX acl_entries_idx_ae_scheme ON acl_entries (ae_scheme); + +CREATE INDEX acl_entries_idx_ae_id ON acl_entries (ae_id); + +-- +-- Table: objects +-- +DROP TABLE IF EXISTS objects; + +CREATE TABLE objects ( + ob_type varchar(16) NOT NULL, + ob_name varchar(255) NOT NULL, + ob_owner integer, + ob_acl_get integer, + ob_acl_store integer, + ob_acl_show integer, + ob_acl_destroy integer, + ob_acl_flags integer, + ob_expires datetime, + ob_created_by varchar(255) NOT NULL, + ob_created_from varchar(255) NOT NULL, + ob_created_on datetime NOT NULL, + ob_stored_by varchar(255), + ob_stored_from varchar(255), + ob_stored_on datetime, + ob_downloaded_by varchar(255), + ob_downloaded_from varchar(255), + ob_downloaded_on datetime, + PRIMARY KEY (ob_name, ob_type), + FOREIGN KEY(ob_acl_destroy) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_flags) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_get) REFERENCES acls(ac_id), + FOREIGN KEY(ob_owner) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_show) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_store) REFERENCES acls(ac_id), + FOREIGN KEY(ob_type) REFERENCES types(ty_name) +); + +CREATE INDEX objects_idx_ob_acl_destroy ON objects (ob_acl_destroy); + +CREATE INDEX objects_idx_ob_acl_flags ON objects (ob_acl_flags); + +CREATE INDEX objects_idx_ob_acl_get ON objects (ob_acl_get); + +CREATE INDEX objects_idx_ob_owner ON objects (ob_owner); + +CREATE INDEX objects_idx_ob_acl_show ON objects (ob_acl_show); + +CREATE INDEX objects_idx_ob_acl_store ON objects (ob_acl_store); + +CREATE INDEX objects_idx_ob_type ON objects (ob_type); + +-- +-- Table: object_history +-- +DROP TABLE IF EXISTS object_history; + +CREATE TABLE object_history ( + oh_id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + oh_type varchar(16) NOT NULL, + oh_name varchar(255) NOT NULL, + oh_action varchar(16) NOT NULL, + oh_field varchar(16), + oh_type_field varchar(255), + oh_old varchar(255), + oh_new varchar(255), + oh_by varchar(255) NOT NULL, + oh_from varchar(255) NOT NULL, + oh_on datetime NOT NULL, + FOREIGN KEY(oh_type) REFERENCES objects(ob_type) +); + +CREATE INDEX object_history_idx_oh_type_oh_name ON object_history (oh_type, oh_name); + +COMMIT; diff --git a/perl/sql/Wallet-Schema-0.08-MySQL.sql b/perl/sql/Wallet-Schema-0.08-MySQL.sql new file mode 100644 index 0000000..44b6475 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.08-MySQL.sql @@ -0,0 +1,193 @@ +-- +-- Created by SQL::Translator::Producer::MySQL +-- Created on Fri Jan 25 14:12:02 2013 +-- +SET foreign_key_checks=0; + +DROP TABLE IF EXISTS `acl_history`; + +-- +-- Table: `acl_history` +-- +CREATE TABLE `acl_history` ( + `ah_id` integer NOT NULL auto_increment, + `ah_acl` integer NOT NULL, + `ah_action` varchar(16) NOT NULL, + `ah_scheme` varchar(32), + `ah_identifier` varchar(255), + `ah_by` varchar(255) NOT NULL, + `ah_from` varchar(255) NOT NULL, + `ah_on` datetime NOT NULL, + PRIMARY KEY (`ah_id`) +); + +DROP TABLE IF EXISTS `acl_schemes`; + +-- +-- Table: `acl_schemes` +-- +CREATE TABLE `acl_schemes` ( + `as_name` varchar(32) NOT NULL, + `as_class` varchar(64), + PRIMARY KEY (`as_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `acls`; + +-- +-- Table: `acls` +-- +CREATE TABLE `acls` ( + `ac_id` integer NOT NULL auto_increment, + `ac_name` varchar(255) NOT NULL, + PRIMARY KEY (`ac_id`), + UNIQUE `ac_name` (`ac_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `enctypes`; + +-- +-- Table: `enctypes` +-- +CREATE TABLE `enctypes` ( + `en_name` varchar(255) NOT NULL, + PRIMARY KEY (`en_name`) +); + +DROP TABLE IF EXISTS `flags`; + +-- +-- Table: `flags` +-- +CREATE TABLE `flags` ( + `fl_type` varchar(16) NOT NULL, + `fl_name` varchar(255) NOT NULL, + `fl_flag` enum('locked', 'unchanging') NOT NULL, + PRIMARY KEY (`fl_type`, `fl_name`, `fl_flag`) +); + +DROP TABLE IF EXISTS `keytab_enctypes`; + +-- +-- Table: `keytab_enctypes` +-- +CREATE TABLE `keytab_enctypes` ( + `ke_name` varchar(255) NOT NULL, + `ke_enctype` varchar(255) NOT NULL, + PRIMARY KEY (`ke_name`, `ke_enctype`) +); + +DROP TABLE IF EXISTS `keytab_sync`; + +-- +-- Table: `keytab_sync` +-- +CREATE TABLE `keytab_sync` ( + `ks_name` varchar(255) NOT NULL, + `ks_target` varchar(255) NOT NULL, + PRIMARY KEY (`ks_name`, `ks_target`) +); + +DROP TABLE IF EXISTS `sync_targets`; + +-- +-- Table: `sync_targets` +-- +CREATE TABLE `sync_targets` ( + `st_name` varchar(255) NOT NULL, + PRIMARY KEY (`st_name`) +); + +DROP TABLE IF EXISTS `types`; + +-- +-- Table: `types` +-- +CREATE TABLE `types` ( + `ty_name` varchar(16) NOT NULL, + `ty_class` varchar(64), + PRIMARY KEY (`ty_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `acl_entries`; + +-- +-- Table: `acl_entries` +-- +CREATE TABLE `acl_entries` ( + `ae_id` integer NOT NULL, + `ae_scheme` varchar(32) NOT NULL, + `ae_identifier` varchar(255) NOT NULL, + INDEX `acl_entries_idx_ae_scheme` (`ae_scheme`), + INDEX `acl_entries_idx_ae_id` (`ae_id`), + PRIMARY KEY (`ae_id`, `ae_scheme`, `ae_identifier`), + CONSTRAINT `acl_entries_fk_ae_scheme` FOREIGN KEY (`ae_scheme`) REFERENCES `acl_schemes` (`as_name`), + CONSTRAINT `acl_entries_fk_ae_id` FOREIGN KEY (`ae_id`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `objects`; + +-- +-- Table: `objects` +-- +CREATE TABLE `objects` ( + `ob_type` varchar(16) NOT NULL, + `ob_name` varchar(255) NOT NULL, + `ob_owner` integer, + `ob_acl_get` integer, + `ob_acl_store` integer, + `ob_acl_show` integer, + `ob_acl_destroy` integer, + `ob_acl_flags` integer, + `ob_expires` datetime, + `ob_created_by` varchar(255) NOT NULL, + `ob_created_from` varchar(255) NOT NULL, + `ob_created_on` datetime NOT NULL, + `ob_stored_by` varchar(255), + `ob_stored_from` varchar(255), + `ob_stored_on` datetime, + `ob_downloaded_by` varchar(255), + `ob_downloaded_from` varchar(255), + `ob_downloaded_on` datetime, + `ob_comment` varchar(255), + INDEX `objects_idx_ob_acl_destroy` (`ob_acl_destroy`), + INDEX `objects_idx_ob_acl_flags` (`ob_acl_flags`), + INDEX `objects_idx_ob_acl_get` (`ob_acl_get`), + INDEX `objects_idx_ob_owner` (`ob_owner`), + INDEX `objects_idx_ob_acl_show` (`ob_acl_show`), + INDEX `objects_idx_ob_acl_store` (`ob_acl_store`), + INDEX `objects_idx_ob_type` (`ob_type`), + PRIMARY KEY (`ob_name`, `ob_type`), + CONSTRAINT `objects_fk_ob_acl_destroy` FOREIGN KEY (`ob_acl_destroy`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_flags` FOREIGN KEY (`ob_acl_flags`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_get` FOREIGN KEY (`ob_acl_get`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_owner` FOREIGN KEY (`ob_owner`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_show` FOREIGN KEY (`ob_acl_show`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_store` FOREIGN KEY (`ob_acl_store`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_type` FOREIGN KEY (`ob_type`) REFERENCES `types` (`ty_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `object_history`; + +-- +-- Table: `object_history` +-- +CREATE TABLE `object_history` ( + `oh_id` integer NOT NULL auto_increment, + `oh_type` varchar(16) NOT NULL, + `oh_name` varchar(255) NOT NULL, + `oh_action` varchar(16) NOT NULL, + `oh_field` varchar(16), + `oh_type_field` varchar(255), + `oh_old` varchar(255), + `oh_new` varchar(255), + `oh_by` varchar(255) NOT NULL, + `oh_from` varchar(255) NOT NULL, + `oh_on` datetime NOT NULL, + INDEX `object_history_idx_oh_type_oh_name` (`oh_type`, `oh_name`), + PRIMARY KEY (`oh_id`), + CONSTRAINT `object_history_fk_oh_type_oh_name` FOREIGN KEY (`oh_type`, `oh_name`) REFERENCES `objects` (`ob_type`, `ob_name`) +) ENGINE=InnoDB; + +SET foreign_key_checks=1; + diff --git a/perl/sql/Wallet-Schema-0.08-PostgreSQL.sql b/perl/sql/Wallet-Schema-0.08-PostgreSQL.sql new file mode 100644 index 0000000..2f79147 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.08-PostgreSQL.sql @@ -0,0 +1,201 @@ +-- +-- Created by SQL::Translator::Producer::PostgreSQL +-- Created on Fri Jan 25 14:12:02 2013 +-- +-- +-- Table: acl_history +-- +DROP TABLE "acl_history" CASCADE; +CREATE TABLE "acl_history" ( + "ah_id" serial NOT NULL, + "ah_acl" integer NOT NULL, + "ah_action" character varying(16) NOT NULL, + "ah_scheme" character varying(32), + "ah_identifier" character varying(255), + "ah_by" character varying(255) NOT NULL, + "ah_from" character varying(255) NOT NULL, + "ah_on" timestamp NOT NULL, + PRIMARY KEY ("ah_id") +); + +-- +-- Table: acl_schemes +-- +DROP TABLE "acl_schemes" CASCADE; +CREATE TABLE "acl_schemes" ( + "as_name" character varying(32) NOT NULL, + "as_class" character varying(64), + PRIMARY KEY ("as_name") +); + +-- +-- Table: acls +-- +DROP TABLE "acls" CASCADE; +CREATE TABLE "acls" ( + "ac_id" serial NOT NULL, + "ac_name" character varying(255) NOT NULL, + PRIMARY KEY ("ac_id"), + CONSTRAINT "ac_name" UNIQUE ("ac_name") +); + +-- +-- Table: enctypes +-- +DROP TABLE "enctypes" CASCADE; +CREATE TABLE "enctypes" ( + "en_name" character varying(255) NOT NULL, + PRIMARY KEY ("en_name") +); + +-- +-- Table: flags +-- +DROP TABLE "flags" CASCADE; +CREATE TABLE "flags" ( + "fl_type" character varying(16) NOT NULL, + "fl_name" character varying(255) NOT NULL, + "fl_flag" character varying NOT NULL, + PRIMARY KEY ("fl_type", "fl_name", "fl_flag") +); + +-- +-- Table: keytab_enctypes +-- +DROP TABLE "keytab_enctypes" CASCADE; +CREATE TABLE "keytab_enctypes" ( + "ke_name" character varying(255) NOT NULL, + "ke_enctype" character varying(255) NOT NULL, + PRIMARY KEY ("ke_name", "ke_enctype") +); + +-- +-- Table: keytab_sync +-- +DROP TABLE "keytab_sync" CASCADE; +CREATE TABLE "keytab_sync" ( + "ks_name" character varying(255) NOT NULL, + "ks_target" character varying(255) NOT NULL, + PRIMARY KEY ("ks_name", "ks_target") +); + +-- +-- Table: sync_targets +-- +DROP TABLE "sync_targets" CASCADE; +CREATE TABLE "sync_targets" ( + "st_name" character varying(255) NOT NULL, + PRIMARY KEY ("st_name") +); + +-- +-- Table: types +-- +DROP TABLE "types" CASCADE; +CREATE TABLE "types" ( + "ty_name" character varying(16) NOT NULL, + "ty_class" character varying(64), + PRIMARY KEY ("ty_name") +); + +-- +-- Table: acl_entries +-- +DROP TABLE "acl_entries" CASCADE; +CREATE TABLE "acl_entries" ( + "ae_id" integer NOT NULL, + "ae_scheme" character varying(32) NOT NULL, + "ae_identifier" character varying(255) NOT NULL, + PRIMARY KEY ("ae_id", "ae_scheme", "ae_identifier") +); +CREATE INDEX "acl_entries_idx_ae_scheme" on "acl_entries" ("ae_scheme"); +CREATE INDEX "acl_entries_idx_ae_id" on "acl_entries" ("ae_id"); + +-- +-- Table: objects +-- +DROP TABLE "objects" CASCADE; +CREATE TABLE "objects" ( + "ob_type" character varying(16) NOT NULL, + "ob_name" character varying(255) NOT NULL, + "ob_owner" integer, + "ob_acl_get" integer, + "ob_acl_store" integer, + "ob_acl_show" integer, + "ob_acl_destroy" integer, + "ob_acl_flags" integer, + "ob_expires" timestamp, + "ob_created_by" character varying(255) NOT NULL, + "ob_created_from" character varying(255) NOT NULL, + "ob_created_on" timestamp NOT NULL, + "ob_stored_by" character varying(255), + "ob_stored_from" character varying(255), + "ob_stored_on" timestamp, + "ob_downloaded_by" character varying(255), + "ob_downloaded_from" character varying(255), + "ob_downloaded_on" timestamp, + "ob_comment" character varying(255), + PRIMARY KEY ("ob_name", "ob_type") +); +CREATE INDEX "objects_idx_ob_acl_destroy" on "objects" ("ob_acl_destroy"); +CREATE INDEX "objects_idx_ob_acl_flags" on "objects" ("ob_acl_flags"); +CREATE INDEX "objects_idx_ob_acl_get" on "objects" ("ob_acl_get"); +CREATE INDEX "objects_idx_ob_owner" on "objects" ("ob_owner"); +CREATE INDEX "objects_idx_ob_acl_show" on "objects" ("ob_acl_show"); +CREATE INDEX "objects_idx_ob_acl_store" on "objects" ("ob_acl_store"); +CREATE INDEX "objects_idx_ob_type" on "objects" ("ob_type"); + +-- +-- Table: object_history +-- +DROP TABLE "object_history" CASCADE; +CREATE TABLE "object_history" ( + "oh_id" serial NOT NULL, + "oh_type" character varying(16) NOT NULL, + "oh_name" character varying(255) NOT NULL, + "oh_action" character varying(16) NOT NULL, + "oh_field" character varying(16), + "oh_type_field" character varying(255), + "oh_old" character varying(255), + "oh_new" character varying(255), + "oh_by" character varying(255) NOT NULL, + "oh_from" character varying(255) NOT NULL, + "oh_on" timestamp NOT NULL, + PRIMARY KEY ("oh_id") +); +CREATE INDEX "object_history_idx_oh_type_oh_name" on "object_history" ("oh_type", "oh_name"); + +-- +-- Foreign Key Definitions +-- + +ALTER TABLE "acl_entries" ADD FOREIGN KEY ("ae_scheme") + REFERENCES "acl_schemes" ("as_name") DEFERRABLE; + +ALTER TABLE "acl_entries" ADD FOREIGN KEY ("ae_id") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_acl_destroy") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_acl_flags") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_acl_get") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_owner") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_acl_show") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_acl_store") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_type") + REFERENCES "types" ("ty_name") DEFERRABLE; + +ALTER TABLE "object_history" ADD FOREIGN KEY ("oh_type", "oh_name") + REFERENCES "objects" ("ob_type", "ob_name") DEFERRABLE; + diff --git a/perl/sql/Wallet-Schema-0.08-SQLite.sql b/perl/sql/Wallet-Schema-0.08-SQLite.sql new file mode 100644 index 0000000..9936c20 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.08-SQLite.sql @@ -0,0 +1,201 @@ +-- +-- Created by SQL::Translator::Producer::SQLite +-- Created on Fri Jan 25 14:12:02 2013 +-- + +BEGIN TRANSACTION; + +-- +-- Table: acl_history +-- +DROP TABLE IF EXISTS acl_history; + +CREATE TABLE acl_history ( + ah_id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + ah_acl integer NOT NULL, + ah_action varchar(16) NOT NULL, + ah_scheme varchar(32), + ah_identifier varchar(255), + ah_by varchar(255) NOT NULL, + ah_from varchar(255) NOT NULL, + ah_on datetime NOT NULL +); + +-- +-- Table: acl_schemes +-- +DROP TABLE IF EXISTS acl_schemes; + +CREATE TABLE acl_schemes ( + as_name varchar(32) NOT NULL, + as_class varchar(64), + PRIMARY KEY (as_name) +); + +-- +-- Table: acls +-- +DROP TABLE IF EXISTS acls; + +CREATE TABLE acls ( + ac_id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + ac_name varchar(255) NOT NULL +); + +CREATE UNIQUE INDEX ac_name ON acls (ac_name); + +-- +-- Table: enctypes +-- +DROP TABLE IF EXISTS enctypes; + +CREATE TABLE enctypes ( + en_name varchar(255) NOT NULL, + PRIMARY KEY (en_name) +); + +-- +-- Table: flags +-- +DROP TABLE IF EXISTS flags; + +CREATE TABLE flags ( + fl_type varchar(16) NOT NULL, + fl_name varchar(255) NOT NULL, + fl_flag varchar(32) NOT NULL, + PRIMARY KEY (fl_type, fl_name, fl_flag) +); + +-- +-- Table: keytab_enctypes +-- +DROP TABLE IF EXISTS keytab_enctypes; + +CREATE TABLE keytab_enctypes ( + ke_name varchar(255) NOT NULL, + ke_enctype varchar(255) NOT NULL, + PRIMARY KEY (ke_name, ke_enctype) +); + +-- +-- Table: keytab_sync +-- +DROP TABLE IF EXISTS keytab_sync; + +CREATE TABLE keytab_sync ( + ks_name varchar(255) NOT NULL, + ks_target varchar(255) NOT NULL, + PRIMARY KEY (ks_name, ks_target) +); + +-- +-- Table: sync_targets +-- +DROP TABLE IF EXISTS sync_targets; + +CREATE TABLE sync_targets ( + st_name varchar(255) NOT NULL, + PRIMARY KEY (st_name) +); + +-- +-- Table: types +-- +DROP TABLE IF EXISTS types; + +CREATE TABLE types ( + ty_name varchar(16) NOT NULL, + ty_class varchar(64), + PRIMARY KEY (ty_name) +); + +-- +-- Table: acl_entries +-- +DROP TABLE IF EXISTS acl_entries; + +CREATE TABLE acl_entries ( + ae_id integer NOT NULL, + ae_scheme varchar(32) NOT NULL, + ae_identifier varchar(255) NOT NULL, + PRIMARY KEY (ae_id, ae_scheme, ae_identifier), + FOREIGN KEY(ae_scheme) REFERENCES acl_schemes(as_name), + FOREIGN KEY(ae_id) REFERENCES acls(ac_id) +); + +CREATE INDEX acl_entries_idx_ae_scheme ON acl_entries (ae_scheme); + +CREATE INDEX acl_entries_idx_ae_id ON acl_entries (ae_id); + +-- +-- Table: objects +-- +DROP TABLE IF EXISTS objects; + +CREATE TABLE objects ( + ob_type varchar(16) NOT NULL, + ob_name varchar(255) NOT NULL, + ob_owner integer, + ob_acl_get integer, + ob_acl_store integer, + ob_acl_show integer, + ob_acl_destroy integer, + ob_acl_flags integer, + ob_expires datetime, + ob_created_by varchar(255) NOT NULL, + ob_created_from varchar(255) NOT NULL, + ob_created_on datetime NOT NULL, + ob_stored_by varchar(255), + ob_stored_from varchar(255), + ob_stored_on datetime, + ob_downloaded_by varchar(255), + ob_downloaded_from varchar(255), + ob_downloaded_on datetime, + ob_comment varchar(255), + PRIMARY KEY (ob_name, ob_type), + FOREIGN KEY(ob_acl_destroy) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_flags) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_get) REFERENCES acls(ac_id), + FOREIGN KEY(ob_owner) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_show) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_store) REFERENCES acls(ac_id), + FOREIGN KEY(ob_type) REFERENCES types(ty_name) +); + +CREATE INDEX objects_idx_ob_acl_destroy ON objects (ob_acl_destroy); + +CREATE INDEX objects_idx_ob_acl_flags ON objects (ob_acl_flags); + +CREATE INDEX objects_idx_ob_acl_get ON objects (ob_acl_get); + +CREATE INDEX objects_idx_ob_owner ON objects (ob_owner); + +CREATE INDEX objects_idx_ob_acl_show ON objects (ob_acl_show); + +CREATE INDEX objects_idx_ob_acl_store ON objects (ob_acl_store); + +CREATE INDEX objects_idx_ob_type ON objects (ob_type); + +-- +-- Table: object_history +-- +DROP TABLE IF EXISTS object_history; + +CREATE TABLE object_history ( + oh_id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, + oh_type varchar(16) NOT NULL, + oh_name varchar(255) NOT NULL, + oh_action varchar(16) NOT NULL, + oh_field varchar(16), + oh_type_field varchar(255), + oh_old varchar(255), + oh_new varchar(255), + oh_by varchar(255) NOT NULL, + oh_from varchar(255) NOT NULL, + oh_on datetime NOT NULL, + FOREIGN KEY(oh_type) REFERENCES objects(ob_type) +); + +CREATE INDEX object_history_idx_oh_type_oh_name ON object_history (oh_type, oh_name); + +COMMIT; diff --git a/perl/t/admin.t b/perl/t/admin.t index 6250f8e..cf6a637 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -8,12 +8,13 @@ # # See LICENSE for licensing terms. -use Test::More tests => 18; +use Test::More tests => 23; use Wallet::Admin; use Wallet::Report; use Wallet::Schema; use Wallet::Server; +use DBI; use lib 't/lib'; use Util; @@ -56,6 +57,24 @@ is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), undef, is ($server->acl_add ('ADMIN', 'base', 'foo'), 1, ' and adding a base ACL now works'); +# Test an upgrade. Reinitialize to an older version, then test upgrade to +# the current version. +$Wallet::Schema::VERSION = '0.07'; +is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, + ' and re-initialization succeeds'); +$Wallet::Schema::VERSION = '0.08'; +my $schema = $admin->dbh; +$schema->upgrade_directory ('sql/'); +my $retval = $admin->upgrade; +is ($retval, 1, 'Performing an upgrade succeeds'); +my $dbh = $schema->storage->dbh; +my $sql = "select version from dbix_class_schema_versions order by version " + ."DESC"; +$version = $dbh->selectall_arrayref ($sql); +is (@$version, 2, ' and versions table has correct number of rows'); +is (@{ $version->[0] }, 1, ' and correct number of columns'); +is ($version->[0][0], '0.08', ' and the schema version is correct'); + # Clean up. is ($admin->destroy, 1, 'Destruction succeeds'); unlink 'wallet-db'; diff --git a/perl/t/lib/Util.pm b/perl/t/lib/Util.pm index 8bbefc4..c15ccfe 100644 --- a/perl/t/lib/Util.pm +++ b/perl/t/lib/Util.pm @@ -45,6 +45,7 @@ sub contents { # for testing by default, but support t/data/test.database as a configuration # file to use another database backend. sub db_setup { + $Wallet::Config::DB_DDL_DIRECTORY = 'sql/'; if (-f 't/data/test.database') { open (DB, '<', 't/data/test.database') or die "cannot open t/data/test.database: $!"; @@ -60,6 +61,10 @@ sub db_setup { $Wallet::Config::DB_USER = $user if $user; $Wallet::Config::DB_PASSWORD = $password if $password; } else { + + # If we have a new SQLite db by default, disable version checking. + $ENV{DBIC_NO_VERSION_CHECK} = 1; + $Wallet::Config::DB_DRIVER = 'SQLite'; $Wallet::Config::DB_INFO = 'wallet-db'; unlink 'wallet-db'; diff --git a/perl/t/report.t b/perl/t/report.t index 363db20..13ef7b6 100755 --- a/perl/t/report.t +++ b/perl/t/report.t @@ -145,7 +145,7 @@ is (scalar (@lines), 1, 'Searching for objects owned by ADMIN finds one'); is ($lines[0][0], 'base', ' and it has the right type'); is ($lines[0][1], 'service/admin', ' and the right name'); @lines = $report->objects ('owner', 'null'); -is (scalar (@lines), 1, 'Searching for objects with no set ownerfinds one'); +is (scalar (@lines), 1, 'Searching for objects with no set owner finds one'); is ($lines[0][0], 'base', ' and it has the right type'); is ($lines[0][1], 'service/null', ' and the right name'); @lines = $report->objects ('acl', 'ADMIN'); diff --git a/perl/t/schema.t b/perl/t/schema.t deleted file mode 100755 index 5dd90d1..0000000 --- a/perl/t/schema.t +++ /dev/null @@ -1,111 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the wallet schema class. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2011 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 16; - -use DBI (); -use POSIX qw(strftime); -use Wallet::Config (); -use Wallet::Schema (); - -use lib 't/lib'; -use Util; - -my $schema = Wallet::Schema->new; -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), 32, ' and returns the right number of statements'); - -# Connect to a database and test create. -db_setup; -my $connect = "DBI:${Wallet::Config::DB_DRIVER}:${Wallet::Config::DB_INFO}"; -my $user = $Wallet::Config::DB_USER; -my $password = $Wallet::Config::DB_PASSWORD; -$dbh = DBI->connect ($connect, $user, $password); -if (not defined $dbh) { - die "cannot connect to database $connect: $DBI::errstr\n"; -} -$dbh->{RaiseError} = 1; -$dbh->{PrintError} = 0; -eval { $schema->create ($dbh) }; -is ($@, '', "create() doesn't die"); - -# Check that the version number is correct. -my $sql = "select md_version from metadata"; -my $version = $dbh->selectall_arrayref ($sql); -is (@$version, 1, 'metadata has correct number of rows'); -is (@{ $version->[0] }, 1, ' and correct number of columns'); -is ($version->[0][0], 1, ' and the schema version is correct'); - -# Test upgrading the database from version 0. SQLite cannot drop table -# columns, so we have to kill the table and then recreate it. -$dbh->do ("drop table metadata"); -if (lc ($Wallet::Config::DB_DRIVER) eq 'sqlite') { - ($sql) = grep { /create table objects/ } $schema->sql; - $sql =~ s/ob_comment .*,//; - $dbh->do ("drop table objects") - or die "cannot drop objects table: $DBI::errstr\n"; - $dbh->do ($sql) - or die "cannot recreate objects table: $DBI::errstr\n"; -} else { - $dbh->do ("alter table objects drop column ob_comment") - or die "cannot drop ob_comment column: $DBI::errstr\n"; -} -eval { $schema->upgrade ($dbh) }; -is ($@, '', "upgrade() doesn't die"); -$sql = "select md_version from metadata"; -$version = $dbh->selectall_arrayref ($sql); -is (@$version, 1, ' and metadata has correct number of rows'); -is (@{ $version->[0] }, 1, ' and correct number of columns'); -is ($version->[0][0], 1, ' and the schema version is correct'); -$sql = "insert into objects (ob_type, ob_name, ob_created_by, ob_created_from, - ob_created_on, ob_comment) values ('file', 'test', 'test', - 'test.example.org', ?, 'a test comment')"; -$dbh->do ($sql, undef, strftime ('%Y-%m-%d %T', localtime time)); -$sql = "select ob_comment from objects where ob_name = 'test'"; -my ($comment) = $dbh->selectrow_array ($sql); -is ($comment, 'a test comment', ' and ob_comment was added to objects'); - -# Test dropping the database. -eval { $schema->drop ($dbh) }; -is ($@, '', "drop() doesn't die"); - -# Make sure all the tables are gone. -SKIP: { - if (lc ($Wallet::Config::DB_DRIVER) eq 'sqlite') { - my $sql = "select name from sqlite_master where type = 'table'"; - my $sth = $dbh->prepare ($sql); - $sth->execute; - my ($table, @tables); - while (defined ($table = $sth->fetchrow_array)) { - push (@tables, $table) unless $table =~ /^sqlite_/; - } - is ("@tables", '', ' and there are no tables in the database'); - } elsif (lc ($Wallet::Config::DB_DRIVER) eq 'mysql') { - my $sql = "show tables"; - my $sth = $dbh->prepare ($sql); - $sth->execute; - my ($table, @tables); - while (defined ($table = $sth->fetchrow_array)) { - push (@tables, $table); - } - is ("@tables", '', ' and there are no tables in the database'); - } else { - skip 1; - } -} -eval { $schema->create ($dbh) }; -is ($@, '', ' and we can run create again'); - -# Clean up. -eval { $schema->drop ($dbh) }; -unlink 'wallet-db'; diff --git a/perl/t/server.t b/perl/t/server.t index 8e0a30d..63f2e76 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -1030,5 +1030,5 @@ is ($@, "database connection information not configured\n", ' or if DB_INFO is not set'); $Wallet::Config::DB_INFO = 't'; $server = eval { Wallet::Server->new ($user2, $host) }; -like ($@, qr/^cannot connect to database: /, +like ($@, qr/unable to open database file/, ' or if the database connection fails'); diff --git a/server/wallet-admin b/server/wallet-admin index 94d62c7..7e5a402 100755 --- a/server/wallet-admin +++ b/server/wallet-admin @@ -15,6 +15,13 @@ use strict; use Wallet::Admin; +# The last non-DBIx::Class version. If a database has no DBIx::Class +# versioning, we want to set it to this so that upgrades can begin. +our $BASE_VERSION = '0.07'; + +# Directory that contains the wallet SQL files for upgrades. +our $SQL_DIR = '/usr/share/wallet/sql/'; + ############################################################################## # Implementation ############################################################################## @@ -41,6 +48,9 @@ sub command { die "too few arguments to initialize\n" if @args < 1; die "invalid admin principal $args[0]\n" unless $args[0] =~ /^[^\@\s]+\@\S+$/; + + my $schema = $admin->{dbh}; + $schema->upgrade_directory ($SQL_DIR); $admin->initialize (@args) or die $admin->error, "\n"; } elsif ($command eq 'register') { die "too many arguments to register\n" if @args > 3; @@ -59,7 +69,20 @@ sub command { } } elsif ($command eq 'upgrade') { die "too many arguments to upgrade\n" if @args; + + my $schema = $admin->{dbh}; + $schema->upgrade_directory ($SQL_DIR); + + # Check to see if the database is versioned. If not, install the + # versioning table and default version. + if (!$schema->get_db_version) { + print "Versioning database.\n"; + $schema->install ($BASE_VERSION); + } + + # Actually upgrade. $admin->upgrade or die $admin->error, "\n"; + } else { die "unknown command $command\n"; } -- cgit v1.2.3 From a30984dc9602e5a7efe9556f337eb21dbcec8319 Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 31 Jan 2013 14:38:25 -0800 Subject: Fixed errors with Keytab object and its tests perl/Wallet/Object/Keytab.pm was using the wrong value for the database handle in some places (trying to load as a subroutine rather than part of the object). Also, the keytab.t tests were attempting to run against the DBIx::Class object rather than a direct dbh handle that they expected. Change-Id: Ifbb8b110d559f3ba867fc5b0dc3933fd2d4fd484 Reviewed-on: https://gerrit.stanford.edu/731 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/Object/Keytab.pm | 8 +++---- perl/t/keytab.t | 55 +++++++++++++++++++++++++++++--------------- 2 files changed, 40 insertions(+), 23 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index 083dae6..b50fb6e 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -140,8 +140,8 @@ sub sync_set { eval { my $name = $self->{name}; my %search = (ks_name => $name); - my $sync_rs = $self->dbh->resultset('KeytabSync') - ->search (\%search); + my $sync_rs = $self->{dbh}->resultset('KeytabSync') + ->find (\%search); if (defined $sync_rs) { my $target = $sync_rs->ks_target; $sync_rs->delete; @@ -167,8 +167,8 @@ sub sync_list { eval { my %search = (ks_name => $self->{name}); my %attrs = (order_by => 'ks_target'); - my @syncs = $self->dbh->resultset('KeytabSync')->search (\%search, - \%attrs); + my @syncs = $self->{dbh}->resultset('KeytabSync')->search (\%search, + \%attrs); for my $sync_rs (@syncs) { push (@targets, $sync_rs->ks_target); } diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 01def75..c263f58 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -13,6 +13,7 @@ use Test::More tests => 139; BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } +use DBI; use Wallet::Admin; use Wallet::Config; use Wallet::Kadmin; @@ -146,7 +147,8 @@ db_setup; my $admin = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $dbh = $admin->dbh; +my $schema = $admin->dbh; +my $dbh = $schema->storage->dbh; # Use this to accumulate the history traces so that we can check history. my $history = ''; @@ -173,7 +175,8 @@ SKIP: { # Test that object creation without KEYTAB_TMP fails. undef $Wallet::Config::KEYTAB_TMP; $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; is ($object, undef, 'Creating keytab without KEYTAB_TMP fails'); is ($@, "KEYTAB_TMP configuration variable not set\n", @@ -182,7 +185,8 @@ SKIP: { # Okay, now we can test. First, create. $object = eval { - Wallet::Object::Keytab->create ('keytab', "wallet\nf", $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', "wallet\nf", $schema, + @trace) }; is ($object, undef, 'Creating malformed principal fails'); if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { @@ -192,7 +196,7 @@ SKIP: { ' with the right error'); } $object = eval { - Wallet::Object::Keytab->create ('keytab', '', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', '', $schema, @trace) }; is ($object, undef, 'Creating empty principal fails'); if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { @@ -201,7 +205,8 @@ SKIP: { like ($@, qr/^error adding principal \@/, ' with the right error'); } $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; if (defined ($object)) { ok (defined ($object), 'Creating good principal succeeds'); @@ -212,7 +217,8 @@ SKIP: { ok (created ('wallet/one'), ' and the principal was created'); create ('wallet/two'); $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/two', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/two', $schema, + @trace) }; if (defined ($object)) { ok (defined ($object), 'Creating an existing principal succeeds'); @@ -224,13 +230,13 @@ SKIP: { is ($object->error, undef, ' with no error message'); ok (! created ('wallet/two'), ' and now it does not exist'); my @name = qw(keytab wallet-test/one); - $object = eval { Wallet::Object::Keytab->create (@name, $dbh, @trace) }; + $object = eval { Wallet::Object::Keytab->create (@name, $schema, @trace) }; is ($object, undef, 'Creation without permissions fails'); like ($@, qr{^error adding principal wallet-test/one\@\Q$realm: }, ' with the right error'); # Now, try retrieving the keytab. - $object = Wallet::Object::Keytab->new ('keytab', 'wallet/one', $dbh); + $object = Wallet::Object::Keytab->new ('keytab', 'wallet/one', $schema); ok (defined ($object), 'Retrieving the object works'); ok ($object->isa ('Wallet::Object::Keytab'), ' and is the right type'); is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); @@ -283,7 +289,8 @@ EOO # Test principal deletion on object destruction. $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; ok (defined ($object), 'Creating good principal succeeds'); ok (created ('wallet/one'), ' and the principal was created'); @@ -332,7 +339,8 @@ EOO # Test configuration errors. undef $Wallet::Config::KEYTAB_FILE; $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; is ($object, undef, 'Creating with bad configuration fails'); is ($@, "keytab object implementation not configured\n", @@ -340,7 +348,8 @@ EOO $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; undef $Wallet::Config::KEYTAB_PRINCIPAL; $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; is ($object, undef, ' likewise with another missing variable'); is ($@, "keytab object implementation not configured\n", @@ -348,7 +357,8 @@ EOO $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); undef $Wallet::Config::KEYTAB_REALM; $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; is ($object, undef, ' and another'); is ($@, "keytab object implementation not configured\n", @@ -356,14 +366,16 @@ EOO $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); undef $Wallet::Config::KEYTAB_KRBTYPE; $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; is ($object, undef, ' and another'); is ($@, "keytab object implementation not configured\n", ' with the right error'); $Wallet::Config::KEYTAB_KRBTYPE = 'Active Directory'; $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; is ($object, undef, ' and one set to an invalid value'); is ($@, "unknown KEYTAB_KRBTYPE setting: Active Directory\n", @@ -387,12 +399,14 @@ SKIP: { # Create the objects for testing and set the unchanging flag. my $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; ok (defined ($one), 'Creating wallet/one succeeds'); is ($one->flag_set ('unchanging', @trace), 1, ' and setting unchanging'); my $two = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/two', $dbh, @trace); + Wallet::Object::Keytab->create ('keytab', 'wallet/two', $schema, + @trace); }; ok (defined ($two), 'Creating wallet/two succeeds'); is ($two->flag_set ('unchanging', @trace), 1, ' and setting unchanging'); @@ -507,7 +521,8 @@ SKIP: { # Test setting synchronization attributes, which can also be done without # configuration. my $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; ok (defined ($one), 'Creating wallet/one succeeds'); my $expected = <<"EOO"; @@ -584,7 +599,8 @@ SKIP: { # Create an object for testing and determine the enctypes we have to work # with. my $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; if (defined ($one)) { ok (1, 'Creating wallet/one succeeds'); @@ -730,7 +746,8 @@ EOO 'Setting a single enctype works'); is ($one->destroy (@trace), 1, ' and destroying the object works'); $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $dbh, @trace) + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) }; ok (defined ($one), ' as does recreating it'); @values = $one->attr ('enctypes'); -- cgit v1.2.3 From bf18b39b6afe541e6888d32d6a555643cbe9d22e Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 31 Jan 2013 16:27:49 -0800 Subject: Renamed dbh subroutines and variables for clarity In moving from DBI to DBIx::Class, we at first left the various variables the same. This goes through to update them for the proper names. * Wallet::Admin::schema was created to return the schema object (and similarly for Wallet::Server and Wallet::Report). * Wallet::Admin::dbh was modified to return the actual DBI handle again (and similarly for Wallet::Server and Wallet::Report). * Various places that used $admin->{dbh} were moved to $admin->{schema}. * Various places using $dbh for the schema object were changed to $schema. Change-Id: I00914866e9a8250855a7828474aa9ce0f37b914f Reviewed-on: https://gerrit.stanford.edu/733 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/ACL.pm | 64 ++++++++++++++++----------------- perl/Wallet/Admin.pm | 49 ++++++++++++++----------- perl/Wallet/Object/Base.pm | 80 ++++++++++++++++++++--------------------- perl/Wallet/Object/File.pm | 2 +- perl/Wallet/Object/Keytab.pm | 43 +++++++++++----------- perl/Wallet/Object/WAKeyring.pm | 2 +- perl/Wallet/Report.pm | 50 ++++++++++++++------------ perl/Wallet/Schema.pm | 6 ++-- perl/Wallet/Server.pm | 64 +++++++++++++++++++-------------- perl/t/acl.t | 26 +++++++------- perl/t/admin.t | 4 +-- perl/t/file.t | 14 ++++---- perl/t/init.t | 6 ++-- perl/t/keytab.t | 4 +-- perl/t/object.t | 20 +++++------ perl/t/server.t | 4 +-- perl/t/wa-keyring.t | 10 +++--- 17 files changed, 236 insertions(+), 212 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm index 4f51c70..1e62e7b 100644 --- a/perl/Wallet/ACL.pm +++ b/perl/Wallet/ACL.pm @@ -32,7 +32,7 @@ $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 ($class, $id, $schema) = @_; my (%search, $data, $name); if ($id =~ /^\d+\z/) { $search{ac_id} = $id; @@ -40,7 +40,7 @@ sub new { $search{ac_name} = $id; } eval { - $data = $dbh->resultset('Acl')->find (\%search); + $data = $schema->resultset('Acl')->find (\%search); }; if ($@) { die "cannot search for ACL $id: $@\n"; @@ -48,9 +48,9 @@ sub new { die "ACL $id not found\n"; } my $self = { - dbh => $dbh, - id => $data->ac_id, - name => $data->ac_name, + schema => $schema, + id => $data->ac_id, + name => $data->ac_name, }; bless ($self, $class); return $self; @@ -60,18 +60,18 @@ 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 $guard = $dbh->txn_scope_guard; + my $guard = $schema->txn_scope_guard; # Create the new record. my %record = (ac_name => $name); - my $acl = $dbh->resultset('Acl')->create (\%record); + my $acl = $schema->resultset('Acl')->create (\%record); $id = $acl->ac_id; die "unable to retrieve new ACL ID" unless defined $id; @@ -82,7 +82,7 @@ sub create { ah_by => $user, ah_from => $host, ah_on => $date); - my $history = $dbh->resultset('AclHistory')->create (\%record); + my $history = $schema->resultset('AclHistory')->create (\%record); die "unable to create new history entry" unless defined $history; $guard->commit; @@ -91,9 +91,9 @@ sub create { 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; @@ -134,7 +134,7 @@ sub scheme_mapping { my $class; eval { my %search = (as_name => $scheme); - my $scheme_rec = $self->{dbh}->resultset('AclScheme') + my $scheme_rec = $self->{schema}->resultset('AclScheme') ->find (\%search); $class = $scheme_rec->as_class; }; @@ -169,7 +169,7 @@ sub log_acl { ah_by => $user, ah_from => $host, ah_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{dbh}->resultset('AclHistory')->create (\%record); + $self->{schema}->resultset('AclHistory')->create (\%record); } ############################################################################## @@ -186,9 +186,9 @@ sub rename { return; } eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %search = (ac_id => $self->{id}); - my $acls = $self->{dbh}->resultset('Acl')->find (\%search); + my $acls = $self->{schema}->resultset('Acl')->find (\%search); $acls->ac_name ($name); $acls->update; $guard->commit; @@ -212,7 +212,7 @@ sub destroy { my ($self, $user, $host, $time) = @_; $time ||= time; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; # Make certain no one is using the ACL. my @search = ({ ob_owner => $self->{id} }, @@ -221,7 +221,7 @@ sub destroy { { ob_acl_show => $self->{id} }, { ob_acl_destroy => $self->{id} }, { ob_acl_flags => $self->{id} }); - my @entries = $self->{dbh}->resultset('Object')->search (\@search); + my @entries = $self->{schema}->resultset('Object')->search (\@search); if (@entries) { my ($entry) = @entries; die "ACL in use by ".$entry->ob_type.":".$entry->ob_name; @@ -229,14 +229,14 @@ sub destroy { # Delete any entries (there may or may not be any). my %search = (ae_id => $self->{id}); - @entries = $self->{dbh}->resultset('AclEntry')->search(\%search); + @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->{dbh}->resultset('Acl')->find(\%search); + my $entry = $self->{schema}->resultset('Acl')->find(\%search); $entry->delete if defined $entry; # Create new history line for the deletion. @@ -245,7 +245,7 @@ sub destroy { ah_by => $user, ah_from => $host, ah_on => $time); - $self->{dbh}->resultset('AclHistory')->create (\%record); + $self->{schema}->resultset('AclHistory')->create (\%record); $guard->commit; }; if ($@) { @@ -268,11 +268,11 @@ sub add { return; } eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %record = (ae_id => $self->{id}, ae_scheme => $scheme, ae_identifier => $identifier); - my $entry = $self->{dbh}->resultset('AclEntry')->create (\%record); + my $entry = $self->{schema}->resultset('AclEntry')->create (\%record); $self->log_acl ('add', $scheme, $identifier, $user, $host, $time); $guard->commit; }; @@ -290,11 +290,11 @@ sub remove { my ($self, $scheme, $identifier, $user, $host, $time) = @_; $time ||= time; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %search = (ae_id => $self->{id}, ae_scheme => $scheme, ae_identifier => $identifier); - my $entry = $self->{dbh}->resultset('AclEntry')->find (\%search); + my $entry = $self->{schema}->resultset('AclEntry')->find (\%search); unless (defined $entry) { die "entry not found in ACL\n"; } @@ -322,9 +322,9 @@ sub list { undef $self->{error}; my @entries; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %search = (ae_id => $self->{id}); - my @entry_recs = $self->{dbh}->resultset('AclEntry') + my @entry_recs = $self->{schema}->resultset('AclEntry') ->search (\%search); for my $entry (@entry_recs) { push (@entries, [ $entry->ae_scheme, $entry->ae_identifier ]); @@ -364,11 +364,11 @@ sub history { my ($self) = @_; my $output = ''; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %search = (ah_acl => $self->{id}); my %options = (order_by => 'ah_on'); - my @data = $self->{dbh}->resultset('AclHistory')->search (\%search, - \%options); + 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); @@ -512,14 +512,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::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/Admin.pm b/perl/Wallet/Admin.pm index c0b1730..9fc146c 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -39,8 +39,8 @@ our $BASE_VERSION = '0.07'; # Throw an exception if anything goes wrong. sub new { my ($class) = @_; - my $dbh = Wallet::Schema->connect; - my $self = { dbh => $dbh }; + my $schema = Wallet::Schema->connect; + my $self = { schema => $schema }; bless ($self, $class); return $self; } @@ -48,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. @@ -66,7 +72,7 @@ sub error { # Disconnect the database handle on object destruction to avoid warnings. sub DESTROY { my ($self) = @_; - $self->{dbh}->storage->dbh->disconnect; + $self->{schema}->storage->dbh->disconnect; } ############################################################################## @@ -83,7 +89,7 @@ sub initialize { # Deploy the database schema from DDL files, if they exist. If not then # we automatically get the database from the Schema modules. - $self->{dbh}->deploy ({}, $Wallet::Config::DB_DDL_DIRECTORY); + $self->{schema}->deploy ({}, $Wallet::Config::DB_DDL_DIRECTORY); if ($@) { $self->error ($@); return; @@ -91,7 +97,8 @@ sub initialize { $self->default_data; # Create a default admin ACL. - my $acl = Wallet::ACL->create ('ADMIN', $self->{dbh}, $user, 'localhost'); + my $acl = Wallet::ACL->create ('ADMIN', $self->{schema}, $user, + 'localhost'); unless ($acl->add ('krb5', $user, $user, 'localhost')) { $self->error ($acl->error); return; @@ -106,7 +113,7 @@ sub default_data { my ($self) = @_; # acl_schemes default rows. - my ($r1) = $self->{dbh}->resultset('AclScheme')->populate ([ + my ($r1) = $self->{schema}->resultset('AclScheme')->populate ([ [ qw/as_name as_class/ ], [ 'krb5', 'Wallet::ACL::Krb5' ], [ 'krb5-regex', 'Wallet::ACL::Krb5::Regex' ], @@ -120,7 +127,7 @@ sub default_data { my @record = ([ qw/ty_name ty_class/ ], [ 'file', 'Wallet::Object::File' ], [ 'keytab', 'Wallet::Object::Keytab' ]); - ($r1) = $self->{dbh}->resultset('Type')->populate (\@record); + ($r1) = $self->{schema}->resultset('Type')->populate (\@record); warn "default Type not installed" unless defined $r1; return 1; @@ -141,13 +148,13 @@ sub destroy { my ($self) = @_; # Get an actual DBI handle and use it to delete all tables. - my $real_dbh = $self->{dbh}->storage->dbh; + 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"; - $real_dbh->do ($sql); + $dbh->do ($sql); } return 1; @@ -160,9 +167,9 @@ sub backup { my @dbs = qw/MySQL SQLite PostgreSQL/; my $version = $Wallet::Schema::VERSION; - $self->{dbh}->create_ddl_dir (\@dbs, $version, - $Wallet::Config::DB_DDL_DIRECTORY, - $oldversion); + $self->{schema}->create_ddl_dir (\@dbs, $version, + $Wallet::Config::DB_DDL_DIRECTORY, + $oldversion); return 1; } @@ -174,8 +181,8 @@ sub upgrade { # Check to see if the database is versioned. If not, install the # versioning table and default version. - if (!$self->{dbh}->get_db_version) { - $self->{dbh}->install ($BASE_VERSION); + if (!$self->{schema}->get_db_version) { + $self->{schema}->install ($BASE_VERSION); } # Suppress warnings that actually are just informational messages. @@ -187,8 +194,8 @@ sub upgrade { }; # Perform the actual upgrade. - if ($self->{dbh}->get_db_version) { - eval { $self->{dbh}->upgrade; }; + if ($self->{schema}->get_db_version) { + eval { $self->{schema}->upgrade; }; } if ($@) { $self->error ($@); @@ -210,10 +217,10 @@ sub upgrade { sub register_object { my ($self, $type, $class) = @_; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %record = (ty_name => $type, ty_class => $class); - $self->{dbh}->resultset('Type')->create (\%record); + $self->{schema}->resultset('Type')->create (\%record); $guard->commit; }; if ($@) { @@ -230,10 +237,10 @@ sub register_object { sub register_verifier { my ($self, $scheme, $class) = @_; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %record = (as_name => $scheme, as_class => $class); - $self->{dbh}->resultset('AclScheme')->create (\%record); + $self->{schema}->resultset('AclScheme')->create (\%record); $guard->commit; }; if ($@) { diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm index 5bd89a7..dd128cc 100644 --- a/perl/Wallet/Object/Base.pm +++ b/perl/Wallet/Object/Base.pm @@ -36,16 +36,16 @@ $VERSION = '0.06'; # 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 ($class, $type, $name, $schema) = @_; my %search = (ob_type => $type, ob_name => $name); - my $object = $dbh->resultset('Object')->find (\%search); + 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; @@ -56,11 +56,11 @@ 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 = $dbh->txn_scope_guard; + my $guard = $schema->txn_scope_guard; eval { my %record = (ob_type => $type, ob_name => $name, @@ -68,7 +68,7 @@ sub create { ob_created_from => $host, ob_created_on => strftime ('%Y-%m-%d %T', localtime $time)); - $dbh->resultset('Object')->create (\%record); + $schema->resultset('Object')->create (\%record); %record = (oh_type => $type, oh_name => $name, @@ -76,7 +76,7 @@ sub create { oh_by => $user, oh_from => $host, oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $dbh->resultset('ObjectHistory')->create (\%record); + $schema->resultset('ObjectHistory')->create (\%record); $guard->commit; }; @@ -84,9 +84,9 @@ sub create { 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; @@ -136,7 +136,7 @@ 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->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; eval { my %record = (oh_type => $self->{type}, oh_name => $self->{name}, @@ -144,11 +144,11 @@ sub log_action { oh_by => $user, oh_from => $host, oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{dbh}->resultset('ObjectHistory')->create (\%record); + $self->{schema}->resultset('ObjectHistory')->create (\%record); my %search = (ob_type => $self->{type}, ob_name => $self->{name}); - my $object = $self->{dbh}->resultset('Object')->find (\%search); + my $object = $self->{schema}->resultset('Object')->find (\%search); if ($action eq 'get') { $object->ob_downloaded_by ($user); $object->ob_downloaded_from ($host); @@ -202,7 +202,7 @@ sub log_set { oh_by => $user, oh_from => $host, oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{dbh}->resultset('ObjectHistory')->create (\%record); + $self->{schema}->resultset('ObjectHistory')->create (\%record); } ############################################################################## @@ -225,11 +225,11 @@ sub _set_internal { return; } - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; eval { my %search = (ob_type => $type, ob_name => $name); - my $object = $self->{dbh}->resultset('Object')->find (\%search); + my $object = $self->{schema}->resultset('Object')->find (\%search); my $old = $object->get_column ("ob_$attr"); $object->update ({ "ob_$attr" => $value }); @@ -261,7 +261,7 @@ sub _get_internal { eval { my %search = (ob_type => $type, ob_name => $name); - my $object = $self->{dbh}->resultset('Object')->find (\%search); + my $object = $self->{schema}->resultset('Object')->find (\%search); $value = $object->get_column ($attr); }; if ($@) { @@ -282,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; @@ -352,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; @@ -375,13 +375,13 @@ 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 %search = (fl_type => $type, fl_name => $name, fl_flag => $flag); - my $flag = $dbh->resultset('Flag')->find (\%search); + my $flag = $schema->resultset('Flag')->find (\%search); if (not defined $flag) { $value = 0; } else { @@ -403,13 +403,13 @@ sub flag_clear { $time ||= time; my $name = $self->{name}; my $type = $self->{type}; - my $dbh = $self->{dbh}; - my $guard = $dbh->txn_scope_guard; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; eval { my %search = (fl_type => $type, fl_name => $name, fl_flag => $flag); - my $flag = $dbh->resultset('Flag')->find (\%search); + my $flag = $schema->resultset('Flag')->find (\%search); unless (defined $flag) { die "flag not set\n"; } @@ -435,8 +435,8 @@ sub flag_list { my %search = (fl_type => $self->{type}, fl_name => $self->{name}); my %attrs = (order_by => 'fl_flag'); - my @flags_rs = $self->{dbh}->resultset('Flag')->search (\%search, - \%attrs); + my @flags_rs = $self->{schema}->resultset('Flag')->search (\%search, + \%attrs); for my $flag (@flags_rs) { push (@flags, $flag->fl_flag); } @@ -457,17 +457,17 @@ sub flag_set { $time ||= time; my $name = $self->{name}; my $type = $self->{type}; - my $dbh = $self->{dbh}; - my $guard = $dbh->txn_scope_guard; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; eval { my %search = (fl_type => $type, fl_name => $name, fl_flag => $flag); - my $flag = $dbh->resultset('Flag')->find (\%search); + my $flag = $schema->resultset('Flag')->find (\%search); if (defined $flag) { die "flag already set\n"; } - $flag = $dbh->resultset('Flag')->create (\%search); + $flag = $schema->resultset('Flag')->create (\%search); $self->log_set ('flags', undef, $flag->fl_flag, $user, $host, $time); $guard->commit; }; @@ -489,7 +489,7 @@ sub format_acl_id { my $name = $id; my %search = (ac_id => $id); - my $acl_rs = $self->{dbh}->resultset('Acl')->find (\%search); + my $acl_rs = $self->{schema}->resultset('Acl')->find (\%search); if (defined $acl_rs) { $name = $acl_rs->ac_name . " ($id)"; } @@ -507,7 +507,7 @@ sub history { my %search = (oh_type => $self->{type}, oh_name => $self->{name}); my %attrs = (order_by => 'oh_on'); - my @history = $self->{dbh}->resultset('ObjectHistory') + my @history = $self->{schema}->resultset('ObjectHistory') ->search (\%search, \%attrs); for my $history_rs (@history) { @@ -620,7 +620,7 @@ sub show { eval { my %search = (ob_type => $type, ob_name => $name); - $object_rs = $self->{dbh}->resultset('Object')->find (\%search); + $object_rs = $self->{schema}->resultset('Object')->find (\%search); }; if ($@) { $self->error ("cannot retrieve data for ${type}:${name}: $@"); @@ -658,7 +658,7 @@ sub show { $output .= $attr_output; } if ($field =~ /^ob_(owner|acl_)/) { - my $acl = eval { Wallet::ACL->new ($value, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($value, $self->{schema}) }; if ($acl and not $@) { $value = $acl->name || $value; push (@acls, [ $acl, $value ]); @@ -688,18 +688,18 @@ sub destroy { $self->error ("cannot destroy ${type}:${name}: object is locked"); return; } - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; eval { # Remove any flags that may exist for the record. my %search = (fl_type => $type, fl_name => $name); - $self->{dbh}->resultset('Flag')->search (\%search)->delete; + $self->{schema}->resultset('Flag')->search (\%search)->delete; # Remove any object records %search = (ob_type => $type, ob_name => $name); - $self->{dbh}->resultset('Object')->search (\%search)->delete; + $self->{schema}->resultset('Object')->search (\%search)->delete; # And create a new history object for the destroy action. my %record = (oh_type => $type, @@ -708,7 +708,7 @@ sub destroy { oh_by => $user, oh_from => $host, oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{dbh}->resultset('ObjectHistory')->create (\%record); + $self->{schema}->resultset('ObjectHistory')->create (\%record); $guard->commit; }; if ($@) { diff --git a/perl/Wallet/Object/File.pm b/perl/Wallet/Object/File.pm index 47c8ac2..69468e1 100644 --- a/perl/Wallet/Object/File.pm +++ b/perl/Wallet/Object/File.pm @@ -143,7 +143,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 b50fb6e..962c19b 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -40,12 +40,12 @@ sub enctypes_set { my @trace = ($user, $host, $time); my $name = $self->{name}; my %enctypes = map { $_ => 1 } @$enctypes; - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; eval { # Find all enctypes for the given keytab. my %search = (ke_name => $name); - my @enctypes = $self->{dbh}->resultset('KeytabEnctype') + my @enctypes = $self->{schema}->resultset('KeytabEnctype') ->search (\%search); my (@current); for my $enctype_rs (@enctypes) { @@ -61,7 +61,7 @@ sub enctypes_set { } else { %search = (ke_name => $name, ke_enctype => $enctype); - $self->{dbh}->resultset('KeytabEnctype')->find (\%search) + $self->{schema}->resultset('KeytabEnctype')->find (\%search) ->delete; $self->log_set ('type_data enctypes', $enctype, undef, @trace); } @@ -73,13 +73,13 @@ sub enctypes_set { # to make it easier to test. for my $enctype (sort keys %enctypes) { my %search = (en_name => $enctype); - my $enctype_rs = $self->{dbh}->('Enctype')->find (\%search); + my $enctype_rs = $self->{schema}->('Enctype')->find (\%search); unless (defined $enctype_rs) { die "unknown encryption type $enctype\n"; } my %record = (ke_name => $name, ke_enctype => $enctype); - $self->{dbh}->resultset('Enctype')->create (\%record); + $self->{schema}->resultset('Enctype')->create (\%record); $self->log_set ('type_data enctypes', undef, $enctype, @trace); } $guard->commit; @@ -101,7 +101,7 @@ sub enctypes_list { eval { my %search = (ke_name => $self->{name}); my %attrs = (order_by => 'ke_enctype'); - my @enctypes_rs = $self->{dbh}->resultset('KeytabEnctype') + my @enctypes_rs = $self->{schema}->resultset('KeytabEnctype') ->search (\%search, \%attrs); for my $enctype_rs (@enctypes_rs) { push (@enctypes, $enctype_rs->ke_enctype); @@ -136,11 +136,11 @@ sub sync_set { $self->error ("unsupported synchronization target $target"); return; } else { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; eval { my $name = $self->{name}; my %search = (ks_name => $name); - my $sync_rs = $self->{dbh}->resultset('KeytabSync') + my $sync_rs = $self->{schema}->resultset('KeytabSync') ->find (\%search); if (defined $sync_rs) { my $target = $sync_rs->ks_target; @@ -167,8 +167,8 @@ sub sync_list { eval { my %search = (ks_name => $self->{name}); my %attrs = (order_by => 'ks_target'); - my @syncs = $self->{dbh}->resultset('KeytabSync')->search (\%search, - \%attrs); + my @syncs = $self->{schema}->resultset('KeytabSync')->search (\%search, + \%attrs); for my $sync_rs (@syncs) { push (@targets, $sync_rs->ks_target); } @@ -239,16 +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; - $self = $class->SUPER::new ($type, $name, $dbh); + $self = $class->SUPER::new ($type, $name, $schema); $self->{kadmin} = $kadmin; return $self; } @@ -258,9 +258,9 @@ 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; @@ -270,7 +270,8 @@ sub create { 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; } @@ -283,15 +284,15 @@ sub destroy { $self->error ("cannot destroy $id: object is locked"); return; } - my $dbh = $self->{dbh}; - my $guard = $dbh->txn_scope_guard; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; eval { my %search = (ks_name => $self->{name}); - my $sync_rs = $dbh->resultset('KeytabSync')->search (\%search); + my $sync_rs = $schema->resultset('KeytabSync')->search (\%search); $sync_rs->delete_all if defined $sync_rs; %search = (ke_name => $self->{name}); - my $enctype_rs = $dbh->resultset('KeytabEnctype')->search (\%search); + my $enctype_rs = $schema->resultset('KeytabEnctype')->search (\%search); $enctype_rs->delete_all if defined $enctype_rs; $guard->commit; @@ -353,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 index b26be58..f33497c 100644 --- a/perl/Wallet/Object/WAKeyring.pm +++ b/perl/Wallet/Object/WAKeyring.pm @@ -255,7 +255,7 @@ Wallet::Object::WAKeyring - WebAuth keyring object implementation for wallet my ($user, $host, $time); my @name = qw(wa-keyring www.stanford.edu); my @trace = ($user, $host, $time); - my $object = Wallet::Object::WAKeyring->create (@name, $dbh, $trace); + my $object = Wallet::Object::WAKeyring->create (@name, $schema, $trace); my $keyring = $object->get (@trace); unless ($object->store ($keyring)) { die $object->error, "\n"; diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index ea8cd2f..ff25b3a 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -32,8 +32,8 @@ $VERSION = '0.04'; # exception if anything goes wrong. sub new { my ($class) = @_; - my $dbh = Wallet::Schema->connect; - my $self = { dbh => $dbh }; + my $schema = Wallet::Schema->connect; + my $self = { schema => $schema }; bless ($self, $class); return $self; } @@ -41,7 +41,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 +65,7 @@ sub error { # Disconnect the database handle on object destruction to avoid warnings. sub DESTROY { my ($self) = @_; - $self->{dbh}->storage->dbh->disconnect; + $self->{schema}->storage->dbh->disconnect; } ############################################################################## @@ -106,7 +112,7 @@ sub objects_owner { if (lc ($owner) eq 'null') { %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; %search = (ob_owner => $acl->id); } @@ -138,8 +144,8 @@ sub objects_acl { my ($self, $search) = @_; my @objects; - my $dbh = $self->{dbh}; - my $acl = eval { Wallet::ACL->new ($search, $dbh) }; + my $schema = $self->{schema}; + my $acl = eval { Wallet::ACL->new ($search, $schema) }; return unless $acl; my @search = ({ ob_owner => $acl->id }, @@ -202,10 +208,10 @@ sub objects { # Perform the search and return on any errors. my @objects; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; eval { - my @objects_rs = $dbh->resultset('Object')->search ($search_ref, - $options_ref); + 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 ]); } @@ -228,13 +234,13 @@ sub acls_all { my ($self) = @_; my @acls; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my %search = (); my %options = (order_by => [ qw/ac_id/ ], select => [ qw/ac_id ac_name/ ]); eval { - my @acls_rs = $dbh->resultset('Acl')->search (\%search, \%options); + 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 ]); } @@ -252,7 +258,7 @@ sub acls_empty { my ($self) = @_; my @acls; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my %search = (ae_id => undef); my %options = (join => 'acl_entries', prefetch => 'acl_entries', @@ -260,7 +266,7 @@ sub acls_empty { select => [ qw/ac_id ac_name/ ]); eval { - my @acls_rs = $dbh->resultset('Acl')->search (\%search, \%options); + 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 ]); } @@ -280,7 +286,7 @@ sub acls_entry { my ($self, $type, $identifier) = @_; my @acls; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my %search = (ae_scheme => $type, ae_identifier => { like => '%'.$identifier.'%' }); my %options = (join => 'acl_entries', @@ -290,7 +296,7 @@ sub acls_entry { distinct => 1); eval { - my @acls_rs = $dbh->resultset('Acl')->search (\%search, \%options); + 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 ]); } @@ -308,7 +314,7 @@ sub acls_unused { my ($self) = @_; my @acls; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my %search = ( #'acls_owner.ob_owner' => undef, #'acls_get.ob_owner' => undef, @@ -322,7 +328,7 @@ sub acls_unused { select => [ qw/ac_id ac_name/ ]); eval { - my @acls_rs = $dbh->resultset('Acl')->search (\%search, \%options); + 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) { @@ -347,7 +353,7 @@ sub acls_unused { # 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; @@ -433,7 +439,7 @@ sub acls { sub owners { my ($self, $type, $name) = @_; undef $self->{error}; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my @owners; eval { @@ -446,8 +452,8 @@ sub owners { distinct => 1, ); - my @acls_rs = $dbh->resultset('AclEntry')->search (\%search, - \%options); + 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; diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index d36b7ac..cee94f7 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -40,11 +40,11 @@ sub connect { my $user = $Wallet::Config::DB_USER; my $pass = $Wallet::Config::DB_PASSWORD; my %attrs = (PrintError => 0, RaiseError => 1); - my $dbh = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) }; + my $schema = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) }; if ($@) { die "cannot connect to database: $@\n"; } - return $dbh; + return $schema; } __END__ @@ -62,7 +62,7 @@ Wallet::Schema - Database schema and connector for the wallet system =head1 SYNOPSIS use Wallet::Schema; - my $dbh = Wallet::Schema->connect; + my $schema = Wallet::Schema->connect; =head1 DESCRIPTION diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm index 402fbe0..db53f6c 100644 --- a/perl/Wallet/Server.pm +++ b/perl/Wallet/Server.pm @@ -37,13 +37,13 @@ $VERSION = '0.11'; # for various things. Throw an exception if anything goes wrong. sub new { my ($class, $user, $host) = @_; - my $dbh = Wallet::Schema->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. @@ -71,8 +77,8 @@ sub error { sub DESTROY { my ($self) = @_; - if ($self->{dbh}) { - $self->{dbh}->storage->dbh->disconnect; + if ($self->{schema}) { + $self->{schema}->storage->dbh->disconnect; } } @@ -86,9 +92,9 @@ sub type_mapping { my ($self, $type) = @_; my $class; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %search = (ty_name => $type); - my $type_rec = $self->{dbh}->resultset('Type')->find (\%search); + my $type_rec = $self->{schema}->resultset('Type')->find (\%search); $class = $type_rec->ty_class; $guard->commit; }; @@ -118,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; @@ -128,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; @@ -181,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; @@ -246,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; @@ -302,7 +308,7 @@ sub acl_verify { $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; @@ -556,7 +562,7 @@ sub flag_set { # 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->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { if ($@ =~ /^ACL .* not found/) { return 0; @@ -585,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; @@ -617,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; @@ -637,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; @@ -658,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; @@ -689,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; @@ -713,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; @@ -733,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; @@ -975,6 +981,10 @@ mostly for testing; normally, clients should perform all actions through the Wallet::Server object to ensure that authorization and history logging is done properly. +=item schema() + +Returns the DBIx::Class schema object. + =item error() Returns the error of the last failing operation or undef if no operations diff --git a/perl/t/acl.t b/perl/t/acl.t index f169eb5..62eb411 100755 --- a/perl/t/acl.t +++ b/perl/t/acl.t @@ -29,30 +29,30 @@ db_setup; my $setup = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($setup->reinitialize ($setup), 1, 'Database initialization succeeded'); -my $dbh = $setup->dbh; +my $schema = $setup->schema; # Test create and new. -my $acl = eval { Wallet::ACL->create ('test', $dbh, @trace) }; +my $acl = eval { Wallet::ACL->create ('test', $schema, @trace) }; ok (defined ($acl), 'ACL creation'); is ($@, '', ' with no exceptions'); ok ($acl->isa ('Wallet::ACL'), ' and the right class'); is ($acl->name, 'test', ' and the right name'); is ($acl->id, 2, ' and the right ID'); -$acl = eval { Wallet::ACL->create (3, $dbh, @trace) }; +$acl = eval { Wallet::ACL->create (3, $schema, @trace) }; ok (!defined ($acl), 'Creating with a numeric name'); is ($@, "ACL name may not be all numbers\n", ' with the right error message'); -$acl = eval { Wallet::ACL->create ('test', $dbh, @trace) }; +$acl = eval { Wallet::ACL->create ('test', $schema, @trace) }; ok (!defined ($acl), 'Creating a duplicate object'); like ($@, qr/^cannot create ACL test: /, ' with the right error message'); -$acl = eval { Wallet::ACL->new ('test2', $dbh) }; +$acl = eval { Wallet::ACL->new ('test2', $schema) }; ok (!defined ($acl), 'Searching for a non-existent ACL'); is ($@, "ACL test2 not found\n", ' with the right error message'); -$acl = eval { Wallet::ACL->new ('test', $dbh) }; +$acl = eval { Wallet::ACL->new ('test', $schema) }; ok (defined ($acl), 'Searching for the test ACL by name'); is ($@, '', ' with no exceptions'); ok ($acl->isa ('Wallet::ACL'), ' and the right class'); is ($acl->id, 2, ' and the right ID'); -$acl = eval { Wallet::ACL->new (2, $dbh) }; +$acl = eval { Wallet::ACL->new (2, $schema) }; ok (defined ($acl), 'Searching for the test ACL by ID'); is ($@, '', ' with no exceptions'); ok ($acl->isa ('Wallet::ACL'), ' and the right class'); @@ -66,15 +66,15 @@ if ($acl->rename ('example')) { } is ($acl->name, 'example', ' and the new name is right'); is ($acl->id, 2, ' and the ID did not change'); -$acl = eval { Wallet::ACL->new ('test', $dbh) }; +$acl = eval { Wallet::ACL->new ('test', $schema) }; ok (!defined ($acl), ' and it cannot be found under the old name'); is ($@, "ACL test not found\n", ' with the right error message'); -$acl = eval { Wallet::ACL->new ('example', $dbh) }; +$acl = eval { Wallet::ACL->new ('example', $schema) }; ok (defined ($acl), ' and it can be found with the new name'); is ($@, '', ' with no exceptions'); is ($acl->name, 'example', ' and the right name'); is ($acl->id, 2, ' and the right ID'); -$acl = eval { Wallet::ACL->new (2, $dbh) }; +$acl = eval { Wallet::ACL->new (2, $schema) }; ok (defined ($acl), ' and it can still found by ID'); is ($@, '', ' with no exceptions'); is ($acl->name, 'example', ' and the right name'); @@ -212,13 +212,13 @@ if ($acl->destroy (@trace)) { } else { is ($acl->error, '', 'Destroying the ACL works'); } -$acl = eval { Wallet::ACL->new ('example', $dbh) }; +$acl = eval { Wallet::ACL->new ('example', $schema) }; ok (!defined ($acl), ' and now cannot be found'); is ($@, "ACL example not found\n", ' with the right error message'); -$acl = eval { Wallet::ACL->new (2, $dbh) }; +$acl = eval { Wallet::ACL->new (2, $schema) }; ok (!defined ($acl), ' or by ID'); is ($@, "ACL 2 not found\n", ' with the right error message'); -$acl = eval { Wallet::ACL->create ('example', $dbh, @trace) }; +$acl = eval { Wallet::ACL->create ('example', $schema, @trace) }; ok (defined ($acl), ' and creating another with the same name works'); is ($@, '', ' with no exceptions'); is ($acl->name, 'example', ' and the right name'); diff --git a/perl/t/admin.t b/perl/t/admin.t index cf6a637..ff69ee9 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -63,11 +63,11 @@ $Wallet::Schema::VERSION = '0.07'; is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, ' and re-initialization succeeds'); $Wallet::Schema::VERSION = '0.08'; -my $schema = $admin->dbh; +my $schema = $admin->schema; $schema->upgrade_directory ('sql/'); my $retval = $admin->upgrade; is ($retval, 1, 'Performing an upgrade succeeds'); -my $dbh = $schema->storage->dbh; +my $dbh = $admin->dbh; my $sql = "select version from dbix_class_schema_versions order by version " ."DESC"; $version = $dbh->selectall_arrayref ($sql); diff --git a/perl/t/file.t b/perl/t/file.t index a821c4f..f902fba 100755 --- a/perl/t/file.t +++ b/perl/t/file.t @@ -31,7 +31,7 @@ db_setup; my $admin = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $dbh = $admin->dbh; +my $schema = $admin->schema; # Use this to accumulate the history traces so that we can check history. my $history = ''; @@ -39,7 +39,7 @@ my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); # Test error handling in the absence of configuration. $object = eval { - Wallet::Object::File->create ('file', 'test', $dbh, @trace) + Wallet::Object::File->create ('file', 'test', $schema, @trace) }; ok (defined ($object), 'Creating a basic file object succeeds'); ok ($object->isa ('Wallet::Object::File'), ' and is the right class'); @@ -55,7 +55,7 @@ $Wallet::Config::FILE_BUCKET = 'test-files'; # Okay, now we can test. First, the basic object without store. $object = eval { - Wallet::Object::File->create ('file', 'test', $dbh, @trace) + Wallet::Object::File->create ('file', 'test', $schema, @trace) }; ok (defined ($object), 'Creating a basic file object succeeds'); ok ($object->isa ('Wallet::Object::File'), ' and is the right class'); @@ -66,7 +66,7 @@ is ($object->destroy (@trace), 1, ' but destroying the object succeeds'); # Now store something and be sure that we get something reasonable. $object = eval { - Wallet::Object::File->create ('file', 'test', $dbh, @trace) + Wallet::Object::File->create ('file', 'test', $schema, @trace) }; ok (defined ($object), 'Recreating the object succeeds'); is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); @@ -103,7 +103,7 @@ ok (! -f 'test-files/09/test', ' and the file is gone'); # Now try some aggressive names. $object = eval { - Wallet::Object::File->create ('file', '../foo', $dbh, @trace) + Wallet::Object::File->create ('file', '../foo', $schema, @trace) }; ok (defined ($object), 'Creating ../foo succeeds'); is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); @@ -115,7 +115,7 @@ is ($object->get (@trace), "foo\n", ' and get returns correctly'); is ($object->destroy (@trace), 1, 'Destroying the object works'); ok (! -f 'test-files/39/%2E%2E%2Ffoo', ' and the file is gone'); $object = eval { - Wallet::Object::File->create ('file', "\0", $dbh, @trace) + Wallet::Object::File->create ('file', "\0", $schema, @trace) }; ok (defined ($object), 'Creating nul succeeds'); is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); @@ -130,7 +130,7 @@ ok (! -f 'test-files/93/%00', ' and the file is gone'); # Test error handling in the file store. system ('rm -r test-files') == 0 or die "cannot remove test-files\n"; $object = eval { - Wallet::Object::File->create ('file', 'test', $dbh, @trace) + Wallet::Object::File->create ('file', 'test', $schema, @trace) }; ok (defined ($object), 'Recreating the object succeeds'); is ($object->store ("foo\n", @trace), undef, diff --git a/perl/t/init.t b/perl/t/init.t index 213aedf..aa028e3 100755 --- a/perl/t/init.t +++ b/perl/t/init.t @@ -24,7 +24,7 @@ is ($admin->initialize ('admin@EXAMPLE.COM'), 1, ' and initialization succeeds'); # Check whether the database entries that should be created were. -my $acl = eval { Wallet::ACL->new ('ADMIN', $admin->dbh) }; +my $acl = eval { Wallet::ACL->new ('ADMIN', $admin->schema) }; is ($@, '', 'Retrieving ADMIN ACL successful'); ok ($acl->isa ('Wallet::ACL'), ' and is the right class'); my @entries = $acl->list; @@ -38,7 +38,7 @@ is ($admin->reinitialize ('admin@EXAMPLE.ORG'), 1, 'Reinitialization succeeded'); # Now repeat the database content checks. -$acl = eval { Wallet::ACL->new ('ADMIN', $admin->dbh) }; +$acl = eval { Wallet::ACL->new ('ADMIN', $admin->schema) }; is ($@, '', 'Retrieving ADMIN ACL successful'); ok ($acl->isa ('Wallet::ACL'), ' and is the right class'); @entries = $acl->list; @@ -49,7 +49,7 @@ is ($entries[0][1], 'admin@EXAMPLE.ORG', ' with the right user'); # Test cleanup. is ($admin->destroy, 1, 'Destroying the database works'); -$acl = eval { Wallet::ACL->new ('ADMIN', $admin->dbh) }; +$acl = eval { Wallet::ACL->new ('ADMIN', $admin->schema) }; like ($@, qr/^cannot search for ACL ADMIN: /, ' and now the database is gone'); unlink 'wallet-db'; diff --git a/perl/t/keytab.t b/perl/t/keytab.t index c263f58..561f130 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -147,8 +147,8 @@ db_setup; my $admin = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $schema = $admin->dbh; -my $dbh = $schema->storage->dbh; +my $schema = $admin->schema; +my $dbh = $admin->dbh; # Use this to accumulate the history traces so that we can check history. my $history = ''; diff --git a/perl/t/object.t b/perl/t/object.t index 2d60dd2..5eb6941 100755 --- a/perl/t/object.t +++ b/perl/t/object.t @@ -30,26 +30,26 @@ db_setup; my $admin = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $dbh = $admin->dbh; +my $schema = $admin->schema; # Okay, now we have a database. Test create and new. We make believe this is # a keytab object; it won't matter for what we're doing. my $object = eval { - Wallet::Object::Base->create ('keytab', $princ, $dbh, @trace) + Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) }; is ($@, '', 'Object creation did not die'); ok ($object->isa ('Wallet::Object::Base'), ' and returned the right class'); my $other = eval { - Wallet::Object::Base->create ('keytab', $princ, $dbh, @trace) + Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) }; like ($@, qr/^cannot create object \Qkeytab:$princ: /, 'Repeating fails'); -$other = eval { Wallet::Object::Base->create ('', $princ, $dbh, @trace) }; +$other = eval { Wallet::Object::Base->create ('', $princ, $schema, @trace) }; is ($@, "invalid object type\n", 'Using an empty type fails'); -$other = eval { Wallet::Object::Base->create ('keytab', '', $dbh, @trace) }; +$other = eval { Wallet::Object::Base->create ('keytab', '', $schema, @trace) }; is ($@, "invalid object name\n", ' as does an empty name'); -$object = eval { Wallet::Object::Base->new ('keytab', "a$princ", $dbh) }; +$object = eval { Wallet::Object::Base->new ('keytab', "a$princ", $schema) }; is ($@, "cannot find keytab:a$princ\n", 'Searching for unknown object fails'); -$object = eval { Wallet::Object::Base->new ('keytab', $princ, $dbh) }; +$object = eval { Wallet::Object::Base->new ('keytab', $princ, $schema) }; is ($@, '', 'Object new did not die'); ok ($object->isa ('Wallet::Object::Base'), ' and returned the right class'); @@ -58,7 +58,7 @@ is ($object->type, 'keytab', 'Type accessor works'); is ($object->name, $princ, 'Name accessor works'); # We'll use this for later tests. -my $acl = Wallet::ACL->new ('ADMIN', $dbh); +my $acl = Wallet::ACL->new ('ADMIN', $schema); # Owner. is ($object->owner, undef, 'Owner is not set to start'); @@ -266,12 +266,12 @@ if ($object->destroy (@trace)) { } else { is ($object->error, '', 'Destroy is successful'); } -$object = eval { Wallet::Object::Base->new ('keytab', $princ, $dbh) }; +$object = eval { Wallet::Object::Base->new ('keytab', $princ, $schema) }; is ($@, "cannot find keytab:$princ\n", ' and object is all gone'); # Test history. $object = eval { - Wallet::Object::Base->create ('keytab', $princ, $dbh, @trace) + Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) }; ok (defined ($object), 'Recreating the object succeeds'); $output = <<"EOO"; diff --git a/perl/t/server.t b/perl/t/server.t index 63f2e76..8474989 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -36,8 +36,8 @@ is ($setup->reinitialize ($admin), 1, 'Database initialization succeeded'); $server = eval { Wallet::Server->new (@trace) }; is ($@, '', 'Reopening with new did not die'); ok ($server->isa ('Wallet::Server'), ' and returned the right class'); -my $dbh = $server->dbh; -ok (defined ($dbh), ' and returns a defined database handle'); +my $schema = $server->schema; +ok (defined ($schema), ' and returns a defined schema object'); # Allow creation of base objects for testing purposes. $setup->register_object ('base', 'Wallet::Object::Base'); diff --git a/perl/t/wa-keyring.t b/perl/t/wa-keyring.t index 703b7fe..3011d54 100755 --- a/perl/t/wa-keyring.t +++ b/perl/t/wa-keyring.t @@ -40,14 +40,14 @@ db_setup; my $admin = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $dbh = $admin->dbh; +my $schema = $admin->schema; # Create a WebAuth context to use. my $wa = WebAuth->new; # Test error handling in the absence of configuration. my $object = eval { - Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $dbh, @trace) + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) }; ok (defined ($object), 'Creating a basic WebAuth keyring object succeeds'); ok ($object->isa ('Wallet::Object::WAKeyring'), ' and is the right class'); @@ -65,7 +65,7 @@ $Wallet::Config::WAKEYRING_BUCKET = 'test-keyrings'; # Okay, now we can test. First, the basic object without store. $object = eval { - Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $dbh, @trace) + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) }; ok (defined ($object), 'Creating a basic WebAuth keyring object succeeds'); ok ($object->isa ('Wallet::Object::WAKeyring'), ' and is the right class'); @@ -100,7 +100,7 @@ is ($object->destroy (@trace), 1, 'Destroying the object succeeds'); # Now store something and be sure that we get something reasonable. $object = eval { - Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $dbh, @trace) + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) }; ok (defined ($object), 'Recreating the object succeeds'); my $key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); @@ -159,7 +159,7 @@ is ($object->destroy (@trace), 1, 'Destroying the object succeeds'); # Test error handling in the file store. system ('rm -r test-keyrings') == 0 or die "cannot remove test-keyrings\n"; $object = eval { - Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $dbh, @trace) + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) }; ok (defined ($object), 'Recreating the object succeeds'); is ($object->get (@trace), undef, ' but retrieving it fails'); -- cgit v1.2.3 From 0753a60cc0b6f9873c6b9fe70e298bd045306466 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Sun, 3 Feb 2013 23:24:40 -0800 Subject: Add current Stanford naming policy and test suite To make it easier to revise and test revisions to the Stanford wallet naming policy, convert the code to a module and include it in the distribution. Add a test suite for the current policy. Change-Id: I73b888fa8d18401a239144c2e9f810ad4692c44b Reviewed-on: https://gerrit.stanford.edu/755 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/Policy/Stanford.pm | 237 +++++++++++++++++++++++++++++++++++++++++ perl/t/stanford-naming.t | 193 +++++++++++++++++++++++++++++++++ 2 files changed, 430 insertions(+) create mode 100644 perl/Wallet/Policy/Stanford.pm create mode 100755 perl/t/stanford-naming.t (limited to 'perl/t') diff --git a/perl/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm new file mode 100644 index 0000000..906f6ba --- /dev/null +++ b/perl/Wallet/Policy/Stanford.pm @@ -0,0 +1,237 @@ +# Wallet::Policy::Stanford -- Stanford's wallet naming and ownership policy. +# +# Written by Russ Allbery +# 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); +} + +############################################################################## +# Implementation +############################################################################## + +# 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) = @_; + my $schema = eval { Wallet::Schema->connect }; + return unless ($schema and not $@); + my $acl = eval { Wallet::ACL->new ($name, $schema) }; + return unless ($acl and not $@); + for my $line ($acl->list) { + return 1 if $line->[0] eq 'netdb-root'; + } + return; +} + +# Map a file object name to a hostname and return it. Returns undef if this +# file object name doesn't map to a hostname. +sub _host_for_file { + my ($name) = @_; + my %allowed = map { $_ => 1 } + qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key); + my $allowed_regex = '(?:' . join ('|', sort keys %allowed) . ')'; + if ($name !~ /^[^-]+-(.*)-$allowed_regex(?:-.*)?$/) { + return; + } + my $host = $1; + if ($host !~ /\./) { + $host .= '.stanford.edu'; + } + 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 } + qw(HTTP afpserver cifs ftp host imap ipp ldap lpr nfs pop postgres + sieve smtp webauth xmpp); + return unless $name =~ m,/,; + my ($service, $host) = split ('/', $name, 2); + return unless $allowed{$service}; + if ($host !~ /\./) { + $host .= '.stanford.edu'; + } + 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) = @_; + my $realm = 'stanford.edu'; + my %host_for = ( + keytab => \&_host_for_keytab, + file => \&_host_for_file, + ); + return unless defined $host_for{$type}; + my $host = $host_for{$type}->($name); + return unless $host; + my $acl_name = "host/$host"; + my @acl; + if ($ENV{REMOTE_USER} =~ m,/root, or 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); +} + +# 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 %host = map { $_ => 1 } + qw(HTTP afpserver cifs ftp http host ident imap ipp ldap lpr nfs pop + postgres sieve smtp uniengd webauth xmpp); + my %staff; + if (open (STAFF, '<', '/etc/remctl/acl/its-idg')) { + local $_; + while () { + 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') { + 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') { + my %groups = map { $_ => 1 } + qw(apps crcsg gsb idg sysadmin sulair vast); + my %types = map { $_ => 1 } + qw(config db gpg-key htpasswd password properties ssh-rsa ssh-dsa + ssl-key ssl-keystore ssl-pkcs12 tivoli-key); + 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 +############################################################################## + +=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 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). 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 +implemented by this module. + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/t/stanford-naming.t b/perl/t/stanford-naming.t new file mode 100755 index 0000000..ec3760a --- /dev/null +++ b/perl/t/stanford-naming.t @@ -0,0 +1,193 @@ +#!/usr/bin/perl +# +# Tests for the Stanford naming policy. +# +# The naming policy code is included primarily an example for non-Stanford +# sites, but it's used at Stanford and this test suite is used to verify +# behavior at Stanford. +# +# Written by Russ Allbery +# Copyright 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use 5.008; +use strict; +use warnings; + +use Test::More tests => 57; + +use lib 't/lib'; +use Util; + +# Load the naming policy module. +BEGIN { + use_ok('Wallet::Admin'); + use_ok('Wallet::Policy::Stanford', qw(default_owner verify_name)); + use_ok('Wallet::Server'); +} + +# Various valid keytab names. +my @VALID_KEYTABS = qw(host/example.stanford.edu HTTP/example.stanford.edu + service/example example/cgi class-example01/cgi dept-01example/cgi + group-example-01/cgi); + +# Various invalid keytab names. +my @INVALID_KEYTABS = qw(example host/example service/example.stanford.edu + thisistoolong/cgi not-valid/cgi unknown/example.stanford.edu); + +# Various valid file names. +my @VALID_FILES = qw(apps-example-config-file crcsg-example-db-s_example + idg-debian-gpg-key idg-devnull-password-root sulair-accounts-properties + idg-accounts-ssl-keystore idg-accounts-ssl-pkcs12 + crcsg-example-htpasswd-web sulair-example-password-ipmi + sulair-example-password-root sulair-example-password-tivoli + sulair-example-ssh-dsa sulair-example-ssh-rsa idg-mdm-ssl-key + idg-openafs-tivoli-key); + +# Various invalid file names. +my @INVALID_FILES = qw(unknown foo-example-ssh-rsa idg-accounts-foo !!bad); + +# Global variables for the wallet server setup. +my $ADMIN = 'admin@EXAMPLE.COM'; +my $HOST = 'localhost'; +my @TRACE = ($ADMIN, $HOST); + +# Start by testing lots of straightforward naming validity. +for my $name (@VALID_KEYTABS) { + is(verify_name('keytab', $name), undef, "Valid keytab $name"); +} +for my $name (@INVALID_KEYTABS) { + isnt(verify_name('keytab', $name), undef, "Invalid keytab $name"); +} +for my $name (@VALID_FILES) { + is(verify_name('file', $name), undef, "Valid file $name"); +} +for my $name (@INVALID_FILES) { + isnt(verify_name('file', $name), undef, "Invalid file $name"); +} + +# Now we need an actual database. Use Wallet::Admin to set it up. +db_setup; +my $setup = eval { Wallet::Admin->new }; +is($@, q{}, 'Database initialization did not die'); +is($setup->reinitialize($ADMIN), 1, 'Database initialization succeeded'); +my $server = eval { Wallet::Server->new(@TRACE) }; +is($@, q{}, 'Server creation did not die'); + +# Create a host/example.stanford.edu ACL that uses the netdb ACL type. +is($server->acl_create('host/example.stanford.edu'), 1, 'Created netdb ACL'); +is( + $server->acl_add('host/example.stanford.edu', 'netdb', + 'example.stanford.edu'), + 1, + '...with netdb ACL line' +); +is( + $server->acl_add('host/example.stanford.edu', 'krb5', + 'host/example.stanford.edu@stanford.edu'), + 1, + '...and krb5 ACL line' +); + +# Likewise for host/foo.example.edu with the netdb-root ACL type. +is($server->acl_create('host/foo.stanford.edu'), 1, 'Created netdb-root ACL'); +is( + $server->acl_add('host/foo.stanford.edu', 'netdb-root', + 'foo.stanford.edu'), + 1, + '...with netdb-root ACL line' +); +is( + $server->acl_add('host/foo.stanford.edu', 'krb5', + 'host/foo.stanford.edu@stanford.edu'), + 1, + '...and krb5 ACL line' +); + +# Now we can test default ACLs. First, without a root instance. +local $ENV{REMOTE_USER} = $ADMIN; +is_deeply( + [default_owner('keytab', 'host/bar.stanford.edu')], + [ + 'host/bar.stanford.edu', + ['netdb', 'bar.stanford.edu'], + ['krb5', 'host/bar.stanford.edu@stanford.edu'] + ], + 'Correct default owner for host-based keytab' +); +is_deeply( + [default_owner('keytab', 'HTTP/example.stanford.edu')], + [ + 'host/example.stanford.edu', + ['netdb', 'example.stanford.edu'], + ['krb5', 'host/example.stanford.edu@stanford.edu'] + ], + '...and when netdb ACL already exists' +); +is_deeply( + [default_owner('keytab', 'webauth/foo.stanford.edu')], + [ + 'host/foo.stanford.edu', + ['netdb-root', 'foo.stanford.edu'], + ['krb5', 'host/foo.stanford.edu@stanford.edu'] + ], + '...and when netdb-root ACL already exists' +); + +# Now with a root instance. +local $ENV{REMOTE_USER} = 'admin/root@stanford.edu'; +is_deeply( + [default_owner('keytab', 'host/bar.stanford.edu')], + [ + 'host/bar.stanford.edu', + ['netdb-root', 'bar.stanford.edu'], + ['krb5', 'host/bar.stanford.edu@stanford.edu'] + ], + 'Correct default owner for host-based keytab for /root' +); +is_deeply( + [default_owner('keytab', 'HTTP/example.stanford.edu')], + [ + 'host/example.stanford.edu', + ['netdb-root', 'example.stanford.edu'], + ['krb5', 'host/example.stanford.edu@stanford.edu'] + ], + '...and when netdb ACL already exists' +); +is_deeply( + [default_owner('keytab', 'webauth/foo.stanford.edu')], + [ + 'host/foo.stanford.edu', + ['netdb-root', 'foo.stanford.edu'], + ['krb5', 'host/foo.stanford.edu@stanford.edu'] + ], + '...and when netdb-root ACL already exists' +); + +# Check for a type that isn't host-based. +is(default_owner('keytab', 'service/foo'), undef, + 'No default owner for service/foo'); + +# Check for an unknown object type. +is(default_owner('unknown', 'foo'), undef, + 'No default owner for unknown type'); + +# Check for legacy autocreation mappings for file objects. +for my $type (qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key)) { + my $name = "idg-example-$type"; + is_deeply( + [default_owner('file', $name)], + [ + 'host/example.stanford.edu', + ['netdb-root', 'example.stanford.edu'], + ['krb5', 'host/example.stanford.edu@stanford.edu'] + ], + "Default owner for file $name", + ); +} + +# Clean up. +$setup->destroy; +unlink 'wallet-db'; -- cgit v1.2.3 From abcbf4eada033bd364d685f56e80f0bd07a3f76a Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 5 Feb 2013 18:09:49 -0800 Subject: Refactor Stanford naming policy, add new file patterns Refactor the Wallet::Policy::Stanford module to pull some of the constants out, and then add data and support in the naming policy for the new file object naming scheme. Change-Id: Iba0c24c119ce529a1d3fd8cd3332335c4433df09 Reviewed-on: https://gerrit.stanford.edu/756 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/Policy/Stanford.pm | 176 +++++++++++++++++++++++++++++++++-------- perl/t/stanford-naming.t | 35 +++++++- 2 files changed, 174 insertions(+), 37 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm index 906f6ba..640c43c 100644 --- a/perl/Wallet/Policy/Stanford.pm +++ b/perl/Wallet/Policy/Stanford.pm @@ -29,6 +29,59 @@ BEGIN { @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. This default is entirely Stanford-specific, +# even more so than the rest of this file. +our @GROUPS = 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_TYPES = ( + 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-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 ############################################################################## @@ -40,7 +93,7 @@ BEGIN { # pose a security problem. # # On any failure, just return an empty ACL to use the default. -sub acl_has_netdb_root { +sub _acl_has_netdb_root { my ($name) = @_; my $schema = eval { Wallet::Schema->connect }; return unless ($schema and not $@); @@ -52,19 +105,19 @@ sub acl_has_netdb_root { return; } -# Map a file object name to a hostname and return it. Returns undef if this -# file object name doesn't map to a hostname. -sub _host_for_file { +# 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 } - qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key); + 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 .= '.stanford.edu'; + $host .= q{.} . $DOMAIN; } return $host; } @@ -73,14 +126,12 @@ sub _host_for_file { # keytab principal name doesn't map to a hostname. sub _host_for_keytab { my ($name) = @_; - my %allowed = map { $_ => 1 } - qw(HTTP afpserver cifs ftp host imap ipp ldap lpr nfs pop postgres - sieve smtp webauth xmpp); + my %allowed = map { $_ => 1 } @KEYTAB_HOST; return unless $name =~ m,/,; my ($service, $host) = split ('/', $name, 2); return unless $allowed{$service}; if ($host !~ /\./) { - $host .= '.stanford.edu'; + $host .= q{.} . $DOMAIN; } return $host; } @@ -91,22 +142,21 @@ sub _host_for_keytab { # using root instances by default. sub default_owner { my ($type, $name) = @_; - my $realm = 'stanford.edu'; my %host_for = ( keytab => \&_host_for_keytab, - file => \&_host_for_file, + file => \&_host_for_file_legacy, ); return unless defined $host_for{$type}; my $host = $host_for{$type}->($name); return unless $host; my $acl_name = "host/$host"; my @acl; - if ($ENV{REMOTE_USER} =~ m,/root, or acl_has_netdb_root ($acl_name)) { + if ($ENV{REMOTE_USER} =~ m,/root, or _acl_has_netdb_root ($acl_name)) { @acl = ([ 'netdb-root', $host ], - [ 'krb5', "host/$host\@$realm" ]); + [ 'krb5', "host/$host\@$REALM" ]); } else { @acl = ([ 'netdb', $host ], - [ 'krb5', "host/$host\@$realm" ]); + [ 'krb5', "host/$host\@$REALM" ]); } return ($acl_name, @acl); } @@ -119,11 +169,8 @@ sub default_owner { # creation using a */root instance. sub verify_name { my ($type, $name, $user) = @_; - my %host = map { $_ => 1 } - qw(HTTP afpserver cifs ftp http host ident imap ipp ldap lpr nfs pop - postgres sieve smtp uniengd webauth xmpp); my %staff; - if (open (STAFF, '<', '/etc/remctl/acl/its-idg')) { + if (open (STAFF, '<', $ROOT_REQUIRED)) { local $_; while () { s/^\s+//; @@ -141,6 +188,7 @@ sub verify_name { # 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"; } @@ -169,20 +217,80 @@ sub verify_name { # Check file object naming conventions. if ($type eq 'file') { - my %groups = map { $_ => 1 } - qw(apps crcsg gsb idg sysadmin sulair vast); - my %types = map { $_ => 1 } - qw(config db gpg-key htpasswd password properties ssh-rsa ssh-dsa - ssl-key ssl-keystore ssl-pkcs12 tivoli-key); - 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"; + my %groups = map { $_ => 1 } @GROUPS; + 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_TYPES{$type} && $FILE_TYPES{$type}{host}) { + my ($host, $extra) = @name; + if ($host !~ m{ [.] }xms) { + return "host name $host is not fully qualified"; + } + if (defined($extra) && !$FILE_TYPES{$type}{extra}) { + return "extraneous component at end of $name"; + } + if (!defined($extra) && $FILE_TYPES{$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 (!$groups{$group}) { + return "unknown group $group"; + } + + # Check the type. Be sure it's not host-based. + if (!$FILE_TYPES{$type}) { + return "unknown type $type"; + } + if ($FILE_TYPES{$type}{host}) { + return "bad name for host-based file type $type"; + } + + # Check the extra data. + if (defined($extra) && !$FILE_TYPES{$type}{extra}) { + return "extraneous component at end of $name"; + } + if (!defined($extra) && $FILE_TYPES{$type}{need_extra}) { + return "missing component in $name"; + } + return; + } else { + # Legacy naming scheme. + 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"; + } } } diff --git a/perl/t/stanford-naming.t b/perl/t/stanford-naming.t index ec3760a..2ed8014 100755 --- a/perl/t/stanford-naming.t +++ b/perl/t/stanford-naming.t @@ -16,7 +16,7 @@ use 5.008; use strict; use warnings; -use Test::More tests => 57; +use Test::More tests => 91; use lib 't/lib'; use Util; @@ -38,7 +38,28 @@ my @INVALID_KEYTABS = qw(example host/example service/example.stanford.edu thisistoolong/cgi not-valid/cgi unknown/example.stanford.edu); # Various valid file names. -my @VALID_FILES = qw(apps-example-config-file crcsg-example-db-s_example +my @VALID_FILES = qw(htpasswd/example.stanford.edu/web + password-ipmi/example.stanford.edu + password-root/example.stanford.edu + password-tivoli/example.stanford.edu + ssh-dsa/example.stanford.edu + ssh-rsa/example.stanford.edu + ssl-key/example.stanford.edu + ssl-key/example.stanford.edu/mysql + tivoli-key/example.stanford.edu + config/idg/example/foo + db/idg/example/s_foo + gpg-key/idg/debian + password/idg/example/backup + properties/idg/accounts + properties/idg/accounts/sponsorship + ssl-keystore/idg/accounts + ssl-keystore/idg/accounts/sponsorship + ssl-pkcs12/idg/accounts + ssl-pkcs12/idg/accounts/sponsorship); + +# Various valid legacy file names. +my @VALID_LEGACY_FILES = qw(apps-example-config-file crcsg-example-db-s_example idg-debian-gpg-key idg-devnull-password-root sulair-accounts-properties idg-accounts-ssl-keystore idg-accounts-ssl-pkcs12 crcsg-example-htpasswd-web sulair-example-password-ipmi @@ -47,7 +68,12 @@ my @VALID_FILES = qw(apps-example-config-file crcsg-example-db-s_example idg-openafs-tivoli-key); # Various invalid file names. -my @INVALID_FILES = qw(unknown foo-example-ssh-rsa idg-accounts-foo !!bad); +my @INVALID_FILES = qw(unknown foo-example-ssh-rsa idg-accounts-foo !!bad + htpasswd/example.stanford.edu htpasswd/example password-root/example + password-root/example.stanford.edu/foo ssh-foo/example.stanford.edu + tivoli-key/example.stanford.edu/foo tivoli-key config config/idg + config/idg/example db/idg/example password/idg/example + idg/password/example properties//accounts properties/idg/); # Global variables for the wallet server setup. my $ADMIN = 'admin@EXAMPLE.COM'; @@ -64,6 +90,9 @@ for my $name (@INVALID_KEYTABS) { for my $name (@VALID_FILES) { is(verify_name('file', $name), undef, "Valid file $name"); } +for my $name (@VALID_LEGACY_FILES) { + is(verify_name('file', $name), undef, "Valid file $name"); +} for my $name (@INVALID_FILES) { isnt(verify_name('file', $name), undef, "Invalid file $name"); } -- cgit v1.2.3 From 7001e303c51b1b18f07fb764c91b5ff67b2318f8 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 5 Feb 2013 19:01:55 -0800 Subject: Add default owner support to Stanford naming policy Add support for a default owner for host-based file objects to Wallet::Policy::Stanford. Change-Id: I1a9bf07def1356788fbd0acf9910a2e86c9e8f08 Reviewed-on: https://gerrit.stanford.edu/757 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/Policy/Stanford.pm | 18 +++++++++++++++++- perl/t/stanford-naming.t | 26 +++++++++++++++++++++++++- 2 files changed, 42 insertions(+), 2 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm index 640c43c..0183df8 100644 --- a/perl/Wallet/Policy/Stanford.pm +++ b/perl/Wallet/Policy/Stanford.pm @@ -122,6 +122,22 @@ sub _host_for_file_legacy { 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_TYPES{$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 { @@ -144,7 +160,7 @@ sub default_owner { my ($type, $name) = @_; my %host_for = ( keytab => \&_host_for_keytab, - file => \&_host_for_file_legacy, + file => \&_host_for_file, ); return unless defined $host_for{$type}; my $host = $host_for{$type}->($name); diff --git a/perl/t/stanford-naming.t b/perl/t/stanford-naming.t index 2ed8014..909ad1e 100755 --- a/perl/t/stanford-naming.t +++ b/perl/t/stanford-naming.t @@ -16,7 +16,7 @@ use 5.008; use strict; use warnings; -use Test::More tests => 91; +use Test::More tests => 94; use lib 't/lib'; use Util; @@ -203,6 +203,30 @@ is(default_owner('keytab', 'service/foo'), undef, is(default_owner('unknown', 'foo'), undef, 'No default owner for unknown type'); +# Check for autocreation mappings for host-based file objects. +is_deeply( + [default_owner('file', 'ssl-key/example.stanford.edu')], + [ + 'host/example.stanford.edu', + ['netdb-root', 'example.stanford.edu'], + ['krb5', 'host/example.stanford.edu@stanford.edu'] + ], + 'Default owner for file ssl-key/example.stanford.edu', +); +is_deeply( + [default_owner('file', 'ssl-key/example.stanford.edu/mysql')], + [ + 'host/example.stanford.edu', + ['netdb-root', 'example.stanford.edu'], + ['krb5', 'host/example.stanford.edu@stanford.edu'] + ], + 'Default owner for file ssl-key/example.stanford.edu/mysql', +); + +# Check for a file object that isn't host-based. +is(default_owner('file', 'config/idg/example/foo'), undef, + 'No default owner for non-host-based file type'); + # Check for legacy autocreation mappings for file objects. for my $type (qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key)) { my $name = "idg-example-$type"; -- cgit v1.2.3 From 271896c3a9dee9108e021519e340e4547ef5ab93 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 5 Feb 2013 19:51:00 -0800 Subject: Separate legacy groups from new groups in Stanford policy Add all the new group names for the Stanford naming policy and associate them with default ACLs (not yet used). Distinguish them from the legacy group names, and use the appropriate ones for naming policy enforcement. Change-Id: I4b87ff48d34d82195245798f41afefff26efa95d Reviewed-on: https://gerrit.stanford.edu/758 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/Policy/Stanford.pm | 20 +++++++++++++++----- perl/t/stanford-naming.t | 31 ++++++++++++++++--------------- 2 files changed, 31 insertions(+), 20 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm index 0183df8..840f5f3 100644 --- a/perl/Wallet/Policy/Stanford.pm +++ b/perl/Wallet/Policy/Stanford.pm @@ -39,9 +39,19 @@ BEGIN { # The domain to append to hostnames to fully-qualify them. our $DOMAIN = 'stanford.edu'; -# Groups for file object naming. This default is entirely Stanford-specific, -# even more so than the rest of this file. -our @GROUPS = qw(apps crcsg gsb idg sysadmin sulair vast); +# 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 %GROUPS = ( + '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 @@ -233,7 +243,6 @@ sub verify_name { # Check file object naming conventions. if ($type eq 'file') { - my %groups = map { $_ => 1 } @GROUPS; if ($name =~ m{ / }xms) { my @name = split('/', $name); @@ -274,7 +283,7 @@ sub verify_name { my ($group, $service, $extra) = @name; # Check the group. - if (!$groups{$group}) { + if (!$GROUPS{$group}) { return "unknown group $group"; } @@ -296,6 +305,7 @@ sub verify_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"; diff --git a/perl/t/stanford-naming.t b/perl/t/stanford-naming.t index 909ad1e..00c7121 100755 --- a/perl/t/stanford-naming.t +++ b/perl/t/stanford-naming.t @@ -16,7 +16,7 @@ use 5.008; use strict; use warnings; -use Test::More tests => 94; +use Test::More tests => 95; use lib 't/lib'; use Util; @@ -47,16 +47,16 @@ my @VALID_FILES = qw(htpasswd/example.stanford.edu/web ssl-key/example.stanford.edu ssl-key/example.stanford.edu/mysql tivoli-key/example.stanford.edu - config/idg/example/foo - db/idg/example/s_foo - gpg-key/idg/debian - password/idg/example/backup - properties/idg/accounts - properties/idg/accounts/sponsorship - ssl-keystore/idg/accounts - ssl-keystore/idg/accounts/sponsorship - ssl-pkcs12/idg/accounts - ssl-pkcs12/idg/accounts/sponsorship); + config/its-idg/example/foo + db/its-idg/example/s_foo + gpg-key/its-idg/debian + password/its-idg/example/backup + properties/its-idg/accounts + properties/its-idg/accounts/sponsorship + ssl-keystore/its-idg/accounts + ssl-keystore/its-idg/accounts/sponsorship + ssl-pkcs12/its-idg/accounts + ssl-pkcs12/its-idg/accounts/sponsorship); # Various valid legacy file names. my @VALID_LEGACY_FILES = qw(apps-example-config-file crcsg-example-db-s_example @@ -71,9 +71,10 @@ my @VALID_LEGACY_FILES = qw(apps-example-config-file crcsg-example-db-s_example my @INVALID_FILES = qw(unknown foo-example-ssh-rsa idg-accounts-foo !!bad htpasswd/example.stanford.edu htpasswd/example password-root/example password-root/example.stanford.edu/foo ssh-foo/example.stanford.edu - tivoli-key/example.stanford.edu/foo tivoli-key config config/idg - config/idg/example db/idg/example password/idg/example - idg/password/example properties//accounts properties/idg/); + tivoli-key/example.stanford.edu/foo tivoli-key config config/its-idg + config/its-idg/example db/its-idg/example password/its-idg/example + its-idg/password/example properties//accounts properties/its-idg/ + ssl-keystore/idg/accounts); # Global variables for the wallet server setup. my $ADMIN = 'admin@EXAMPLE.COM'; @@ -224,7 +225,7 @@ is_deeply( ); # Check for a file object that isn't host-based. -is(default_owner('file', 'config/idg/example/foo'), undef, +is(default_owner('file', 'config/its-idg/example/foo'), undef, 'No default owner for non-host-based file type'); # Check for legacy autocreation mappings for file objects. -- cgit v1.2.3 From 4948053f7fd8a19f5c645d535ea3fa96f9539f4e Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 5 Feb 2013 20:18:35 -0800 Subject: Add default owner for group-based files in Stanford policy In Wallet::Policy::Stanford, add support for setting a default owner of file objects whose names are based on a group that has an ACL mapping. Change-Id: I4f63815621d81e26ba4779d10f249cb31eef2b5e Reviewed-on: https://gerrit.stanford.edu/759 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/Policy/Stanford.pm | 94 +++++++++++++++++++++++++++++------------- perl/t/stanford-naming.t | 14 +++++-- 2 files changed, 77 insertions(+), 31 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm index 840f5f3..39bea33 100644 --- a/perl/Wallet/Policy/Stanford.pm +++ b/perl/Wallet/Policy/Stanford.pm @@ -42,7 +42,7 @@ 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 %GROUPS = ( +our %ACL_FOR_GROUP = ( 'its-apps' => 'group/sharedapps', 'its-crc-sg' => 'group/crcsg', 'its-idg' => 'group/its-idg', @@ -56,7 +56,7 @@ 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_TYPES = ( +our %FILE_TYPE = ( config => { extra => 1, need_extra => 1 }, db => { extra => 1, need_extra => 1 }, 'gpg-key' => { }, @@ -96,6 +96,21 @@ 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 @@ -105,11 +120,7 @@ our $ROOT_REQUIRED = '/etc/remctl/acl/its-idg'; # On any failure, just return an empty ACL to use the default. sub _acl_has_netdb_root { my ($name) = @_; - my $schema = eval { Wallet::Schema->connect }; - return unless ($schema and not $@); - my $acl = eval { Wallet::ACL->new ($name, $schema) }; - return unless ($acl and not $@); - for my $line ($acl->list) { + for my $line (_acl_members($name)) { return 1 if $line->[0] eq 'netdb-root'; } return; @@ -144,7 +155,7 @@ sub _host_for_file { # Parse the name and check whether this is a host-based object. my ($type, $host) = split('/', $name); - return if !$FILE_TYPES{$type}{host}; + return if !$FILE_TYPE{$type}{host}; return $host; } @@ -168,23 +179,50 @@ sub _host_for_keytab { # 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, ); - return unless defined $host_for{$type}; - my $host = $host_for{$type}->($name); - return unless $host; - my $acl_name = "host/$host"; - my @acl; - if ($ENV{REMOTE_USER} =~ m,/root, or _acl_has_netdb_root ($acl_name)) { - @acl = ([ 'netdb-root', $host ], - [ 'krb5', "host/$host\@$REALM" ]); - } else { - @acl = ([ 'netdb', $host ], - [ 'krb5', "host/$host\@$REALM" ]); + + # 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); + } } - 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 @@ -261,15 +299,15 @@ sub verify_name { # All objects start with the type. First check if this is a # host-based type. my $type = shift @name; - if ($FILE_TYPES{$type} && $FILE_TYPES{$type}{host}) { + 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_TYPES{$type}{extra}) { + if (defined($extra) && !$FILE_TYPE{$type}{extra}) { return "extraneous component at end of $name"; } - if (!defined($extra) && $FILE_TYPES{$type}{need_extra}) { + if (!defined($extra) && $FILE_TYPE{$type}{need_extra}) { return "missing component in $name"; } return; @@ -283,23 +321,23 @@ sub verify_name { my ($group, $service, $extra) = @name; # Check the group. - if (!$GROUPS{$group}) { + if (!$ACL_FOR_GROUP{$group}) { return "unknown group $group"; } # Check the type. Be sure it's not host-based. - if (!$FILE_TYPES{$type}) { + if (!$FILE_TYPE{$type}) { return "unknown type $type"; } - if ($FILE_TYPES{$type}{host}) { + if ($FILE_TYPE{$type}{host}) { return "bad name for host-based file type $type"; } # Check the extra data. - if (defined($extra) && !$FILE_TYPES{$type}{extra}) { + if (defined($extra) && !$FILE_TYPE{$type}{extra}) { return "extraneous component at end of $name"; } - if (!defined($extra) && $FILE_TYPES{$type}{need_extra}) { + if (!defined($extra) && $FILE_TYPE{$type}{need_extra}) { return "missing component in $name"; } return; diff --git a/perl/t/stanford-naming.t b/perl/t/stanford-naming.t index 00c7121..9473ed5 100755 --- a/perl/t/stanford-naming.t +++ b/perl/t/stanford-naming.t @@ -16,7 +16,7 @@ use 5.008; use strict; use warnings; -use Test::More tests => 95; +use Test::More tests => 97; use lib 't/lib'; use Util; @@ -136,6 +136,11 @@ is( '...and krb5 ACL line' ); +# Create a group/its-idg ACL, which will be used for autocreation of file +# objects. +is($server->acl_create('group/its-idg'), 1, 'Created group/its-idg ACL'); +is($server->acl_add('group/its-idg', 'krb5', $ADMIN), 1, '...with member'); + # Now we can test default ACLs. First, without a root instance. local $ENV{REMOTE_USER} = $ADMIN; is_deeply( @@ -225,8 +230,11 @@ is_deeply( ); # Check for a file object that isn't host-based. -is(default_owner('file', 'config/its-idg/example/foo'), undef, - 'No default owner for non-host-based file type'); +is_deeply( + [default_owner('file', 'config/its-idg/example/foo')], + ['group/its-idg', ['krb5', $ADMIN]], + 'Default owner for file config/its-idg/example/foo', +); # Check for legacy autocreation mappings for file objects. for my $type (qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key)) { -- cgit v1.2.3 From 3733b1537c987a42e4c3f6b30f4ccfef378e7cfc Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 13 Feb 2013 12:13:41 -0800 Subject: Add ssl-keypair to Stanford naming policy Used currently by MDM to store both the certificate and the key in the same file for convenience. Change-Id: I38901ac93fe3022c2e00f735a0f995500841d709 Reviewed-on: https://gerrit.stanford.edu/784 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- docs/stanford-naming | 10 ++++++++++ perl/Wallet/Policy/Stanford.pm | 1 + perl/t/stanford-naming.t | 4 +++- 3 files changed, 14 insertions(+), 1 deletion(-) (limited to 'perl/t') diff --git a/docs/stanford-naming b/docs/stanford-naming index aa59f68..5207c40 100644 --- a/docs/stanford-naming +++ b/docs/stanford-naming @@ -141,6 +141,16 @@ Object Naming (OLD: --ssl-key) + ssl-keypair/[/] + + Same as ssl-key except that the signed certificate is included in + the same file as the private key. This is used for convenience + with some applications that want to have both the signed + certificate and private key in the same file. + + The meaning of and are the same as for + ssl-key. + tivoli-key/ The Tivoli password or backup encryption key for this server. diff --git a/perl/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm index 39bea33..1444d51 100644 --- a/perl/Wallet/Policy/Stanford.pm +++ b/perl/Wallet/Policy/Stanford.pm @@ -69,6 +69,7 @@ our %FILE_TYPE = ( '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 }, diff --git a/perl/t/stanford-naming.t b/perl/t/stanford-naming.t index 9473ed5..3b9ea60 100755 --- a/perl/t/stanford-naming.t +++ b/perl/t/stanford-naming.t @@ -16,7 +16,7 @@ use 5.008; use strict; use warnings; -use Test::More tests => 97; +use Test::More tests => 99; use lib 't/lib'; use Util; @@ -46,6 +46,8 @@ my @VALID_FILES = qw(htpasswd/example.stanford.edu/web ssh-rsa/example.stanford.edu ssl-key/example.stanford.edu ssl-key/example.stanford.edu/mysql + ssl-keypair/example.stanford.edu + ssl-keypair/example.stanford.edu/mysql tivoli-key/example.stanford.edu config/its-idg/example/foo db/its-idg/example/s_foo -- cgit v1.2.3 From b750e56ea3f93fbc09917cacfc6b2737ef9671a7 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 13 Feb 2013 18:24:56 -0800 Subject: Set upgrade directory in Wallet::Admin In the upgrade() wrapper in Wallet::Admin, set the DDL directory in the schema before attempting an upgrade. Change-Id: I691184fc4cf416e68f300bc78f7caffc41bf94b8 Reviewed-on: https://gerrit.stanford.edu/793 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/Admin.pm | 1 + perl/t/admin.t | 2 -- 2 files changed, 1 insertion(+), 2 deletions(-) (limited to 'perl/t') diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index 9fc146c..fd184a0 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -195,6 +195,7 @@ sub upgrade { # Perform the actual upgrade. if ($self->{schema}->get_db_version) { + $self->{schema}->upgrade_directory ($Wallet::Config::DB_DDL_DIRECTORY); eval { $self->{schema}->upgrade; }; } if ($@) { diff --git a/perl/t/admin.t b/perl/t/admin.t index ff69ee9..a11b9b2 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -63,8 +63,6 @@ $Wallet::Schema::VERSION = '0.07'; is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, ' and re-initialization succeeds'); $Wallet::Schema::VERSION = '0.08'; -my $schema = $admin->schema; -$schema->upgrade_directory ('sql/'); my $retval = $admin->upgrade; is ($retval, 1, 'Performing an upgrade succeeds'); my $dbh = $admin->dbh; -- cgit v1.2.3 From 4d11772001f65264bf714711550acdbb05900f4c Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 27 Feb 2013 14:46:47 -0800 Subject: Use correct form of Stanford's copyright statement Change-Id: I06dd9ecca19315179bdd34d4b301548fe7604331 Reviewed-on: https://gerrit.stanford.edu/842 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- client/file.c | 3 ++- client/internal.h | 3 ++- client/keytab.c | 3 ++- client/krb5.c | 3 ++- client/options.c | 2 +- client/remctl.c | 3 ++- client/srvtab.c | 3 ++- client/wallet-rekey.c | 3 ++- client/wallet.c | 2 +- configure.ac | 4 +--- contrib/convert-srvtab-db | 3 ++- contrib/used-principals | 3 ++- contrib/wallet-contacts | 3 ++- contrib/wallet-summary | 3 ++- contrib/wallet-unknown-hosts | 3 ++- examples/stanford.conf | 3 ++- perl/Wallet/ACL.pm | 3 ++- perl/Wallet/ACL/Base.pm | 3 ++- perl/Wallet/ACL/Krb5.pm | 3 ++- perl/Wallet/ACL/Krb5/Regex.pm | 3 ++- perl/Wallet/ACL/NetDB.pm | 3 ++- perl/Wallet/ACL/NetDB/Root.pm | 3 ++- perl/Wallet/Config.pm | 3 ++- perl/Wallet/Database.pm | 3 ++- perl/Wallet/Kadmin.pm | 3 ++- perl/Wallet/Kadmin/Heimdal.pm | 3 ++- perl/Wallet/Kadmin/MIT.pm | 2 +- perl/Wallet/Object/File.pm | 3 ++- perl/Wallet/Object/Keytab.pm | 4 ++-- perl/Wallet/Report.pm | 3 ++- perl/create-ddl | 3 ++- perl/t/acl.t | 3 ++- perl/t/config.t | 3 ++- perl/t/file.t | 3 ++- perl/t/init.t | 3 ++- perl/t/keytab.t | 2 +- perl/t/lib/Util.pm | 3 ++- perl/t/pod.t | 3 ++- perl/t/report.t | 3 ++- perl/t/verifier-netdb.t | 3 ++- perl/t/verifier.t | 3 ++- server/keytab-backend | 2 +- server/wallet-report | 3 ++- tests/client/basic-t.in | 2 +- tests/client/full-t.in | 3 ++- tests/client/prompt-t.in | 3 ++- tests/client/rekey-t.in | 2 +- tests/data/cmd-fake | 4 +++- tests/data/fake-kadmin | 3 ++- tests/server/keytab-t | 3 ++- tests/server/report-t | 3 ++- 51 files changed, 95 insertions(+), 54 deletions(-) (limited to 'perl/t') diff --git a/client/file.c b/client/file.c index 861da6a..c171969 100644 --- a/client/file.c +++ b/client/file.c @@ -2,7 +2,8 @@ * File handling for the wallet client. * * Written by Russ Allbery - * Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University + * Copyright 2007, 2008, 2010 + * The Board of Trustees of the Leland Stanford Junior University * * See LICENSE for licensing terms. */ diff --git a/client/internal.h b/client/internal.h index c8e5802..24dd875 100644 --- a/client/internal.h +++ b/client/internal.h @@ -2,7 +2,8 @@ * Internal support functions for the wallet client. * * Written by Russ Allbery - * Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University + * Copyright 2007, 2008, 2010 + * The Board of Trustees of the Leland Stanford Junior University * * See LICENSE for licensing terms. */ diff --git a/client/keytab.c b/client/keytab.c index 6614c4b..0a3e419 100644 --- a/client/keytab.c +++ b/client/keytab.c @@ -2,7 +2,8 @@ * Implementation of keytab handling for the wallet client. * * Written by Russ Allbery - * 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. */ diff --git a/client/krb5.c b/client/krb5.c index aad39f6..e86a225 100644 --- a/client/krb5.c +++ b/client/krb5.c @@ -6,7 +6,8 @@ * client. * * Written by Russ Allbery - * Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University + * Copyright 2007, 2008, 2010 + * The Board of Trustees of the Leland Stanford Junior University */ #include diff --git a/client/options.c b/client/options.c index 2f1de70..67ecb7f 100644 --- a/client/options.c +++ b/client/options.c @@ -6,7 +6,7 @@ * * Written by Russ Allbery * Copyright 2006, 2007, 2008, 2010 - * Board of Trustees, Leland Stanford Jr. University + * The Board of Trustees of the Leland Stanford Junior University * * See LICENSE for licensing terms. */ diff --git a/client/remctl.c b/client/remctl.c index 5a541d5..071e410 100644 --- a/client/remctl.c +++ b/client/remctl.c @@ -2,7 +2,8 @@ * remctl interface for the wallet client. * * Written by Russ Allbery - * 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. */ diff --git a/client/srvtab.c b/client/srvtab.c index b26e6fc..73277e9 100644 --- a/client/srvtab.c +++ b/client/srvtab.c @@ -2,7 +2,8 @@ * Implementation of srvtab handling for the wallet client. * * Written by Russ Allbery - * Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University + * Copyright 2007, 2008, 2010 + * The Board of Trustees of the Leland Stanford Junior University * * See LICENSE for licensing terms. */ diff --git a/client/wallet-rekey.c b/client/wallet-rekey.c index 3a9687c..5007f41 100644 --- a/client/wallet-rekey.c +++ b/client/wallet-rekey.c @@ -3,7 +3,8 @@ * * Written by Russ Allbery * and Jon Robertson - * Copyright 2010 Board of Trustees, Leland Stanford Jr. University + * Copyright 2010 + * The Board of Trustees of the Leland Stanford Junior University * * See LICENSE for licensing terms. */ diff --git a/client/wallet.c b/client/wallet.c index dc04dcd..c5a7877 100644 --- a/client/wallet.c +++ b/client/wallet.c @@ -3,7 +3,7 @@ * * Written by Russ Allbery * Copyright 2006, 2007, 2008, 2010 - * Board of Trustees, Leland Stanford Jr. University + * The Board of Trustees of the Leland Stanford Junior University * * See LICENSE for licensing terms. */ diff --git a/configure.ac b/configure.ac index a79e42d..4fc218b 100644 --- a/configure.ac +++ b/configure.ac @@ -2,12 +2,10 @@ dnl Autoconf configuration for wallet. dnl dnl Written by Russ Allbery dnl Copyright 2006, 2007, 2008, 2010 -dnl Board of Trustees, Leland Stanford Jr. University +dnl The Board of Trustees of the Leland Stanford Junior University dnl dnl See LICENSE for licensing terms. -dnl We cannot use -Wall -Werror with AM_INIT_AUTOMAKE since we override -dnl distuninstallcheck (not supported by Perl). AC_PREREQ([2.64]) AC_INIT([wallet], [0.12], [rra@stanford.edu]) AC_CONFIG_AUX_DIR([build-aux]) diff --git a/contrib/convert-srvtab-db b/contrib/convert-srvtab-db index 8d3b31e..6263472 100755 --- a/contrib/convert-srvtab-db +++ b/contrib/convert-srvtab-db @@ -3,7 +3,8 @@ # convert-srvtab-db -- Converts a leland_srvtab database to wallet # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/contrib/used-principals b/contrib/used-principals index aa838fe..ca431e3 100755 --- a/contrib/used-principals +++ b/contrib/used-principals @@ -3,7 +3,8 @@ # used-principals -- Report which Kerberos v5 principals are in use. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/contrib/wallet-contacts b/contrib/wallet-contacts index 177fc76..907c161 100755 --- a/contrib/wallet-contacts +++ b/contrib/wallet-contacts @@ -3,7 +3,8 @@ # wallet-contacts -- Report contact addresses for matching wallet objects. # # Written by Russ Allbery -# Copyright 2009 Board of Trustees, Leland Stanford Jr. University +# Copyright 2009 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/contrib/wallet-summary b/contrib/wallet-summary index aba8406..2237351 100755 --- a/contrib/wallet-summary +++ b/contrib/wallet-summary @@ -3,7 +3,8 @@ # wallet-summary -- Summarize keytabs in the wallet database. # # Written by Russ Allbery -# Copyright 2003, 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2003, 2008, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/contrib/wallet-unknown-hosts b/contrib/wallet-unknown-hosts index da972b2..e19dcf0 100755 --- a/contrib/wallet-unknown-hosts +++ b/contrib/wallet-unknown-hosts @@ -3,7 +3,8 @@ # wallet-unknown-hosts -- Report host keytabs in wallet for unknown hosts. # # Written by Russ Allbery -# Copyright 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/examples/stanford.conf b/examples/stanford.conf index becfc6e..1d14796 100644 --- a/examples/stanford.conf +++ b/examples/stanford.conf @@ -6,7 +6,8 @@ # ACL rules. # # Written by Russ Allbery -# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm index 1e62e7b..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 -# 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. diff --git a/perl/Wallet/ACL/Base.pm b/perl/Wallet/ACL/Base.pm index 85eaefa..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 -# 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. diff --git a/perl/Wallet/ACL/Krb5.pm b/perl/Wallet/ACL/Krb5.pm index 12be141..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 -# 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. diff --git a/perl/Wallet/ACL/Krb5/Regex.pm b/perl/Wallet/ACL/Krb5/Regex.pm index 8f9702e..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 -# 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. diff --git a/perl/Wallet/ACL/NetDB.pm b/perl/Wallet/ACL/NetDB.pm index 0aa8958..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 -# 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. diff --git a/perl/Wallet/ACL/NetDB/Root.pm b/perl/Wallet/ACL/NetDB/Root.pm index c28bb1e..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 -# 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. diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index 9649c6c..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 -# 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. diff --git a/perl/Wallet/Database.pm b/perl/Wallet/Database.pm index 8df338a..61de0ba 100644 --- a/perl/Wallet/Database.pm +++ b/perl/Wallet/Database.pm @@ -6,7 +6,8 @@ # like DBIx::Class objects in the rest of the code. # # Written by Russ Allbery -# Copyright 2008-2012 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. 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 -# 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 6c91b1d..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 -# 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/MIT.pm b/perl/Wallet/Kadmin/MIT.pm index c191bc9..b633e67 100644 --- a/perl/Wallet/Kadmin/MIT.pm +++ b/perl/Wallet/Kadmin/MIT.pm @@ -3,7 +3,7 @@ # Written by Russ Allbery # Pulled into a module by Jon Robertson # 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. diff --git a/perl/Wallet/Object/File.pm b/perl/Wallet/Object/File.pm index 69468e1..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 -# 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. diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index 962c19b..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 -# 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. diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index ff25b3a..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 -# 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. diff --git a/perl/create-ddl b/perl/create-ddl index 62deb86..10f126a 100755 --- a/perl/create-ddl +++ b/perl/create-ddl @@ -3,7 +3,8 @@ # create-ddl - Create DDL files for Wallet # # Written by Jon Robertson -# Copyright 2012 Board of Trustees, Leland Stanford Jr. University +# Copyright 2012 +# The Board of Trustees of the Leland Stanford Junior University ############################################################################# # Modules and declarations diff --git a/perl/t/acl.t b/perl/t/acl.t index 62eb411..26b4903 100755 --- a/perl/t/acl.t +++ b/perl/t/acl.t @@ -3,7 +3,8 @@ # Tests for the wallet ACL API. # # Written by Russ Allbery -# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/perl/t/config.t b/perl/t/config.t index 6b9f226..543e5d6 100755 --- a/perl/t/config.t +++ b/perl/t/config.t @@ -3,7 +3,8 @@ # Tests for the wallet server configuration. # # Written by Russ Allbery -# 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. diff --git a/perl/t/file.t b/perl/t/file.t index f902fba..5cb7c35 100755 --- a/perl/t/file.t +++ b/perl/t/file.t @@ -3,7 +3,8 @@ # Tests for the file object implementation. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/perl/t/init.t b/perl/t/init.t index aa028e3..142f54c 100755 --- a/perl/t/init.t +++ b/perl/t/init.t @@ -3,7 +3,8 @@ # Tests for database initialization. # # Written by Russ Allbery -# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 561f130..3ced592 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -4,7 +4,7 @@ # # Written by Russ Allbery # 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. diff --git a/perl/t/lib/Util.pm b/perl/t/lib/Util.pm index c15ccfe..3e606fe 100644 --- a/perl/t/lib/Util.pm +++ b/perl/t/lib/Util.pm @@ -1,7 +1,8 @@ # Utility class for wallet tests. # # Written by Russ Allbery -# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/perl/t/pod.t b/perl/t/pod.t index c467b82..dc5f468 100755 --- a/perl/t/pod.t +++ b/perl/t/pod.t @@ -3,7 +3,8 @@ # Test POD formatting for the wallet Perl modules. # # Written by Russ Allbery -# 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. diff --git a/perl/t/report.t b/perl/t/report.t index 13ef7b6..a6b85df 100755 --- a/perl/t/report.t +++ b/perl/t/report.t @@ -3,7 +3,8 @@ # Tests for the wallet reporting interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/perl/t/verifier-netdb.t b/perl/t/verifier-netdb.t index 6bd4e73..398cc6a 100755 --- a/perl/t/verifier-netdb.t +++ b/perl/t/verifier-netdb.t @@ -7,7 +7,8 @@ # environments. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/perl/t/verifier.t b/perl/t/verifier.t index f56f5fa..75f1afa 100755 --- a/perl/t/verifier.t +++ b/perl/t/verifier.t @@ -3,7 +3,8 @@ # Tests for the basic wallet ACL verifiers. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/server/keytab-backend b/server/keytab-backend index 7b6adb4..3ea3df0 100755 --- a/server/keytab-backend +++ b/server/keytab-backend @@ -18,7 +18,7 @@ # # Written by Russ Allbery # Copyright 2006, 2007, 2008, 2010 -# Board of Trustees, Leland Stanford Jr. University +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/server/wallet-report b/server/wallet-report index 992f5b8..0fd8aa9 100755 --- a/server/wallet-report +++ b/server/wallet-report @@ -3,7 +3,8 @@ # wallet-report -- Wallet server reporting interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/tests/client/basic-t.in b/tests/client/basic-t.in index 11f0bce..836f394 100644 --- a/tests/client/basic-t.in +++ b/tests/client/basic-t.in @@ -4,7 +4,7 @@ # # Written by Russ Allbery # Copyright 2006, 2007, 2008, 2010 -# Board of Trustees, Leland Stanford Jr. University +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/tests/client/full-t.in b/tests/client/full-t.in index 680e78f..ebdba03 100644 --- a/tests/client/full-t.in +++ b/tests/client/full-t.in @@ -3,7 +3,8 @@ # End-to-end tests for the wallet client. # # Written by Russ Allbery -# 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. diff --git a/tests/client/prompt-t.in b/tests/client/prompt-t.in index 682cd70..06991cc 100644 --- a/tests/client/prompt-t.in +++ b/tests/client/prompt-t.in @@ -3,7 +3,8 @@ # Password prompting tests for the wallet client. # # Written by Russ Allbery -# 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. diff --git a/tests/client/rekey-t.in b/tests/client/rekey-t.in index 390a362..0cfcb5d 100644 --- a/tests/client/rekey-t.in +++ b/tests/client/rekey-t.in @@ -4,7 +4,7 @@ # # Written by Russ Allbery # Copyright 2006, 2007, 2008, 2010 -# Board of Trustees, Leland Stanford Jr. University +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/tests/data/cmd-fake b/tests/data/cmd-fake index add72fc..11791a6 100755 --- a/tests/data/cmd-fake +++ b/tests/data/cmd-fake @@ -4,7 +4,9 @@ # the client test suite. It doesn't test any of the wallet server code. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# # See LICENSE for licensing terms. command="$1" diff --git a/tests/data/fake-kadmin b/tests/data/fake-kadmin index 4c0ceac..c073ea5 100755 --- a/tests/data/fake-kadmin +++ b/tests/data/fake-kadmin @@ -3,7 +3,8 @@ # Fake kadmin.local used to test the keytab backend. # # Written by Russ Allbery -# Copyright 2007 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/tests/server/keytab-t b/tests/server/keytab-t index 2a0ceed..a9f5450 100755 --- a/tests/server/keytab-t +++ b/tests/server/keytab-t @@ -3,7 +3,8 @@ # Tests for the keytab-backend dispatch code. # # Written by Russ Allbery -# Copyright 2006, 2007, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2006, 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. diff --git a/tests/server/report-t b/tests/server/report-t index 0771946..43ec9d1 100755 --- a/tests/server/report-t +++ b/tests/server/report-t @@ -3,7 +3,8 @@ # Tests for the wallet-report dispatch code. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. -- cgit v1.2.3 From 9ae4e978acd8d36b39e52087806b00acdf7837ad Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 27 Feb 2013 15:17:50 -0800 Subject: Mark the LDAP verifier test as maintainer-only This currently requires global read access to the Stanford LDAP directory, so even other people at Stanford can't run it. Will revisit when we have a chance to write mock LDAP classes. Change-Id: I0e944b8019744b14a62e60d5dcc662b417108722 Reviewed-on: https://gerrit.stanford.edu/844 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/t/verifier-ldap-attr.t | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'perl/t') diff --git a/perl/t/verifier-ldap-attr.t b/perl/t/verifier-ldap-attr.t index 1c84fac..41d6737 100755 --- a/perl/t/verifier-ldap-attr.t +++ b/perl/t/verifier-ldap-attr.t @@ -6,17 +6,24 @@ # access to the LDAP server and will be skipped in all other environments. # # Written by Russ Allbery -# Copyright 2012 +# Copyright 2012, 2013 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. -use Test::More tests => 10; +use Test::More; use lib 't/lib'; use Util; -BEGIN { use_ok ('Wallet::ACL::LDAP::Attribute') }; +# Skip all spelling tests unless the maintainer environment variable is set. +plan skip_all => 'LDAP verifier tests only run for maintainer' + unless $ENV{RRA_MAINTAINER_TESTS}; + +# Declare a plan. +plan tests => 10; + +require_ok ('Wallet::ACL::LDAP::Attribute'); my $host = 'ldap.stanford.edu'; my $base = 'cn=people,dc=stanford,dc=edu'; -- cgit v1.2.3 From 18edd82ea59d8ddea7647a5848a082b78c68db1f Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 27 Feb 2013 15:35:10 -0800 Subject: Add explicit license statement to perl/t/data/README Change-Id: Ibad85d6d7c653b557e9ec297a4268068261271fa Reviewed-on: https://gerrit.stanford.edu/847 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/t/data/README | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'perl/t') diff --git a/perl/t/data/README b/perl/t/data/README index d250d33..4ceccff 100644 --- a/perl/t/data/README +++ b/perl/t/data/README @@ -58,3 +58,13 @@ also need to be configured in your local krb.conf (but not krb.realms). The test process will create the principals wallet.one and wallet.two and on success will clean up after itself. If the test fails, they may be left behind in the AFS kaserver. + +----- + +Copyright 2007, 2009, 2013 + The Board of Trustees of the Leland Stanford Junior University + +Copying and distribution of this file, with or without modification, are +permitted in any medium without royalty provided the copyright notice and +this notice are preserved. This file is offered as-is, without any +warranty. -- cgit v1.2.3 From f6c63bdb2be5ccc0c6133bf87025d37805579005 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 27 Mar 2013 12:51:46 -0700 Subject: Allow owners of objects to destroy them by default Owners of wallet objects are now allowed to destroy them. In previous versions, a special destroy ACL had to be set and the owner ACL wasn't used for destroy actions, but operational experience at Stanford has shown that letting owners destroy their own objects is a better model. Change-Id: I0e97d7a000e62cf5321add7b44140db6edc6769f Reviewed-on: https://gerrit.stanford.edu/973 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- NEWS | 5 +++++ client/wallet.pod | 6 +++--- docs/design | 6 +++--- docs/notes | 12 ++++++------ perl/Wallet/Server.pm | 19 ++++++++++--------- perl/t/server.t | 20 ++++++++++++-------- server/keytab-backend | 2 +- server/wallet-backend | 8 ++++---- 8 files changed, 44 insertions(+), 34 deletions(-) (limited to 'perl/t') diff --git a/NEWS b/NEWS index 0d98220..d236f6a 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,11 @@ wallet 1.0 (unreleased) + Owners of wallet objects are now allowed to destroy them. In previous + versions, a special destroy ACL had to be set and the owner ACL wasn't + used for destroy actions, but operational experience at Stanford has + shown that letting owners destroy their own objects is a better model. + wallet-admin has a new sub-command, upgrade, which upgrades the wallet database to the latest schema version. This command should be run when deploying any new version of the wallet server. diff --git a/client/wallet.pod b/client/wallet.pod index 32d81ad..214a157 100644 --- a/client/wallet.pod +++ b/client/wallet.pod @@ -159,9 +159,9 @@ C and C, which use the C ACL, C, which uses the C ACL, and C, which uses the owner or C ACL depending on whether one is setting or retrieving the comment. If the appropriate ACL is set, it alone is checked to see if the user has access. -Otherwise, C, C, C, C, C, C, -and C access is permitted if the user is authorized by the owner -ACL of the object. +Otherwise, C, C, C, C, C, C, +C, and C access is permitted if the user is authorized +by the owner ACL of the object. Administrators can run any command on any object or ACL except for C and C. For C and C, they must still be authorized by diff --git a/docs/design b/docs/design index 4bb5587..8f4b20d 100644 --- a/docs/design +++ b/docs/design @@ -148,9 +148,9 @@ Server Design * Optional ACLs for get, store, show, destroy, and flag operations. If there is an ACL for get, store, or show, that overrides the - normal permissions of the owner. In the absence of an ACL for - destroy or flag, only wallet administrators can destroy an object or - set flags on that object. This entry would need no special ACLs. + normal permissions of the owner. In the absence of an ACL for flag, + only wallet administrators can set flags on that object. This entry + would need no special ACLs. * Trace fields storing the user, remote host, and timestamp for when this object was last created, stored, and downloaded. diff --git a/docs/notes b/docs/notes index 84a82d1..5a7d3bc 100644 --- a/docs/notes +++ b/docs/notes @@ -46,7 +46,7 @@ Server Issues ACL Management - Supported operations are: get, store, create (possibly triggered by a + Supported operations are: get, store, create (possibly triggered by a get or store of something that didn't already exist), destroy, show, and setting or clearing flags. Each of these need a separate ACL potentially. Not sure if we're going to need separate ACLs for each @@ -62,10 +62,9 @@ Server Issues that returns a default ACL given the object type and name if the object doesn't already exist. - Owner rights provides get, store, and show, but not destroy or setting - or clearing flags (not destroy because it's too destructive and we - don't want it done accidentally). This can be overridden by more - precise ACL settings. So the ACL logic would go like this: + Owner rights provides get, store, show, and destroy, but not setting + or clearing flags. This can be overridden by more precise ACL + settings. So the ACL logic would go like this: * If the user is an administrator and the operation isn't get or store, operation is permitted. @@ -74,7 +73,8 @@ Server Issues that specific ACL, apply that ACL. * If the object exists but with no specific ACL setting and the - operation is one of get, store, or show, apply the owner ACL. + operation is one of get, store, show, or destroy, apply the owner + ACL. * If the object doesn't exist and the action is get, store, or create, punt to a local policy if it exists and see if it returns a diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm index db53f6c..6d67e17 100644 --- a/perl/Wallet/Server.pm +++ b/perl/Wallet/Server.pm @@ -1,7 +1,7 @@ # Wallet::Server -- Wallet system server implementation. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011 +# Copyright 2007, 2008, 2010, 2011, 2013 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -301,7 +301,7 @@ sub acl_verify { } elsif ($action ne 'comment') { $id = $object->acl ($action); } - if (! defined ($id) and $action ne 'flags' and $action ne 'destroy') { + if (! defined ($id) and $action ne 'flags') { $id = $object->owner; } unless (defined $id) { @@ -970,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() @@ -981,10 +982,6 @@ mostly for testing; normally, clients should perform all actions through the Wallet::Server object to ensure that authorization and history logging is done properly. -=item schema() - -Returns the DBIx::Class schema object. - =item error() Returns the error of the last failing operation or undef if no operations @@ -1058,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 diff --git a/perl/t/server.t b/perl/t/server.t index 8474989..4afda51 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -3,12 +3,12 @@ # Tests for the wallet server API. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011, 2012 +# Copyright 2007, 2008, 2010, 2011, 2012, 2013 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. -use Test::More tests => 381; +use Test::More tests => 382; use POSIX qw(strftime); use Wallet::Admin; @@ -497,10 +497,6 @@ is ($server->create ('base', 'service/test'), undef, ' nor can we create objects'); is ($server->error, "$user1 not authorized to create base:service/test", ' with error'); -is ($server->destroy ('base', 'service/user1'), undef, - ' or destroy objects'); -is ($server->error, "$user1 not authorized to destroy base:service/user1", - ' with error'); is ($server->owner ('base', 'service/user1', 'user2'), undef, ' or set the owner'); is ($server->error, @@ -801,6 +797,12 @@ is ($server->store ('base', 'service/both', 'stuff'), undef, ' or store it'); is ($server->error, 'cannot find base:service/both', ' because it is gone'); +# Switch back to user1 and test destroy. +$server = eval { Wallet::Server->new ($user1, $host) }; +is ($@, '', 'Switching users works'); +is ($server->destroy ('base', 'service/user1'), 1, + 'Destroy of an object we own with no destroy ACLs works'); + # Test default ACLs on object creation. # # Create a default_acl sub that permits $user2 to create service/default with @@ -836,8 +838,10 @@ sub default_owner { } package main; -# We're still user2, so we should now be able to create service/default. Make -# sure we can and that the ACLs all look good. +# Switch back to user2, so we should now be able to create service/default. +# Make sure we can and that the ACLs all look good. +$server = eval { Wallet::Server->new ($user2, $host) }; +is ($@, '', 'Switching users works'); is ($server->create ('base', 'service/default'), undef, 'Creating an object with the default ACL fails'); is ($server->error, "$user2 not authorized to create base:service/default", diff --git a/server/keytab-backend b/server/keytab-backend index e45aba2..b0116c7 100755 --- a/server/keytab-backend +++ b/server/keytab-backend @@ -152,7 +152,7 @@ __END__ =for stopwords keytab-backend keytabs KDC keytab kadmin.local -norandkey ktadd remctld -auth Allbery rekeying +auth Allbery rekeying MERCHANTABILITY NONINFRINGEMENT sublicense =head1 NAME diff --git a/server/wallet-backend b/server/wallet-backend index 9d45982..fc3434e 100755 --- a/server/wallet-backend +++ b/server/wallet-backend @@ -335,7 +335,7 @@ __END__ =for stopwords wallet-backend backend backend-specific remctld ACL acl timestamp getacl setacl metadata keytab keytabs enctypes enctype ktadd KDC Allbery -autocreate +autocreate MERCHANTABILITY NONINFRINGEMENT sublicense =head1 NAME @@ -386,9 +386,9 @@ C and C, which use the C ACL, C, which uses the C ACL, and C, which uses the owner or C ACL depending on whether one is setting or retrieving the comment. If the appropriate ACL is set, it alone is checked to see if the user has access. -Otherwise, C, C, C, C, C, C, -and C access is permitted if the user is authorized by the owner -ACL of the object. +Otherwise, C, C, C, C, C, C, +C, and C access is permitted if the user is authorized +by the owner ACL of the object. Administrators can run any command on any object or ACL except for C and C. For C and C, they must still be authorized by -- cgit v1.2.3 From e44a0417cde0235c2fc368e86acea3d257816958 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 27 Mar 2013 15:02:23 -0700 Subject: Fix test skip counts for some of the Perl tests Change-Id: Ic0f33bf01936a093a645bedd5adfa771fd4e3574 Reviewed-on: https://gerrit.stanford.edu/983 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/t/kadmin.t | 4 ++-- perl/t/keytab.t | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) (limited to 'perl/t') diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index cefd80d..8eabc6b 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -3,7 +3,7 @@ # Tests for the kadmin object implementation. # # Written by Jon Robertson -# Copyright 2009, 2010, 2012 +# Copyright 2009, 2010, 2012, 2013 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -73,7 +73,7 @@ SKIP: { # implementation is configured. This retests some things that are also tested # by the keytab test, but specifically through the Wallet::Kadmin API. SKIP: { - skip 'no keytab configuration', 15 unless -f 't/data/test.keytab'; + skip 'no keytab configuration', 16 unless -f 't/data/test.keytab'; # Set up our configuration. $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 3ced592..f89b2c6 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -3,7 +3,7 @@ # Tests for the keytab object implementation. # # Written by Russ Allbery -# Copyright 2007, 2008, 2009, 2010 +# Copyright 2007, 2008, 2009, 2010, 2013 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -386,7 +386,7 @@ EOO # Tests for unchanging support. Skip these if we don't have a keytab or if we # can't find remctld. SKIP: { - skip 'no keytab configuration', 27 unless -f 't/data/test.keytab'; + skip 'no keytab configuration', 31 unless -f 't/data/test.keytab'; # Set up our configuration. $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; -- cgit v1.2.3