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 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