From 1575d5c34a2c6235bbf6a5010f8a8c142fe47079 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 11 Jul 2014 21:39:23 -0700 Subject: Switch to Module::Build for the Perl module The wallet server now requires Perl 5.8 or later (instead of 5.006 in previous versions) and is now built with Module::Build instead of ExtUtils::MakeMaker. This should be transparent to anyone not working with the source code, since Perl 5.8 was released in 2002, but Module::Build is now required to build the wallet server. It is included in some versions of Perl, or can be installed separately from CPAN, distribution packages, or other sources. Also reorganize the test suite to use subdirectories. Change-Id: Id06120ba2bad1ebbfee3d8a48ca2f25869463165 Reviewed-on: https://gerrit.stanford.edu/1530 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/t/acl.t | 232 ---------- perl/t/admin.t | 106 ----- perl/t/config.t | 44 -- perl/t/docs/pod-spelling.t | 74 +++ perl/t/docs/pod.t | 15 + perl/t/duo.t | 157 ------- perl/t/file.t | 150 ------- perl/t/general/acl.t | 232 ++++++++++ perl/t/general/admin.t | 106 +++++ perl/t/general/config.t | 44 ++ perl/t/general/init.t | 58 +++ perl/t/general/report.t | 330 ++++++++++++++ perl/t/general/server.t | 1040 +++++++++++++++++++++++++++++++++++++++++++ perl/t/init.t | 58 --- perl/t/kadmin.t | 117 ----- perl/t/keytab.t | 771 -------------------------------- perl/t/object.t | 353 --------------- perl/t/object/base.t | 353 +++++++++++++++ perl/t/object/duo.t | 157 +++++++ perl/t/object/file.t | 150 +++++++ perl/t/object/keytab.t | 771 ++++++++++++++++++++++++++++++++ perl/t/object/wa-keyring.t | 184 ++++++++ perl/t/pod-spelling.t | 74 --- perl/t/pod.t | 15 - perl/t/policy/stanford.t | 260 +++++++++++ perl/t/report.t | 330 -------------- perl/t/server.t | 1040 ------------------------------------------- perl/t/stanford-naming.t | 260 ----------- perl/t/util/kadmin.t | 117 +++++ perl/t/verifier-ldap-attr.t | 73 --- perl/t/verifier-netdb.t | 45 -- perl/t/verifier.t | 155 ------- perl/t/verifier/basic.t | 155 +++++++ perl/t/verifier/ldap-attr.t | 73 +++ perl/t/verifier/netdb.t | 45 ++ perl/t/wa-keyring.t | 184 -------- 36 files changed, 4164 insertions(+), 4164 deletions(-) delete mode 100755 perl/t/acl.t delete mode 100755 perl/t/admin.t delete mode 100755 perl/t/config.t create mode 100755 perl/t/docs/pod-spelling.t create mode 100755 perl/t/docs/pod.t delete mode 100755 perl/t/duo.t delete mode 100755 perl/t/file.t create mode 100755 perl/t/general/acl.t create mode 100755 perl/t/general/admin.t create mode 100755 perl/t/general/config.t create mode 100755 perl/t/general/init.t create mode 100755 perl/t/general/report.t create mode 100755 perl/t/general/server.t delete mode 100755 perl/t/init.t delete mode 100755 perl/t/kadmin.t delete mode 100755 perl/t/keytab.t delete mode 100755 perl/t/object.t create mode 100755 perl/t/object/base.t create mode 100755 perl/t/object/duo.t create mode 100755 perl/t/object/file.t create mode 100755 perl/t/object/keytab.t create mode 100755 perl/t/object/wa-keyring.t delete mode 100755 perl/t/pod-spelling.t delete mode 100755 perl/t/pod.t create mode 100755 perl/t/policy/stanford.t delete mode 100755 perl/t/report.t delete mode 100755 perl/t/server.t delete mode 100755 perl/t/stanford-naming.t create mode 100755 perl/t/util/kadmin.t delete mode 100755 perl/t/verifier-ldap-attr.t delete mode 100755 perl/t/verifier-netdb.t delete mode 100755 perl/t/verifier.t create mode 100755 perl/t/verifier/basic.t create mode 100755 perl/t/verifier/ldap-attr.t create mode 100755 perl/t/verifier/netdb.t delete mode 100755 perl/t/wa-keyring.t (limited to 'perl/t') diff --git a/perl/t/acl.t b/perl/t/acl.t deleted file mode 100755 index e633f46..0000000 --- a/perl/t/acl.t +++ /dev/null @@ -1,232 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the wallet ACL API. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use POSIX qw(strftime); -use Test::More tests => 101; - -use Wallet::ACL; -use Wallet::Admin; -use Wallet::Server; - -use lib 't/lib'; -use Util; - -# Some global defaults to use. -my $admin = 'admin@EXAMPLE.COM'; -my $user1 = 'alice@EXAMPLE.COM'; -my $user2 = 'bob@EXAMPLE.COM'; -my $host = 'localhost'; -my @trace = ($admin, $host, time); - -# Use Wallet::Admin to set up the database. -db_setup; -my $setup = eval { Wallet::Admin->new }; -is ($@, '', 'Database connection succeeded'); -is ($setup->reinitialize ($setup), 1, 'Database initialization succeeded'); -my $schema = $setup->schema; - -# Test create and new. -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, $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', $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', $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', $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, $schema) }; -ok (defined ($acl), 'Searching for the test ACL by ID'); -is ($@, '', ' with no exceptions'); -ok ($acl->isa ('Wallet::ACL'), ' and the right class'); -is ($acl->name, 'test', ' and the right name'); - -# Test rename. -if ($acl->rename ('example')) { - ok (1, 'Renaming the ACL'); -} else { - is ($acl->error, '', 'Renaming the ACL'); -} -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', $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', $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, $schema) }; -ok (defined ($acl), ' and it can still found by ID'); -is ($@, '', ' with no exceptions'); -is ($acl->name, 'example', ' and the right name'); -is ($acl->id, 2, ' and the right ID'); -ok (! $acl->rename ('ADMIN'), ' but renaming to an existing name fails'); -like ($acl->error, qr/^cannot rename ACL 2 to ADMIN: /, - ' with the right error'); - -# Test add, check, remove, list, and show. -my @entries = $acl->list; -is (scalar (@entries), 0, 'ACL starts empty'); -is ($acl->check ($user1), 0, ' so check fails'); -is (scalar ($acl->check_errors), '', ' with no errors'); -ok (! $acl->add ('example', 'foo', @trace), ' and cannot add bad scheme'); -is ($acl->error, 'unknown ACL scheme example', ' with the right error'); -if ($acl->add ('krb5', $user1, @trace)) { - ok (1, ' and can add a good scheme'); -} else { - is ($acl->error, '', ' and can add a good scheme'); -} -@entries = $acl->list; -is (scalar (@entries), 1, ' and now there is one element'); -is ($entries[0][0], 'krb5', ' with the right scheme'); -is ($entries[0][1], $user1, ' and identifier'); -is ($acl->check ($user1), 1, ' so check succeeds'); -is (scalar ($acl->check_errors), '', ' with no errors'); -is ($acl->check ($user2), 0, ' but the second user still fails'); -is (scalar ($acl->check_errors), '', ' with no errors'); -if ($acl->add ('krb5', $user2, @trace)) { - ok (1, ' and can add a second entry'); -} else { - is ($acl->error, '', ' and can add a second entry'); -} -is ($acl->check ($user2), 1, ' and now the second user checks'); -is (scalar ($acl->check_errors), '', ' with no errors'); -is ($acl->check ($user1), 1, ' and the first one still checks'); -is (scalar ($acl->check_errors), '', ' with no errors'); -@entries = sort { $a->[1] cmp $b->[1] } $acl->list; -is (scalar (@entries), 2, ' and now there are two entries'); -is ($entries[0][0], 'krb5', ' with the right scheme for 1'); -is ($entries[0][1], $user1, ' and the right identifier for 1'); -is ($entries[1][0], 'krb5', ' and the right scheme for 2'); -is ($entries[1][1], $user2, ' and the right identifier for 2'); -my $expected = <<"EOE"; -Members of ACL example (id: 2) are: - krb5 $user1 - krb5 $user2 -EOE -is ($acl->show, $expected, ' and show returns correctly'); -ok (! $acl->remove ('krb5', $admin, @trace), - 'Removing a nonexistent entry fails'); -is ($acl->error, "cannot remove krb5:$admin from 2: entry not found in ACL", - ' with the right error'); -if ($acl->remove ('krb5', $user1, @trace)) { - ok (1, ' but removing the first user works'); -} else { - is ($acl->error, '', ' but removing the first user works'); -} -is ($acl->check ($user1), 0, ' and now they do not check'); -is (scalar ($acl->check_errors), '', ' with no errors'); -@entries = $acl->list; -is (scalar (@entries), 1, ' and now there is one entry'); -is ($entries[0][0], 'krb5', ' with the right scheme'); -is ($entries[0][1], $user2, ' and the right identifier'); -ok (! $acl->add ('krb5', $user2), 'Adding the same entry again fails'); -like ($acl->error, qr/^cannot add \Qkrb5:$user2\E to 2: /, - ' with the right error'); -if ($acl->add ('krb5', '', @trace)) { - ok (1, 'Adding a bad entry works'); -} else { - is ($acl->error, '', 'Adding a bad entry works'); -} -@entries = sort { $a->[1] cmp $b->[1] } $acl->list; -is (scalar (@entries), 2, ' and now there are two entries'); -is ($entries[0][0], 'krb5', ' with the right scheme for 1'); -is ($entries[0][1], '', ' and the right identifier for 1'); -is ($entries[1][0], 'krb5', ' and the right scheme for 2'); -is ($entries[1][1], $user2, ' and the right identifier for 2'); -$expected = <<"EOE"; -Members of ACL example (id: 2) are: - krb5 - krb5 $user2 -EOE -is ($acl->show, $expected, ' and show returns correctly'); -is ($acl->check ($user2), 1, ' and checking the good entry still works'); -is (scalar ($acl->check_errors), "malformed krb5 ACL\n", - ' but now with the right error'); -my @errors = $acl->check_errors; -is (scalar (@errors), 1, ' and the error return is right in list context'); -is ($errors[0], 'malformed krb5 ACL', ' with the same text'); -is ($acl->check (''), undef, 'Checking with an empty principal fails'); -is ($acl->error, 'no principal specified', ' with the right error'); -if ($acl->remove ('krb5', $user2, @trace)) { - ok (1, 'Removing the second user works'); -} else { - is ($acl->error, '', 'Removing the second user works'); -} -is ($acl->check ($user2), 0, ' and now the second user check fails'); -is (scalar ($acl->check_errors), "malformed krb5 ACL\n", - ' with the right error'); -if ($acl->remove ('krb5', '', @trace)) { - ok (1, 'Removing the bad entry works'); -} else { - is ($acl->error, '', 'Removing the bad entry works'); -} -@entries = $acl->list; -is (scalar (@entries), 0, ' and now there are no entries'); -is ($acl->show, "Members of ACL example (id: 2) are:\n", ' and show concurs'); -is ($acl->check ($user2), 0, ' and the second user check fails'); -is (scalar ($acl->check_errors), '', ' with no error message'); - -# Test history. -my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); -my $history = <<"EOO"; -$date create - by $admin from $host -$date add krb5 $user1 - by $admin from $host -$date add krb5 $user2 - by $admin from $host -$date remove krb5 $user1 - by $admin from $host -$date add krb5 - by $admin from $host -$date remove krb5 $user2 - by $admin from $host -$date remove krb5 - by $admin from $host -EOO -is ($acl->history, $history, 'History is correct'); - -# Test destroy. -if ($acl->destroy (@trace)) { - ok (1, 'Destroying the ACL works'); -} else { - is ($acl->error, '', 'Destroying the ACL works'); -} -$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, $schema) }; -ok (!defined ($acl), ' or by ID'); -is ($@, "ACL 2 not found\n", ' with the right error message'); -$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'); -like ($acl->id, qr{\A[23]\z}, ' and an ID of 2 or 3'); - -# Clean up. -$setup->destroy; -END { - unlink 'wallet-db'; -} diff --git a/perl/t/admin.t b/perl/t/admin.t deleted file mode 100755 index 41bc33a..0000000 --- a/perl/t/admin.t +++ /dev/null @@ -1,106 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for wallet administrative interface. -# -# Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2011, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 26; - -use Wallet::Admin; -use Wallet::Report; -use Wallet::Schema; -use Wallet::Server; -use DBI; - -use lib 't/lib'; -use Util; - -# We test database setup in init.t, so just do the basic setup here. -db_setup; -my $admin = eval { Wallet::Admin->new }; -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; -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'); - -# 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'); -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'); - -# Test registering a new ACL type. -is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), 1, - 'Registering Wallet::ACL::Base 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'); - -# Test re-initialization of the database. -$Wallet::Schema::VERSION = '0.07'; -is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, - ' and re-initialization succeeds'); - -# Test an upgrade. Reinitialize to an older version, then test upgrade to the -# current version. -SKIP: { - my @path = (split (':', $ENV{PATH})); - my ($sqlite) = grep { -x $_ } map { "$_/sqlite3" } @path; - skip 'sqlite3 not found', 5 unless $sqlite; - - # Delete all tables and then redump them straight from the SQL file to - # avoid getting the version table. - unlink 'wallet-db'; - my $status = system ('sqlite3', 'wallet-db', - '.read sql/Wallet-Schema-0.07-SQLite.sql'); - is ($status, 0, 'Reinstalling database from non-versioned SQL succeds'); - - # Upgrade to 0.08. - $Wallet::Schema::VERSION = '0.08'; - $admin = eval { Wallet::Admin->new }; - my $retval = $admin->upgrade; - is ($retval, 1, ' and performing an upgrade to 0.08 succeeds'); - my $sql = "select version from dbix_class_schema_versions order by" - . " version DESC"; - $version = $admin->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'); - - # Upgrade to 0.09. - $Wallet::Schema::VERSION = '0.09'; - $admin = eval { Wallet::Admin->new }; - $retval = $admin->upgrade; - is ($retval, 1, ' and performing an upgrade to 0.09 succeeds'); - $sql = "select version from dbix_class_schema_versions order by" - . " version DESC"; - $version = $admin->dbh->selectall_arrayref ($sql); - is ($version->[0][0], '0.09', ' and the schema version is correct'); -} - -# Clean up. -is ($admin->destroy, 1, 'Destruction succeeds'); -END { - unlink 'wallet-db'; -} diff --git a/perl/t/config.t b/perl/t/config.t deleted file mode 100755 index 881f2bd..0000000 --- a/perl/t/config.t +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the wallet server configuration. -# -# Written by Russ Allbery -# Copyright 2008, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 6; - -# Silence warnings since we're not using use. -package Wallet::Config; -our $DB_DRIVER; -our $KEYTAB_AFS_KASETKEY; -our $KEYTAB_FLAGS; -our $KEYTAB_KADMIN; -package main; - -# Load with a nonexistent file. -$ENV{WALLET_CONFIG} = '/path/to/nonexistent/file'; -eval { require Wallet::Config }; -is ($@, '', 'Loading Wallet::Config with nonexistent config file works'); -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::DB_DRIVER, undef, ' and DB_DRIVER is unset'); - -# Create a configuration file with a single setting. -open (CONFIG, '>', 'test-wallet.conf') - or die "$0: cannot create test-wallet.conf: $!\n"; -print CONFIG '$DB_DRIVER = "mysql";', "\n"; -print CONFIG "1;\n"; -close CONFIG; -$ENV{WALLET_CONFIG} = './test-wallet.conf'; - -# Reload the module and be sure it picks up that configuration file. -delete $INC{'Wallet/Config.pm'}; -eval { require Wallet::Config }; -is ($@, '', 'Loading Wallet::Config with new config file works'); -is ($Wallet::Config::DB_DRIVER, 'mysql', ' and now DB_DRIVER is set'); -unlink 'test-wallet.conf'; diff --git a/perl/t/docs/pod-spelling.t b/perl/t/docs/pod-spelling.t new file mode 100755 index 0000000..577a99e --- /dev/null +++ b/perl/t/docs/pod-spelling.t @@ -0,0 +1,74 @@ +#!/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 +# +# See LICENSE for licensing terms. + +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/docs/pod.t b/perl/t/docs/pod.t new file mode 100755 index 0000000..dfcf88e --- /dev/null +++ b/perl/t/docs/pod.t @@ -0,0 +1,15 @@ +#!/usr/bin/perl -w +# +# Test POD formatting for the wallet Perl modules. +# +# Written by Russ Allbery +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use strict; +use Test::More; +eval 'use Test::Pod 1.00'; +plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; +all_pod_files_ok (); diff --git a/perl/t/duo.t b/perl/t/duo.t deleted file mode 100755 index 4229afe..0000000 --- a/perl/t/duo.t +++ /dev/null @@ -1,157 +0,0 @@ -#!/usr/bin/perl -# -# Tests for the Duo integration object implementation. -# -# Written by Russ Allbery -# Copyright 2014 -# 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; - -BEGIN { - eval 'use Net::Duo'; - plan skip_all => 'Net::Duo required for testing duo' - if $@; - eval 'use Net::Duo::Mock::Agent'; - plan skip_all => 'Net::Duo::Mock::Agent required for testing duo' - if $@; -} - -BEGIN { - use_ok('Wallet::Admin'); - use_ok('Wallet::Config'); - use_ok('Wallet::Object::Duo'); -} - -use lib 't/lib'; -use Util; - -# Some global defaults to use. -my $user = 'admin@EXAMPLE.COM'; -my $host = 'localhost'; -my @trace = ($user, $host, time); -my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); - -# Flush all output immediately. -$| = 1; - -# Use Wallet::Admin to set up the database. -db_setup; -my $admin = eval { Wallet::Admin->new }; -is ($@, '', 'Database connection succeeded'); -is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $schema = $admin->schema; - -# Create a mock object to use for Duo calls. -my $mock = Net::Duo::Mock::Agent->new ({ key_file => 't/data/duo/keys.json' }); - -# Test error handling in the absence of configuration. -my $object = eval { - Wallet::Object::Duo->new ('duo', 'test', $schema); -}; -is ($object, undef, 'Wallet::Object::Duo new with no config failed'); -is ($@, "duo object implementation not configured\n", '...with correct error'); -$object = eval { - Wallet::Object::Duo->create ('duo', 'test', $schema, @trace); -}; -is ($object, undef, 'Wallet::Object::Duo creation with no config failed'); -is ($@, "duo object implementation not configured\n", '...with correct error'); - -# Set up the Duo configuration. -$Wallet::Config::DUO_AGENT = $mock; -$Wallet::Config::DUO_KEY_FILE = 't/data/duo/keys.json'; - -# Test creating an integration. -note ('Test creating an integration'); -my $expected = { - name => 'test', - notes => 'Managed by wallet', - type => 'unix', -}; -$mock->expect ( - { - method => 'POST', - uri => '/admin/v1/integrations', - content => $expected, - response_file => 't/data/duo/integration.json', - } -); -$object = Wallet::Object::Duo->create ('duo', 'test', $schema, @trace); -isa_ok ($object, 'Wallet::Object::Duo'); - -# Check the metadata about the new wallet object. -$expected = <<"EOO"; - Type: duo - Name: test - Duo key: DIRWIH0ZZPV4G88B37VQ - Created by: $user - Created from: $host - Created on: $date -EOO -is ($object->show, $expected, 'Show output is correct'); - -# Test retrieving the integration information. -note ('Test retrieving an integration'); -$mock->expect ( - { - method => 'GET', - uri => '/admin/v1/integrations/DIRWIH0ZZPV4G88B37VQ', - response_file => 't/data/duo/integration.json', - } -); -my $data = $object->get (@trace); -ok (defined ($data), 'Retrieval succeeds'); -$expected = <<'EOO'; -[duo] -ikey = DIRWIH0ZZPV4G88B37VQ -skey = QO4ZLqQVRIOZYkHfdPDORfcNf8LeXIbCWwHazY7o -host = example-admin.duosecurity.com -EOO -is ($data, $expected, '...and integration data is correct'); - -# Ensure that we can't retrieve the object when locked. -is ($object->flag_set ('locked', @trace), 1, - 'Setting object to locked succeeds'); -is ($object->get, undef, '...and now get fails'); -is ($object->error, 'cannot get duo:test: object is locked', - '...with correct error'); -is ($object->flag_clear ('locked', @trace), 1, - '...and clearing locked flag works'); - -# Create a new object by wallet type and name. -$object = Wallet::Object::Duo->new ('duo', 'test', $schema); - -# Test deleting an integration. We can't test this entirely properly because -# currently Net::Duo::Mock::Agent doesn't support stacking multiple expected -# calls and delete makes two calls. -note ('Test deleting an integration'); -$mock->expect ( - { - method => 'GET', - uri => '/admin/v1/integrations/DIRWIH0ZZPV4G88B37VQ', - response_file => 't/data/duo/integration.json', - } -); -TODO: { - local $TODO = 'Net::Duo::Mock::Agent not yet capable'; - - is ($object->destroy (@trace), 1, 'Duo object deletion succeeded'); - $object = eval { Wallet::Object::Duo->new ('duo', 'test', $schema) }; - is ($object, undef, '...and now object cannot be retrieved'); - is ($@, "cannot find duo:test\n", '...with correct error'); -} - -# Clean up. -$admin->destroy; -END { - unlink ('wallet-db'); -} - -# Done testing. -done_testing (); diff --git a/perl/t/file.t b/perl/t/file.t deleted file mode 100755 index 0aecd9d..0000000 --- a/perl/t/file.t +++ /dev/null @@ -1,150 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the file object implementation. -# -# Written by Russ Allbery -# Copyright 2008, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use POSIX qw(strftime); -use Test::More tests => 56; - -use Wallet::Admin; -use Wallet::Config; -use Wallet::Object::File; - -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-files') == 0 or die "cannot remove test-files\n"; -db_setup; -my $admin = eval { Wallet::Admin->new }; -is ($@, '', 'Database connection succeeded'); -is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $schema = $admin->schema; - -# Use this to accumulate the history traces so that we can check history. -my $history = ''; -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', $schema, @trace) - }; -ok (defined ($object), 'Creating a basic file object succeeds'); -ok ($object->isa ('Wallet::Object::File'), ' and is the right class'); -is ($object->get (@trace), undef, ' and get fails'); -is ($object->error, 'file support not configured', ' with the right error'); -is ($object->store (@trace), undef, ' and store fails'); -is ($object->error, 'file support not configured', ' with the right error'); -is ($object->destroy (@trace), 1, ' but destroy succeeds'); - -# Set up our configuration. -mkdir 'test-files' or die "cannot create test-files: $!\n"; -$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', $schema, @trace) - }; -ok (defined ($object), 'Creating a basic file object succeeds'); -ok ($object->isa ('Wallet::Object::File'), ' and is the right class'); -is ($object->get (@trace), undef, ' and get fails'); -is ($object->error, 'cannot get file:test: object has not been stored', - ' with the right error'); -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', $schema, @trace) - }; -ok (defined ($object), 'Recreating the object succeeds'); -is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); -ok (-d 'test-files/09', ' and the hash bucket was created'); -ok (-f 'test-files/09/test', ' and the file exists'); -is (contents ('test-files/09/test'), 'foo', ' with the right contents'); -is ($object->get (@trace), "foo\n", ' and get returns correctly'); -unlink 'test-files/09/test'; -is ($object->get (@trace), undef, ' and get fails if we delete it'); -is ($object->error, 'cannot get file:test: object has not been stored', - ' as if it had not been stored'); -is ($object->store ("bar\n\0baz\n", @trace), 1, ' but storing again works'); -ok (-f 'test-files/09/test', ' and the file exists'); -is (contents ('test-files/09/test'), 'bar', ' with the right contents'); -is ($object->get (@trace), "bar\n\0baz\n", ' and get returns correctly'); - -# Try exceeding the store size. -$Wallet::Config::FILE_MAX_SIZE = 1024; -is ($object->store ('x' x 1024, @trace), 1, - ' and storing exactly 1024 characters works'); -is ($object->get (@trace), 'x' x 1024, ' and get returns the right thing'); -is ($object->store ('x' x 1025, @trace), undef, - ' but storing 1025 characters fails'); -is ($object->error, 'data exceeds maximum of 1024 bytes', - ' with the right error'); - -# Try storing the empty data object. -is ($object->store ('', @trace), 1, 'Storing the empty object works'); -is ($object->get (@trace), '', ' and get returns the right thing'); - -# Test destruction. -is ($object->destroy (@trace), 1, 'Destroying the object works'); -ok (! -f 'test-files/09/test', ' and the file is gone'); - -# Now try some aggressive names. -$object = eval { - 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'); -ok (-d 'test-files/39', ' and the hash bucket was created'); -ok (-f 'test-files/39/%2E%2E%2Ffoo', ' and the file exists'); -is (contents ('test-files/39/%2E%2E%2Ffoo'), 'foo', - ' with the right contents'); -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", $schema, @trace) - }; -ok (defined ($object), 'Creating nul succeeds'); -is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); -ok (-d 'test-files/93', ' and the hash bucket was created'); -ok (-f 'test-files/93/%00', ' and the file exists'); -is (contents ('test-files/93/%00'), 'foo', - ' with the right contents'); -is ($object->get (@trace), "foo\n", ' and get returns correctly'); -is ($object->destroy (@trace), 1, 'Destroying the object works'); -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', $schema, @trace) - }; -ok (defined ($object), 'Recreating the object succeeds'); -is ($object->store ("foo\n", @trace), undef, - ' and storing data in it fails'); -like ($object->error, qr/^cannot create file bucket 09: /, - ' with the right error'); -is ($object->get (@trace), undef, ' and get fails'); -like ($object->error, qr/^cannot create file bucket 09: /, - ' with the right error'); -is ($object->destroy (@trace), 1, ' but destroying the object succeeds'); - -# Clean up. -$admin->destroy; -END { - unlink ('wallet-db'); -} diff --git a/perl/t/general/acl.t b/perl/t/general/acl.t new file mode 100755 index 0000000..e633f46 --- /dev/null +++ b/perl/t/general/acl.t @@ -0,0 +1,232 @@ +#!/usr/bin/perl -w +# +# Tests for the wallet ACL API. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 101; + +use Wallet::ACL; +use Wallet::Admin; +use Wallet::Server; + +use lib 't/lib'; +use Util; + +# Some global defaults to use. +my $admin = 'admin@EXAMPLE.COM'; +my $user1 = 'alice@EXAMPLE.COM'; +my $user2 = 'bob@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($admin, $host, time); + +# Use Wallet::Admin to set up the database. +db_setup; +my $setup = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($setup->reinitialize ($setup), 1, 'Database initialization succeeded'); +my $schema = $setup->schema; + +# Test create and new. +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, $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', $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', $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', $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, $schema) }; +ok (defined ($acl), 'Searching for the test ACL by ID'); +is ($@, '', ' with no exceptions'); +ok ($acl->isa ('Wallet::ACL'), ' and the right class'); +is ($acl->name, 'test', ' and the right name'); + +# Test rename. +if ($acl->rename ('example')) { + ok (1, 'Renaming the ACL'); +} else { + is ($acl->error, '', 'Renaming the ACL'); +} +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', $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', $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, $schema) }; +ok (defined ($acl), ' and it can still found by ID'); +is ($@, '', ' with no exceptions'); +is ($acl->name, 'example', ' and the right name'); +is ($acl->id, 2, ' and the right ID'); +ok (! $acl->rename ('ADMIN'), ' but renaming to an existing name fails'); +like ($acl->error, qr/^cannot rename ACL 2 to ADMIN: /, + ' with the right error'); + +# Test add, check, remove, list, and show. +my @entries = $acl->list; +is (scalar (@entries), 0, 'ACL starts empty'); +is ($acl->check ($user1), 0, ' so check fails'); +is (scalar ($acl->check_errors), '', ' with no errors'); +ok (! $acl->add ('example', 'foo', @trace), ' and cannot add bad scheme'); +is ($acl->error, 'unknown ACL scheme example', ' with the right error'); +if ($acl->add ('krb5', $user1, @trace)) { + ok (1, ' and can add a good scheme'); +} else { + is ($acl->error, '', ' and can add a good scheme'); +} +@entries = $acl->list; +is (scalar (@entries), 1, ' and now there is one element'); +is ($entries[0][0], 'krb5', ' with the right scheme'); +is ($entries[0][1], $user1, ' and identifier'); +is ($acl->check ($user1), 1, ' so check succeeds'); +is (scalar ($acl->check_errors), '', ' with no errors'); +is ($acl->check ($user2), 0, ' but the second user still fails'); +is (scalar ($acl->check_errors), '', ' with no errors'); +if ($acl->add ('krb5', $user2, @trace)) { + ok (1, ' and can add a second entry'); +} else { + is ($acl->error, '', ' and can add a second entry'); +} +is ($acl->check ($user2), 1, ' and now the second user checks'); +is (scalar ($acl->check_errors), '', ' with no errors'); +is ($acl->check ($user1), 1, ' and the first one still checks'); +is (scalar ($acl->check_errors), '', ' with no errors'); +@entries = sort { $a->[1] cmp $b->[1] } $acl->list; +is (scalar (@entries), 2, ' and now there are two entries'); +is ($entries[0][0], 'krb5', ' with the right scheme for 1'); +is ($entries[0][1], $user1, ' and the right identifier for 1'); +is ($entries[1][0], 'krb5', ' and the right scheme for 2'); +is ($entries[1][1], $user2, ' and the right identifier for 2'); +my $expected = <<"EOE"; +Members of ACL example (id: 2) are: + krb5 $user1 + krb5 $user2 +EOE +is ($acl->show, $expected, ' and show returns correctly'); +ok (! $acl->remove ('krb5', $admin, @trace), + 'Removing a nonexistent entry fails'); +is ($acl->error, "cannot remove krb5:$admin from 2: entry not found in ACL", + ' with the right error'); +if ($acl->remove ('krb5', $user1, @trace)) { + ok (1, ' but removing the first user works'); +} else { + is ($acl->error, '', ' but removing the first user works'); +} +is ($acl->check ($user1), 0, ' and now they do not check'); +is (scalar ($acl->check_errors), '', ' with no errors'); +@entries = $acl->list; +is (scalar (@entries), 1, ' and now there is one entry'); +is ($entries[0][0], 'krb5', ' with the right scheme'); +is ($entries[0][1], $user2, ' and the right identifier'); +ok (! $acl->add ('krb5', $user2), 'Adding the same entry again fails'); +like ($acl->error, qr/^cannot add \Qkrb5:$user2\E to 2: /, + ' with the right error'); +if ($acl->add ('krb5', '', @trace)) { + ok (1, 'Adding a bad entry works'); +} else { + is ($acl->error, '', 'Adding a bad entry works'); +} +@entries = sort { $a->[1] cmp $b->[1] } $acl->list; +is (scalar (@entries), 2, ' and now there are two entries'); +is ($entries[0][0], 'krb5', ' with the right scheme for 1'); +is ($entries[0][1], '', ' and the right identifier for 1'); +is ($entries[1][0], 'krb5', ' and the right scheme for 2'); +is ($entries[1][1], $user2, ' and the right identifier for 2'); +$expected = <<"EOE"; +Members of ACL example (id: 2) are: + krb5 + krb5 $user2 +EOE +is ($acl->show, $expected, ' and show returns correctly'); +is ($acl->check ($user2), 1, ' and checking the good entry still works'); +is (scalar ($acl->check_errors), "malformed krb5 ACL\n", + ' but now with the right error'); +my @errors = $acl->check_errors; +is (scalar (@errors), 1, ' and the error return is right in list context'); +is ($errors[0], 'malformed krb5 ACL', ' with the same text'); +is ($acl->check (''), undef, 'Checking with an empty principal fails'); +is ($acl->error, 'no principal specified', ' with the right error'); +if ($acl->remove ('krb5', $user2, @trace)) { + ok (1, 'Removing the second user works'); +} else { + is ($acl->error, '', 'Removing the second user works'); +} +is ($acl->check ($user2), 0, ' and now the second user check fails'); +is (scalar ($acl->check_errors), "malformed krb5 ACL\n", + ' with the right error'); +if ($acl->remove ('krb5', '', @trace)) { + ok (1, 'Removing the bad entry works'); +} else { + is ($acl->error, '', 'Removing the bad entry works'); +} +@entries = $acl->list; +is (scalar (@entries), 0, ' and now there are no entries'); +is ($acl->show, "Members of ACL example (id: 2) are:\n", ' and show concurs'); +is ($acl->check ($user2), 0, ' and the second user check fails'); +is (scalar ($acl->check_errors), '', ' with no error message'); + +# Test history. +my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); +my $history = <<"EOO"; +$date create + by $admin from $host +$date add krb5 $user1 + by $admin from $host +$date add krb5 $user2 + by $admin from $host +$date remove krb5 $user1 + by $admin from $host +$date add krb5 + by $admin from $host +$date remove krb5 $user2 + by $admin from $host +$date remove krb5 + by $admin from $host +EOO +is ($acl->history, $history, 'History is correct'); + +# Test destroy. +if ($acl->destroy (@trace)) { + ok (1, 'Destroying the ACL works'); +} else { + is ($acl->error, '', 'Destroying the ACL works'); +} +$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, $schema) }; +ok (!defined ($acl), ' or by ID'); +is ($@, "ACL 2 not found\n", ' with the right error message'); +$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'); +like ($acl->id, qr{\A[23]\z}, ' and an ID of 2 or 3'); + +# Clean up. +$setup->destroy; +END { + unlink 'wallet-db'; +} diff --git a/perl/t/general/admin.t b/perl/t/general/admin.t new file mode 100755 index 0000000..41bc33a --- /dev/null +++ b/perl/t/general/admin.t @@ -0,0 +1,106 @@ +#!/usr/bin/perl -w +# +# Tests for wallet administrative interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010, 2011, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 26; + +use Wallet::Admin; +use Wallet::Report; +use Wallet::Schema; +use Wallet::Server; +use DBI; + +use lib 't/lib'; +use Util; + +# We test database setup in init.t, so just do the basic setup here. +db_setup; +my $admin = eval { Wallet::Admin->new }; +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; +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'); + +# 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'); +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'); + +# Test registering a new ACL type. +is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), 1, + 'Registering Wallet::ACL::Base 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'); + +# Test re-initialization of the database. +$Wallet::Schema::VERSION = '0.07'; +is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, + ' and re-initialization succeeds'); + +# Test an upgrade. Reinitialize to an older version, then test upgrade to the +# current version. +SKIP: { + my @path = (split (':', $ENV{PATH})); + my ($sqlite) = grep { -x $_ } map { "$_/sqlite3" } @path; + skip 'sqlite3 not found', 5 unless $sqlite; + + # Delete all tables and then redump them straight from the SQL file to + # avoid getting the version table. + unlink 'wallet-db'; + my $status = system ('sqlite3', 'wallet-db', + '.read sql/Wallet-Schema-0.07-SQLite.sql'); + is ($status, 0, 'Reinstalling database from non-versioned SQL succeds'); + + # Upgrade to 0.08. + $Wallet::Schema::VERSION = '0.08'; + $admin = eval { Wallet::Admin->new }; + my $retval = $admin->upgrade; + is ($retval, 1, ' and performing an upgrade to 0.08 succeeds'); + my $sql = "select version from dbix_class_schema_versions order by" + . " version DESC"; + $version = $admin->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'); + + # Upgrade to 0.09. + $Wallet::Schema::VERSION = '0.09'; + $admin = eval { Wallet::Admin->new }; + $retval = $admin->upgrade; + is ($retval, 1, ' and performing an upgrade to 0.09 succeeds'); + $sql = "select version from dbix_class_schema_versions order by" + . " version DESC"; + $version = $admin->dbh->selectall_arrayref ($sql); + is ($version->[0][0], '0.09', ' and the schema version is correct'); +} + +# Clean up. +is ($admin->destroy, 1, 'Destruction succeeds'); +END { + unlink 'wallet-db'; +} diff --git a/perl/t/general/config.t b/perl/t/general/config.t new file mode 100755 index 0000000..881f2bd --- /dev/null +++ b/perl/t/general/config.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl -w +# +# Tests for the wallet server configuration. +# +# Written by Russ Allbery +# Copyright 2008, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 6; + +# Silence warnings since we're not using use. +package Wallet::Config; +our $DB_DRIVER; +our $KEYTAB_AFS_KASETKEY; +our $KEYTAB_FLAGS; +our $KEYTAB_KADMIN; +package main; + +# Load with a nonexistent file. +$ENV{WALLET_CONFIG} = '/path/to/nonexistent/file'; +eval { require Wallet::Config }; +is ($@, '', 'Loading Wallet::Config with nonexistent config file works'); +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::DB_DRIVER, undef, ' and DB_DRIVER is unset'); + +# Create a configuration file with a single setting. +open (CONFIG, '>', 'test-wallet.conf') + or die "$0: cannot create test-wallet.conf: $!\n"; +print CONFIG '$DB_DRIVER = "mysql";', "\n"; +print CONFIG "1;\n"; +close CONFIG; +$ENV{WALLET_CONFIG} = './test-wallet.conf'; + +# Reload the module and be sure it picks up that configuration file. +delete $INC{'Wallet/Config.pm'}; +eval { require Wallet::Config }; +is ($@, '', 'Loading Wallet::Config with new config file works'); +is ($Wallet::Config::DB_DRIVER, 'mysql', ' and now DB_DRIVER is set'); +unlink 'test-wallet.conf'; diff --git a/perl/t/general/init.t b/perl/t/general/init.t new file mode 100755 index 0000000..b8ec3c9 --- /dev/null +++ b/perl/t/general/init.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl -w +# +# Tests for database initialization. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 18; + +use Wallet::ACL; +use Wallet::Admin; + +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'); +ok ($admin->isa ('Wallet::Admin'), ' and returned the right class'); +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->schema) }; +is ($@, '', 'Retrieving ADMIN ACL successful'); +ok ($acl->isa ('Wallet::ACL'), ' and is the right class'); +my @entries = $acl->list; +is (scalar (@entries), 1, ' and has only one entry'); +isnt ($entries[0], undef, ' which is a valid entry'); +is ($entries[0][0], 'krb5', ' of krb5 scheme'); +is ($entries[0][1], 'admin@EXAMPLE.COM', ' with the right user'); + +# Test reinitialization. +is ($admin->reinitialize ('admin@EXAMPLE.ORG'), 1, + 'Reinitialization succeeded'); + +# Now repeat the database content checks. +$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; +is (scalar (@entries), 1, ' and has only one entry'); +isnt ($entries[0], undef, ' which is a valid entry'); +is ($entries[0][0], 'krb5', ' of krb5 scheme'); +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->schema) }; +like ($@, qr/^cannot search for ACL ADMIN: /, + ' and now the database is gone'); +END { + unlink 'wallet-db'; +} diff --git a/perl/t/general/report.t b/perl/t/general/report.t new file mode 100755 index 0000000..9563362 --- /dev/null +++ b/perl/t/general/report.t @@ -0,0 +1,330 @@ +#!/usr/bin/perl -w +# +# Tests for the wallet reporting interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 197; + +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'); + +# 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; +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'); + +# 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'); +@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 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'); +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'); + +# 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'); +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'); + +# 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'); + +# Set up a file bucket so that we can create an object we can retrieve. +system ('rm -rf test-files') == 0 or die "cannot remove test-files\n"; +mkdir 'test-files' or die "cannot create test-files: $!\n"; +$Wallet::Config::FILE_BUCKET = 'test-files'; + +# Create a file object and ensure that it shows up in the unused list. +is ($server->create ('file', 'test'), 1, 'Creating file:test succeeds'); +is ($server->owner ('file', 'test', 'ADMIN'), 1, + ' and setting its owner works'); +@objects = $report->objects ('unused'); +is (scalar (@objects), 4, 'There are now four unused objects'); +is ($objects[0][0], 'base', ' and the first has the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); +is ($objects[1][0], 'base', ' and the second has the right type'); +is ($objects[1][1], 'service/foo', ' and the right name'); +is ($objects[2][0], 'base', ' and the third has the right type'); +is ($objects[2][1], 'service/null', ' and the right name'); +is ($objects[3][0], 'file', ' and the fourth has the right type'); +is ($objects[3][1], 'test', ' and the right name'); + +# Store something and retrieve it, and then check that the file object fell +# off of the list. +is ($server->store ('file', 'test', 'Some data'), 1, + 'Storing data in file:test succeeds'); +is ($server->get ('file', 'test'), 'Some data', ' and retrieving it works'); +@objects = $report->objects ('unused'); +is (scalar (@objects), 3, ' and now there are three unused objects'); +is ($objects[0][0], 'base', ' and the first has the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); +is ($objects[1][0], 'base', ' and the second has the right type'); +is ($objects[1][1], 'service/foo', ' and the right name'); +is ($objects[2][0], 'base', ' and the third has the right type'); +is ($objects[2][1], 'service/null', ' and the right name'); + +# The third and fourth ACLs are both empty and should show up as duplicate. +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); +is (scalar (@{ $acls[0] }), 2, ' with two members'); +is ($acls[0][0], 'fourth', ' and the first member is correct'); +is ($acls[0][1], 'third', ' and the second member is correct'); + +# Add the same line to both ACLs. They should still show up as duplicate. +is ($server->acl_add ('fourth', 'base', 'bar'), 1, + 'Adding a line to the fourth ACL works'); +is ($server->acl_add ('third', 'base', 'bar'), 1, + ' and adding a line to the third ACL works'); +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); +is (scalar (@{ $acls[0] }), 2, ' with two members'); +is ($acls[0][0], 'fourth', ' and the first member is correct'); +is ($acls[0][1], 'third', ' and the second member is correct'); + +# Add another line to the third ACL. Now we match second. +is ($server->acl_add ('third', 'base', 'foo'), 1, + 'Adding another line to the third ACL works'); +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); +is (scalar (@{ $acls[0] }), 2, ' with two members'); +is ($acls[0][0], 'second', ' and the first member is correct'); +is ($acls[0][1], 'third', ' and the second member is correct'); + +# Add yet another line to the third ACL. Now all ACLs are distinct. +is ($server->acl_add ('third', 'base', 'baz'), 1, + 'Adding another line to the third ACL works'); +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 0, 'There are no duplicate ACLs'); +is ($report->error, undef, ' and no error'); + +# Clean up. +$admin->destroy; +system ('rm -r test-files') == 0 or die "cannot remove test-files\n"; +END { + unlink 'wallet-db'; +} diff --git a/perl/t/general/server.t b/perl/t/general/server.t new file mode 100755 index 0000000..9026439 --- /dev/null +++ b/perl/t/general/server.t @@ -0,0 +1,1040 @@ +#!/usr/bin/perl -w +# +# Tests for the wallet server API. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2010, 2011, 2012, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 382; + +use POSIX qw(strftime); +use Wallet::Admin; +use Wallet::Config; +use Wallet::Schema; +use Wallet::Server; + +use lib 't/lib'; +use Util; + +# Some global defaults to use. +my $admin = 'admin@EXAMPLE.COM'; +my $user1 = 'alice@EXAMPLE.COM'; +my $user2 = 'bob@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($admin, $host); + +# Use Wallet::Admin to set up the database. +db_setup; +my $setup = eval { Wallet::Admin->new }; +is ($@, '', 'Database initialization did not die'); +is ($setup->reinitialize ($admin), 1, 'Database initialization succeeded'); + +# Now test the new method. +$server = eval { Wallet::Server->new (@trace) }; +is ($@, '', 'Reopening with new did not die'); +ok ($server->isa ('Wallet::Server'), ' and returned the right class'); +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'); + +# We're currently running as the administrator, so everything should succeed. +# Set up a bunch of data for us to test with, starting with some ACLs. Test +# the error handling while we're at it. +is ($server->acl_show ('ADMIN'), + "Members of ACL ADMIN (id: 1) are:\n krb5 $admin\n", + 'Showing the ADMIN ACL works'); +is ($server->acl_show (1), + "Members of ACL ADMIN (id: 1) are:\n krb5 $admin\n", + ' including by number'); +my $history = <<"EOO"; +DATE create + by $admin from $host +DATE add krb5 $admin + by $admin from $host +EOO +my $result = $server->acl_history ('ADMIN'); +$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($result, $history, ' and displaying history works'); +$result = $server->acl_history (1); +$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +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'); +like ($server->error, qr/^cannot create ACL user1: /, + ' and returns a good error'); +is ($server->acl_create ('ADMIN'), undef, ' and cannot create ADMIN'); +like ($server->error, qr/^cannot create ACL ADMIN: /, + ' and returns a good error'); +is ($server->acl_create ('user2'), 1, 'Create another ACL'); +is ($server->acl_create ('both'), 1, ' and one for both users'); +is ($server->acl_create ('test2'), 1, ' and an empty one'); +is ($server->acl_create ('test'), 1, ' and another test one'); +is ($server->acl_rename ('empty', 'test'), undef, + 'Cannot rename nonexistent ACL'); +is ($server->error, 'ACL empty not found', ' and returns the right error'); +is ($server->acl_rename ('test', 'test2'), undef, + ' and cannot rename to an existing name'); +like ($server->error, qr/^cannot rename ACL 6 to test2: /, + ' and returns the right error'); +is ($server->acl_rename ('test', 'empty'), 1, 'Renaming does work'); +is ($server->acl_rename ('test', 'empty'), undef, ' but not twice'); +is ($server->error, 'ACL test not found', ' and returns the right error'); +is ($server->acl_show ('test'), undef, ' and show fails'); +is ($server->error, 'ACL test not found', ' and returns the right error'); +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_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'); +is ($server->error, 'unknown ACL scheme krb4', ' with the right error'); +is ($server->acl_add ('user1', 'krb5', $user1), 1, + ' but works with the right scheme'); +is ($server->acl_add ('user2', 'krb5', $user2), 1, 'Add another entry'); +is ($server->acl_add ('both', 'krb5', $user1), 1, ' and another'); +is ($server->acl_add ('both', 'krb5', $user2), 1, + ' and another to the same ACL'); +is ($server->acl_show ('both'), + "Members of ACL both (id: 4) are:\n krb5 $user1\n krb5 $user2\n", + ' and show returns the correct result'); +$history = <<"EOO"; +DATE create + by $admin from $host +DATE add krb5 $user1 + by $admin from $host +DATE add krb5 $user2 + by $admin from $host +EOO +$result = $server->acl_history ('both'); +$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($result, $history, ' as does history'); +is ($server->acl_add ('empty', 'krb5', $user1), 1, ' and another to empty'); +is ($server->acl_add ('test', 'krb5', $user1), undef, + ' but adding to an unknown ACL fails'); +is ($server->error, 'ACL test not found', ' and returns the right error'); +is ($server->acl_remove ('test', 'krb5', $user1), undef, + 'Removing from a nonexistent ACL fails'); +is ($server->error, 'ACL test not found', ' and returns the right error'); +is ($server->acl_remove ('empty', 'krb5', $user2), undef, + ' and removing an entry not there fails'); +is ($server->error, + "cannot remove krb5:$user2 from 6: entry not found in ACL", + ' and returns the right error'); +is ($server->acl_show ('empty'), + "Members of ACL empty (id: 6) are:\n krb5 $user1\n", + ' and show returns the correct status'); +is ($server->acl_remove ('empty', 'krb5', $user1), 1, + ' but removing a good one works'); +is ($server->acl_remove ('empty', 'krb5', $user1), undef, + ' but does not work twice'); +is ($server->error, + "cannot remove krb5:$user1 from 6: entry not found in ACL", + ' and returns the right error'); +is ($server->acl_show ('empty'), "Members of ACL empty (id: 6) are:\n", + ' and show returns the correct status'); + +# Make sure we can't cripple the ADMIN ACL. +is ($server->acl_destroy ('ADMIN'), undef, 'Cannot destroy the ADMIN ACL'); +is ($server->error, 'cannot destroy the ADMIN ACL', ' with the right error'); +is ($server->acl_rename ('ADMIN', 'foo'), undef, ' or rename it'); +is ($server->error, 'cannot rename the ADMIN ACL', ' with the right error'); +is ($server->acl_remove ('ADMIN', 'krb5', $admin), undef, + ' or remove its last entry'); +is ($server->error, 'cannot remove last ADMIN ACL entry', + ' with the right error'); +is ($server->acl_add ('ADMIN', 'krb5', $user1), 1, + ' but we can add another entry'); +is ($server->acl_remove ('ADMIN', 'krb5', $user1), 1, ' and then remove it'); +is ($server->acl_remove ('ADMIN', 'krb5', $user1), undef, + ' and remove a user not on it'); +is ($server->error, + "cannot remove krb5:$user1 from 1: entry not found in ACL", + ' and get the right error'); + +# Now, create a few objects to use for testing and test the object API while +# we're at it. +is ($server->create ('base', 'service/admin'), 1, + 'Creating an object works'); +is ($server->create ('base', 'service/admin'), undef, ' but not twice'); +like ($server->error, qr{^cannot create object base:service/admin: }, + ' and returns the right error'); +is ($server->check ('base', 'service/admin'), 1, ' and check works'); +is ($server->create ('srvtab', 'service.admin'), undef, + 'Creating an unknown object fails'); +is ($server->error, 'unknown object type srvtab', ' with the right error'); +is ($server->check ('srvtab', 'service.admin'), undef, ' and check fails'); +is ($server->error, 'unknown object type srvtab', ' with the right error'); +is ($server->create ('', 'service.admin'), undef, + ' and likewise with an empty type'); +is ($server->error, 'unknown object type ', ' with the right error'); +is ($server->create ('base', 'service/user1'), 1, + ' but we can create a base object'); +is ($server->create ('base', 'service/user2'), 1, ' and another'); +is ($server->create ('base', 'service/both'), 1, ' and another'); +is ($server->create ('base', 'service/test'), 1, ' and another'); +is ($server->create ('base', ''), undef, ' but not with an empty name'); +is ($server->error, 'invalid object name', ' with the right error'); +is ($server->destroy ('base', 'service/none'), undef, + 'Destroying an unknown object fails'); +is ($server->error, 'cannot find base:service/none', ' with the right error'); +is ($server->destroy ('srvtab', 'service/test'), undef, + ' and destroying an unknown type fails'); +is ($server->error, 'unknown object type srvtab', ' with a different error'); +is ($server->destroy ('base', 'service/test'), 1, + ' but destroying a good object works'); +is ($server->check ('base', 'service/test'), 0, + ' and now check says it is not there'); +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, + 'Retrieving expires on an unknown object fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->expires ('base', 'service/test', $now), undef, + ' and setting it also fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->expires ('base', 'service/admin'), undef, + 'Retrieving expires for the right object returns undef'); +is ($server->error, undef, ' but there is no error'); +is ($server->expires ('base', 'service/admin', $now), 1, + ' and we can set it'); +is ($server->expires ('base', 'service/admin'), $now, + ' and get the value back'); +is ($server->expires ('base', 'service/admin', ''), 1, ' and clear it'); +is ($server->expires ('base', 'service/admin'), undef, ' and now it is gone'); +is ($server->error, undef, ' and still no error'); + +# Test attributes. +is ($server->attr ('base', 'service/admin', 'foo'), undef, + 'Getting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but called the method'); +is ($server->attr ('base', 'service/admin', 'foo', 'foo'), undef, + ' and setting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' and called the method'); + +# Because we're admin, we should be able to show one of these objects, but we +# still shouldn't be able to get or store since there are no ACLs. +is ($server->show ('base', 'service/test'), undef, + 'Cannot show nonexistent object'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +my $show = $server->show ('base', 'service/admin'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/; +my $expected = <<"EOO"; + Type: base + Name: service/admin + Created by: $admin + Created from: $host + Created on: 0 +EOO +is ($show, $expected, ' but showing an existing object works'); +is ($server->get ('base', 'service/admin'), undef, 'Getting an object fails'); +is ($server->error, "$admin not authorized to get base:service/admin", + ' with the right error'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and storing the object also fails'); +is ($server->error, "$admin not authorized to store base:service/admin", + ' with the right error'); + +# Grant only the get ACL, which should give us partial permissions. +is ($server->acl ('base', 'service/test', 'get', 'ADMIN'), undef, + 'Setting ACL on unknown object fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->acl ('base', 'service/admin', 'foo', 'ADMIN'), undef, + ' as does setting an unknown ACL'); +is ($server->error, 'invalid ACL type foo', ' with the right error'); +is ($server->acl ('base', 'service/admin', 'get', 'test2'), undef, + ' as does setting it to an unknown ACL'); +is ($server->error, 'ACL test2 not found', ' with the right error'); +is ($server->acl ('base', 'service/admin', 'get', 'ADMIN'), 1, + ' but setting the right ACL works'); +$result = eval { $server->get ('base', 'service/admin') }; +is ($result, undef, 'Get still fails'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' but the method is called'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and storing the object still fails'); +is ($server->error, "$admin not authorized to store base:service/admin", + ' with the right error'); +is ($server->acl ('base', 'service/admin', 'get', ''), 1, + 'Clearing the ACL works'); +is ($server->get ('base', 'service/admin'), undef, ' and now get fails'); +is ($server->error, "$admin not authorized to get base:service/admin", + ' with the right error'); +is ($server->acl ('base', 'service/admin', 'store', 'ADMIN'), 1, + 'Setting the store ACL works'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and now store fails'); +is ($server->error, + "cannot store base:service/admin: object type is immutable", + ' with a different error message'); +is ($server->get ('base', 'service/admin'), undef, ' and get still fails'); +is ($server->error, "$admin not authorized to get base:service/admin", + ' with the right error'); +is ($server->acl ('base', 'service/admin', 'store', ''), 1, + 'Clearing the ACL works'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and storing the object now fails'); +is ($server->error, "$admin not authorized to store base:service/admin", + ' with the right error'); + +# Test manipulating the owner. +is ($server->owner ('base', 'service/test'), undef, + 'Owner of nonexistent object fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->owner ('base', 'service/test', 'ADMIN'), undef, + ' as does setting it'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->owner ('base', 'service/admin'), undef, + 'Owner of existing object is also undef'); +is ($server->error, undef, ' but there is no error'); +is ($server->owner ('base', 'service/admin', 'test2'), undef, + 'Setting it to an unknown ACL fails'); +is ($server->error, 'ACL test2 not found', ' with the right error'); +is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, + 'Setting it to ADMIN works'); +$result = eval { $server->get ('base', 'service/admin') }; +is ($result, undef, ' and get still fails'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' but the method is called'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and now store fails'); +is ($server->error, + "cannot store base:service/admin: object type is immutable", + ' with a different error message'); +is ($server->acl ('base', 'service/admin', 'get', 'empty'), 1, + 'Setting the get ACL succeeds'); +is ($server->get ('base', 'service/admin'), undef, ' and get now fails'); +is ($server->error, "$admin not authorized to get base:service/admin", + ' with the right error'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' but store fails'); +is ($server->error, + "cannot store base:service/admin: object type is immutable", + ' with the same error message'); +is ($server->acl ('base', 'service/admin', 'store', 'empty'), 1, + ' until we do the same thing with store'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and now store fails'); +is ($server->error, "$admin not authorized to store base:service/admin", + ' due to permissions'); +is ($server->acl ('base', 'service/admin', 'store', ''), 1, + 'Clearing the store ACL works'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and fixes that'); +is ($server->error, + "cannot store base:service/admin: object type is immutable", + ' since we are back to immutable'); +is ($server->owner ('base', 'service/admin', ''), 1, + ' but clearing the owner works'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and now store fails'); +is ($server->error, "$admin not authorized to store base:service/admin", + ' due to permissions again'); +is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, + ' and setting the owner again works'); + +# Test manipulating flags. +is ($server->flag_clear ('base', 'service/admin', 'locked'), undef, + 'Clearing an unset flag fails'); +is ($server->error, + "cannot clear flag locked on base:service/admin: flag not set", + ' with the right error'); +if ($server->flag_set ('base', 'service/admin', 'locked')) { + ok (1, ' but setting it works'); +} else { + is ($server->error, '', ' but setting it works'); +} +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' now store fails'); +is ($server->error, 'cannot store base:service/admin: object is locked', + ' because the object is locked'); +is ($server->expires ('base', 'service/admin', ''), undef, + ' and expires fails'); +is ($server->error, 'cannot modify base:service/admin: object is locked', + ' because the object is locked'); +is ($server->owner ('base', 'service/admin', ''), undef, ' and owner fails'); +is ($server->error, 'cannot modify base:service/admin: object is locked', + ' because the object is locked'); +for my $acl (qw/get store show destroy flags/) { + is ($server->acl ('base', 'service/admin', $acl, ''), undef, + " and setting $acl ACL fails"); + is ($server->error, 'cannot modify base:service/admin: object is locked', + ' for the same reason'); +} +is ($server->flag_clear ('base', 'service/admin', 'locked'), 1, + ' and then clearing it works'); +is ($server->owner ('base', 'service/admin', ''), 1, + ' and then clearing owner works'); +is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, + ' and setting unchanging works'); +is ($server->flag_clear ('base', 'service/admin', 'locked'), undef, + ' and clearing locked still does not'); +is ($server->error, + "cannot clear flag locked on base:service/admin: flag not set", + ' with the right error'); +is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, + ' and clearing unchanging works'); + +# Test history. +$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) + by $admin from $host +DATE set acl_get to ADMIN (1) + by $admin from $host +DATE unset acl_get (was ADMIN (1)) + by $admin from $host +DATE set acl_store to ADMIN (1) + by $admin from $host +DATE unset acl_store (was ADMIN (1)) + by $admin from $host +DATE set owner to ADMIN (1) + by $admin from $host +DATE set acl_get to empty (6) + by $admin from $host +DATE set acl_store to empty (6) + by $admin from $host +DATE unset acl_store (was empty (6)) + by $admin from $host +DATE unset owner (was ADMIN (1)) + by $admin from $host +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 ADMIN (1)) + by $admin from $host +DATE set flag unchanging + by $admin from $host +DATE clear flag unchanging + by $admin from $host +EOO +my $seen = $server->history ('base', 'service/admin'); +$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($seen, $history, 'History for service/admin is correct'); + +# Now let's set up some additional ACLs for future tests. +is ($server->owner ('base', 'service/user1', 'user1'), 1, 'Set user1 owner'); +is ($server->owner ('base', 'service/user2', 'user2'), 1, 'Set user2 owner'); +is ($server->owner ('base', 'service/both', 'both'), 1, 'Set both owner'); +is ($server->acl ('base', 'service/both', 'show', 'user1'), 1, ' and show'); +is ($server->acl ('base', 'service/both', 'destroy', 'user2'), 1, + ' and destroy'); +is ($server->acl ('base', 'service/both', 'flags', 'user1'), 1, ' and flags'); +is ($server->acl ('base', 'service/admin', 'store', 'user1'), 1, + 'Set admin store'); + +# Okay, now we can switch users and be sure we don't have admin rights. +$server = eval { Wallet::Server->new ($user1, $host) }; +is ($@, '', 'Switching users works'); +is ($server->acl_create ('new'), undef, ' and now we cannot create ACLs'); +is ($server->error, "$user1 not authorized to create ACL", ' with error'); +is ($server->acl_rename ('user1', 'alice'), undef, ' or rename ACLs'); +is ($server->error, "$user1 not authorized to rename ACL user1", + ' with error'); +is ($server->acl_show ('user1'), undef, ' or show ACLs'); +is ($server->error, "$user1 not authorized to show ACL user1", ' with error'); +is ($server->acl_history ('user1'), undef, ' or see history for ACLs'); +is ($server->error, "$user1 not authorized to see history of ACL user1", + ' with error'); +is ($server->acl_destroy ('user2'), undef, ' or destroy ACLs'); +is ($server->error, "$user1 not authorized to destroy ACL user2", + ' with error'); +is ($server->acl_add ('user1', 'krb5', $user2), undef, ' or add to ACLs'); +is ($server->error, "$user1 not authorized to add to ACL user1", + ' with error'); +is ($server->acl_remove ('user1', 'krb5', $user1), undef, + ' or remove from ACLs'); +is ($server->error, "$user1 not authorized to remove from ACL user1", + ' with error'); +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->owner ('base', 'service/user1', 'user2'), undef, + ' or set the owner'); +is ($server->error, + "$user1 not authorized to set owner for base:service/user1", + ' with error'); +is ($server->expires ('base', 'service/user1', $now), undef, + ' or set expires'); +is ($server->error, + "$user1 not authorized to set expires for base:service/user1", + ' with error'); +is ($server->acl ('base', 'service/user1', 'get', 'user1'), undef, + ' or set an ACL'); +is ($server->error, + "$user1 not authorized to set ACL for base:service/user1", + ' with error'); +is ($server->flag_set ('base', 'service/user1', 'unchanging'), undef, + ' or set flags'); +is ($server->error, + "$user1 not authorized to set flags for base:service/user1", + ' with error'); +is ($server->flag_clear ('base', 'service/user1', 'unchanging'), undef, + ' or clear flags'); +is ($server->error, + "$user1 not authorized to set flags for base:service/user1", + ' with error'); + +# However, we can perform object actions on things we own. +$result = eval { $server->get ('base', 'service/user1') }; +is ($result, undef, 'We can get an object we own'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' and the method is called'); +is ($server->store ('base', 'service/user1', 'stuff'), undef, + ' or store an object we own'); +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 + +Members of ACL user1 (id: 2) are: + krb5 $user1 +EOO +is ($show, $expected, ' and show an object we own'); +$history = <<"EOO"; +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; +is ($seen, $history, ' and see history for an object we own'); +is ($server->attr ('base', 'service/user1', 'foo'), undef, + ' and getting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but calls the method'); +is ($server->attr ('base', 'service/user1', 'foo', 'foo'), undef, + ' and setting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but calls the method'); + +# But not on things we don't own. +is ($server->get ('base', 'service/user2'), undef, + 'But we cannot get an object we do not own'); +is ($server->error, "$user1 not authorized to get base:service/user2", + ' with the right error'); +is ($server->store ('base', 'service/user2', 'stuff'), undef, + ' or store it'); +is ($server->error, "$user1 not authorized to store base:service/user2", + ' with the right error'); +is ($server->show ('base', 'service/user2'), undef, ' or show it'); +is ($server->error, "$user1 not authorized to show base:service/user2", + ' with the right error'); +is ($server->history ('base', 'service/user2'), undef, + ' or see history for it'); +is ($server->error, "$user1 not authorized to show base:service/user2", + ' with the right error'); +is ($server->attr ('base', 'service/user2', 'foo'), undef, + ' or get attributes'); +is ($server->error, + "$user1 not authorized to get attributes for base:service/user2", + ' with the right error'); +is ($server->attr ('base', 'service/user2', 'foo', ''), undef, + ' and set attributes'); +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') }; +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->store ('base', 'service/both', 'stuff'), undef, + ' or store an object we jointly own'); +is ($server->error, + "cannot store base:service/both: object type is immutable", + ' and the method is called'); +is ($server->flag_set ('base', 'service/both', 'unchanging'), 1, + ' and set flags on an object we have an ACL'); +is ($server->flag_set ('base', 'service/both', 'locked'), 1, ' both flags'); +$show = $server->show ('base', 'service/both'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; +$expected = <<"EOO"; + Type: base + Name: service/both + Owner: both + Show ACL: user1 + Destroy ACL: user2 + Flags ACL: user1 + Flags: locked unchanging + Created by: $admin + Created from: $host + Created on: 0 + +Members of ACL both (id: 4) are: + krb5 $user1 + krb5 $user2 + +Members of ACL user1 (id: 2) are: + krb5 $user1 + +Members of ACL user2 (id: 3) are: + krb5 $user2 +EOO +is ($show, $expected, ' and show an object we jointly own'); +$history = <<"EOO"; +DATE create + by $admin from $host +DATE set owner to both (4) + by $admin from $host +DATE set acl_show to user1 (2) + by $admin from $host +DATE set acl_destroy to user2 (3) + by $admin from $host +DATE set acl_flags to user1 (2) + by $admin from $host +DATE set flag unchanging + by $user1 from $host +DATE set flag locked + by $user1 from $host +EOO +$seen = $server->history ('base', 'service/both'); +$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($seen, $history, ' and see history for an object we jointly own'); +is ($server->store ('base', 'service/both', 'stuff'), undef, + ' but not store data'); +is ($server->error, 'cannot store base:service/both: object is locked', + ' when the object is locked'); +is ($server->flag_clear ('base', 'service/both', 'locked'), 1, + ' and clear flags'); +is ($server->destroy ('base', 'service/both'), undef, + ' but not destroy it'); +is ($server->error, "$user1 not authorized to destroy base:service/both", + ' due to permissions'); +is ($server->attr ('base', 'service/both', 'foo'), undef, + 'Getting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but calls the method'); +is ($server->attr ('base', 'service/both', 'foo', ''), undef, + ' and setting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but calls the method'); +is ($server->attr ('base', 'service/admin', 'foo', ''), undef, + ' but setting an attribute on service/admin fails'); +is ($server->error, 'unknown attribute foo', ' and calls the method'); +is ($server->attr ('base', 'service/admin', 'foo'), undef, + ' while getting an attribute on service/admin fails'); +is ($server->error, + "$user1 not authorized to get attributes for base:service/admin", + ' with a permission error'); + +# Now switch to the other user and make sure we can do things on objects we +# own. +$server = eval { Wallet::Server->new ($user2, $host) }; +is ($@, '', 'Switching users works'); +$result = eval { $server->get ('base', 'service/user2') }; +is ($result, undef, 'We can get an object we own'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' and the method is called'); +is ($server->store ('base', 'service/user2', 'stuff'), undef, + ' or store an object we own'); +is ($server->error, + "cannot store base:service/user2: object type is immutable", + ' and the method is called'); +$show = $server->show ('base', 'service/user2'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; +$expected = <<"EOO"; + Type: base + Name: service/user2 + Owner: user2 + Created by: $admin + Created from: $host + Created on: 0 + +Members of ACL user2 (id: 3) are: + krb5 $user2 +EOO +is ($show, $expected, ' and show an object we own'); +$history = <<"EOO"; +DATE create + by $admin from $host +DATE set owner to user2 (3) + by $admin from $host +EOO +$seen = $server->history ('base', 'service/user2'); +$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($seen, $history, ' and see history for an object we own'); + +# But not on things we don't own. +is ($server->get ('base', 'service/user1'), undef, + 'But we cannot get an object we do not own'); +is ($server->error, "$user2 not authorized to get base:service/user1", + ' with the right error'); +is ($server->store ('base', 'service/user1', 'stuff'), undef, + ' or store it'); +is ($server->error, "$user2 not authorized to store base:service/user1", + ' with the right error'); +is ($server->show ('base', 'service/user1'), undef, ' or show it'); +is ($server->error, "$user2 not authorized to show base:service/user1", + ' with the right error'); +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'); + +# 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", + ' and the method is called'); +is ($server->store ('base', 'service/both', 'stuff'), undef, + ' or store an object we jointly own'); +is ($server->error, + "cannot store base:service/both: object type is immutable", + ' and the method is called'); +is ($server->show ('base', 'service/both'), undef, ' but we cannot show it'); +is ($server->error, "$user2 not authorized to show base:service/both", + ' with the right error'); +is ($server->history ('base', 'service/both'), undef, + ' or see history for it'); +is ($server->error, "$user2 not authorized to show base:service/both", + ' with the right error'); +is ($server->flag_set ('base', 'service/both', 'locked'), undef, + ' or set flags on it'); +is ($server->error, + "$user2 not authorized to set flags for base:service/both", + ' with the right error'); +is ($server->flag_clear ('base', 'service/both', 'unchanging'), undef, + ' or clear flags on it'); +is ($server->error, + "$user2 not authorized to set flags for base:service/both", + ' with the right error'); +is ($server->attr ('base', 'service/both', 'foo'), undef, + ' or getting an attribute'); +is ($server->error, + "$user2 not authorized to get attributes for base:service/both", + ' with the right error'); +is ($server->attr ('base', 'service/both', 'foo', 'foo'), undef, + ' but setting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but calls the method'); +is ($server->destroy ('base', 'service/both'), 1, ' and we can destroy it'); +is ($server->get ('base', 'service/both'), undef, ' and now cannot get it'); +is ($server->error, 'cannot find base:service/both', ' because it is gone'); +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 +# a default owner of default (the same as the both ACL), $user1 to create +# service/default-both with a default owner of both (but a different +# definition than the existing ACL), and $user2 to create service/default-2 +# with a default owner of user2 (with the same definition as the existing +# ACL). +# +# Also add service/default-get and service/default-store to test auto-creation +# on get and store, and service/default-admin to test auto-creation when one +# is an admin. +package Wallet::Config; +sub default_owner { + my ($type, $name) = @_; + if ($type eq 'base' and $name eq 'service/default') { + return ('default', [ 'krb5', $user1 ], [ 'krb5', $user2 ]); + } elsif ($type eq 'base' and $name eq 'service/default-both') { + return ('both', [ 'krb5', $user1 ]); + } elsif ($type eq 'base' and $name eq 'service/default-2') { + return ('user2', [ 'krb5', $user2 ]); + } elsif ($type eq 'base' and $name eq 'service/default-get') { + return ('user2', [ 'krb5', $user2 ]); + } elsif ($type eq 'base' and $name eq 'service/default-store') { + return ('user2', [ 'krb5', $user2 ]); + } elsif ($type eq 'base' and $name eq 'service/default-admin') { + return ('auto-admin', [ 'krb5', $admin ]); + } elsif ($type eq 'base' and $name eq 'host/default') { + return ('auto-host', [ 'krb5', $admin ]); + } else { + return; + } +} +package main; + +# 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", + ' due to lack of authorization'); +is ($server->autocreate ('base', 'service/default'), 1, + ' but autocreation succeeds'); +is ($server->autocreate ('base', 'service/foo'), undef, + ' but not any object'); +is ($server->error, "$user2 not authorized to create base:service/foo", + ' with the right error'); +$show = $server->show ('base', 'service/default'); +if (defined $show) { + $show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; + $expected = <<"EOO"; + Type: base + Name: service/default + Owner: default + Created by: $user2 + Created from: $host + Created on: 0 + +Members of ACL default (id: 7) are: + krb5 $user1 + krb5 $user2 +EOO + is ($show, $expected, ' and the created object and ACL are correct'); +} else { + is ($server->error, undef, ' and the created object and ACL are correct'); +} + +# Try the other basic cases in default_owner. +is ($server->autocreate ('base', 'service/default-both'), undef, + 'Creating an object with an ACL mismatch fails'); +is ($server->error, "ACL both exists and doesn't match default", + ' with the right error'); +is ($server->autocreate ('base', 'service/default-2'), 1, + 'Creating an object with an existing ACL works'); +$show = $server->show ('base', 'service/default-2'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; +$expected = <<"EOO"; + Type: base + Name: service/default-2 + Owner: user2 + Created by: $user2 + Created from: $host + Created on: 0 + +Members of ACL user2 (id: 3) are: + krb5 $user2 +EOO +is ($show, $expected, ' and the created object and ACL are correct'); + +# Auto-creation does not work on get or store; this is done by the client. +$result = eval { $server->get ('base', 'service/default-get') }; +is ($result, undef, 'Auto-creation on get fails'); +is ($@, '', ' does not die'); +is ($server->error, 'cannot find base:service/default-get', + ' and fails with the right error'); +is ($server->store ('base', 'service/default-store', 'stuff'), undef, + 'Auto-creation on store fails'); +is ($server->error, 'cannot find base:service/default-store', + ' with the right error'); + +# Switch back to admin to test auto-creation. +$server = eval { Wallet::Server->new ($admin, $host) }; +is ($@, '', 'Switching users back to admin works'); +is ($server->autocreate ('base', 'service/default-admin'), 1, + 'Autocreation works for admin'); +$show = $server->show ('base', 'service/default-admin'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; +$expected = <<"EOO"; + Type: base + Name: service/default-admin + Owner: auto-admin + Created by: $admin + Created from: $host + Created on: 0 + +Members of ACL auto-admin (id: 8) are: + krb5 $admin +EOO +is ($show, $expected, ' and the created object and ACL are correct'); +is ($server->destroy ('base', 'service/default-admin'), 1, + ' and we can destroy it'); + +# Test naming enforcement. Permit any base service/* name, but only permit +# base host/* if the host is fully qualified and ends in .example.edu. +package Wallet::Config; +sub verify_name { + my ($type, $name) = @_; + if ($type eq 'base' and $name =~ m,^service/,) { + return; + } elsif ($type eq 'base' and $name =~ m,^host/(.*),) { + my $host = $1; + return "host $host must be fully qualified (add .example.edu)" + unless $host =~ /\./; + return "host $host not in .example.edu domain" + unless $host =~ /\.example\.edu$/; + return; + } else { + return; + } +} +package main; + +# Recreate service/default-admin, which should succeed, and then try the +# various host/* principals. +is ($server->create ('base', 'service/default-admin'), 1, + 'Creating default/admin succeeds'); +if ($server->create ('base', 'host/default.example.edu')) { + ok (1, ' as does creating host/default.example.edu'); +} else { + is ($server->error, '', ' as does creating host/default.example.edu'); +} +is ($server->destroy ('base', 'service/default-admin'), 1, + ' and destroying default-admin works'); +is ($server->destroy ('base', 'host/default.example.edu'), 1, + ' and destroying host/default.example.edu works'); +is ($server->create ('base', 'host/default'), undef, + ' but an unqualified host fails'); +is ($server->error, 'base:host/default rejected: host default must be fully' + . ' qualified (add .example.edu)', ' with the right error'); +is ($server->create ('base', 'host/default.stanford.edu'), undef, + ' and a host in the wrong domain fails'); +is ($server->error, 'base:host/default.stanford.edu rejected: host' + . ' default.stanford.edu not in .example.edu domain', + ' with the right error'); +is ($server->autocreate ('base', 'service/default-admin'), 1, + 'Creating default/admin succeeds'); +is ($server->autocreate ('base', 'host/default'), undef, + ' but an unqualified host fails'); +is ($server->error, 'base:host/default rejected: host default must be fully' + . ' qualified (add .example.edu)', ' with the right error'); +is ($server->acl_show ('auto-host'), undef, ' and the ACL is not present'); +is ($server->error, 'ACL auto-host not found', ' with the right error'); +is ($server->autocreate ('base', 'host/default.stanford.edu'), undef, + ' and a host in the wrong domain fails'); +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'); + +# 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; +END { + unlink 'wallet-db'; +} + +# Now test handling of some configuration errors. +undef $Wallet::Config::DB_DRIVER; +$server = eval { Wallet::Server->new ($user2, $host) }; +is ($@, "database connection information not configured\n", + 'Fail if DB_DRIVER is not set'); +$Wallet::Config::DB_DRIVER = 'SQLite'; +undef $Wallet::Config::DB_INFO; +$server = eval { Wallet::Server->new ($user2, $host) }; +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/unable to open database file/, + ' or if the database connection fails'); diff --git a/perl/t/init.t b/perl/t/init.t deleted file mode 100755 index b8ec3c9..0000000 --- a/perl/t/init.t +++ /dev/null @@ -1,58 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for database initialization. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 18; - -use Wallet::ACL; -use Wallet::Admin; - -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'); -ok ($admin->isa ('Wallet::Admin'), ' and returned the right class'); -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->schema) }; -is ($@, '', 'Retrieving ADMIN ACL successful'); -ok ($acl->isa ('Wallet::ACL'), ' and is the right class'); -my @entries = $acl->list; -is (scalar (@entries), 1, ' and has only one entry'); -isnt ($entries[0], undef, ' which is a valid entry'); -is ($entries[0][0], 'krb5', ' of krb5 scheme'); -is ($entries[0][1], 'admin@EXAMPLE.COM', ' with the right user'); - -# Test reinitialization. -is ($admin->reinitialize ('admin@EXAMPLE.ORG'), 1, - 'Reinitialization succeeded'); - -# Now repeat the database content checks. -$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; -is (scalar (@entries), 1, ' and has only one entry'); -isnt ($entries[0], undef, ' which is a valid entry'); -is ($entries[0][0], 'krb5', ' of krb5 scheme'); -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->schema) }; -like ($@, qr/^cannot search for ACL ADMIN: /, - ' and now the database is gone'); -END { - unlink 'wallet-db'; -} diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t deleted file mode 100755 index 8eabc6b..0000000 --- a/perl/t/kadmin.t +++ /dev/null @@ -1,117 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the kadmin object implementation. -# -# Written by Jon Robertson -# Copyright 2009, 2010, 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use POSIX qw(strftime); -use Test::More tests => 34; - -BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } - -use Wallet::Admin; -use Wallet::Config; -use Wallet::Kadmin; -use Wallet::Kadmin::MIT; - -# Only load Wallet::Kadmin::Heimdal if a required module is found. -my $heimdal_kadm5 = 0; -eval 'use Heimdal::Kadm5'; -if (!$@) { - $heimdal_kadm5 = 1; - require Wallet::Kadmin::Heimdal; -} - -use lib 't/lib'; -use Util; - -# 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'); -$callback = sub { return 2 }; -$kadmin->fork_callback ($callback); -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. 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', 2 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 ($@, "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', 16 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 = '.'; - - # 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'); - 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. - 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'); - 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'); - is ($kadmin->exists ('wallet/one'), 0, ' and now it does not exist'); - 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%, - ' and the right error message is set'); - is ($kadmin->destroy ('wallet/one'), 1, ' and deleting it again works'); - - unlink 'krb5cc_test'; -} diff --git a/perl/t/keytab.t b/perl/t/keytab.t deleted file mode 100755 index 127762a..0000000 --- a/perl/t/keytab.t +++ /dev/null @@ -1,771 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the keytab object implementation. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2009, 2010, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use POSIX qw(strftime); -use Test::More tests => 141; - -BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } - -use DBI; -use Wallet::Admin; -use Wallet::Config; -use Wallet::Kadmin; -use Wallet::Object::Keytab; - -use lib 't/lib'; -use Util; - -# Mapping of klist -ke encryption type names to the strings that Kerberos uses -# internally. It's very annoying to have to maintain this, and it probably -# breaks with Heimdal. -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-hmac-sha1-96', - 'arcfour with hmac/md5' => 'rc4-hmac'); - -# Some global defaults to use. -my $user = 'admin@EXAMPLE.COM'; -my $host = 'localhost'; -my @trace = ($user, $host, time); - -# Flush all output immediately. -$| = 1; - -# Run a command and throw away the output, returning the exit status. -sub system_quiet { - my ($command, @args) = @_; - my $pid = fork; - if (not defined $pid) { - die "cannot fork: $!\n"; - } elsif ($pid == 0) { - open (STDIN, '<', '/dev/null') or die "cannot reopen stdin: $!\n"; - open (STDOUT, '>', '/dev/null') or die "cannot reopen stdout: $!\n"; - open (STDERR, '>', '/dev/null') or die "cannot reopen stderr: $!\n"; - exec ($command, @args) or die "cannot exec $command: $!\n"; - } else { - waitpid ($pid, 0); - return $?; - } -} - -# Create a principal out of Kerberos. Only usable once the configuration has -# been set up. -sub create { - my ($principal) = @_; - my $kadmin = Wallet::Kadmin->new; - return $kadmin->create ($principal); -} - -# Destroy a principal out of Kerberos. Only usable once the configuration has -# been set up. -sub destroy { - my ($principal) = @_; - my $kadmin = Wallet::Kadmin->new; - return $kadmin->destroy ($principal); -} - -# 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; - 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 (grep { -x "$_/kgetcred" } split (':', $ENV{PATH})) { - return (system_quiet ('kgetcred', $principal) == 0); - } else { - warn "# No kvno or kgetcred found\n"; - return; - } -} - -# 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 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; - - my @enctypes; - 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+ /; - 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) { - @enctypes = (); - 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; -} - -# Use Wallet::Admin to set up the database. -unlink ('krb5cc_temp', 'krb5cc_test', 'test-acl', 'test-pid'); -db_setup; -my $admin = eval { Wallet::Admin->new }; -is ($@, '', 'Database connection succeeded'); -is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $schema = $admin->schema; -my $dbh = $admin->dbh; - -# Use this to accumulate the history traces so that we can check history. -my $history = ''; -my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); - -# Basic keytab creation and manipulation tests. -SKIP: { - skip 'no keytab configuration', 52 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'); - my $realm = $Wallet::Config::KEYTAB_REALM; - - # Clean up the principals we're going to use. - destroy ('wallet/one'); - destroy ('wallet/two'); - - # 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', $schema, - @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", $schema, - @trace) - }; - is ($object, undef, 'Creating malformed principal fails'); - 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', '', $schema, @trace) - }; - is ($object, undef, 'Creating empty principal fails'); - 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', $schema, - @trace) - }; - if (defined ($object)) { - ok (defined ($object), 'Creating good principal succeeds'); - } else { - is ($@, '', 'Creating good principal succeeds'); - } - ok ($object->isa ('Wallet::Object::Keytab'), ' and is the right class'); - ok (created ('wallet/one'), ' and the principal was created'); - create ('wallet/two'); - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/two', $schema, - @trace) - }; - 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, $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', $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'); - is ($object->get (@trace), undef, ' and get fails'); - is ($object->error, "cannot get keytab:wallet/one: object is locked", - ' because it is locked'); - is ($object->flag_clear ('locked', @trace), 1, - ' and clearing locked works'); - my $data = $object->get (@trace); - if (defined ($data)) { - ok (defined ($data), ' and getting the keytab works'); - } else { - is ($object->error, '', ' and getting the keytab works'); - } - ok (! -f "./keytab.$$", ' and the temporary file was cleaned up'); - 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. - my $expected = <<"EOO"; - Type: keytab - Name: wallet/one - Created by: $user - Created from: $host - Created on: $date - Downloaded by: $user -Downloaded from: $host - Downloaded on: $date -EOO - is ($object->show, $expected, 'Show output is correct'); - - # Test error handling on keytab retrieval. - 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'); - like ($object->error, - qr{^error creating keytab for wallet/one\@\Q$realm\E: }, - ' with the right error'); - is ($object->destroy (@trace), 1, ' but we can still destroy it'); - - # Test principal deletion on object destruction. - $object = eval { - 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'); - 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", - ' because it is locked'); - is ($object->flag_clear ('locked', @trace), 1, - ' and clearing locked works'); - is ($object->destroy (@trace), 1, ' and destroying it succeeds'); - ok (! created ('wallet/one'), ' and now it does not exist'); - - # Test history (which should still work after the object is deleted). - $history .= <<"EOO"; -$date create - by $user from $host -$date set flag locked - by $user from $host -$date clear flag locked - by $user from $host -$date get - by $user from $host -$date destroy - by $user from $host -$date create - by $user from $host -$date set flag locked - by $user from $host -$date clear flag locked - by $user from $host -$date destroy - by $user from $host -EOO - is ($object->history, $history, 'History is correct to this point'); - - # Test configuration errors. - undef $Wallet::Config::KEYTAB_FILE; - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - is ($object, undef, 'Creating with bad configuration fails'); - is ($@, "keytab object implementation not configured\n", - ' with the right error'); - $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; - undef $Wallet::Config::KEYTAB_PRINCIPAL; - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - is ($object, undef, ' likewise with another missing variable'); - is ($@, "keytab object implementation not configured\n", - ' with the right error'); - $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); - undef $Wallet::Config::KEYTAB_REALM; - $object = eval { - 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_REALM = contents ('t/data/test.realm'); - undef $Wallet::Config::KEYTAB_KRBTYPE; - $object = eval { - 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', $schema, - @trace) - }; - is ($object, undef, ' and one set to an invalid value'); - is ($@, "unknown KEYTAB_KRBTYPE setting: Active Directory\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 -# can't find remctld. -SKIP: { - skip 'no keytab configuration', 31 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 = '.'; - my $realm = $Wallet::Config::KEYTAB_REALM; - my $principal = $Wallet::Config::KEYTAB_PRINCIPAL; - - # Create the objects for testing and set the unchanging flag. - my $one = eval { - 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', $schema, - @trace); - }; - ok (defined ($two), 'Creating wallet/two succeeds'); - is ($two->flag_set ('unchanging', @trace), 1, ' and setting unchanging'); - - # Finally we can test. First the MIT Kerberos tests. - SKIP: { - 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', 16 unless $remctld; - eval { require Net::Remctl }; - 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', - '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 = $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'); - 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; - unlink 'krb5cc_good'; - } - - # 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', 11 - if (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'mit'); - my $data = $one->get (@trace); - ok (defined $data, 'Get of unchanging keytab works'); - 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; - $second =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; - ok (keytab_valid ($second, 'wallet/one'), ' and the keytab is valid'); - ok (keytab_valid ($data, 'wallet/one'), ' as is the first keytab'); - 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 (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'); - is ($two->destroy (@trace), 1, ' as does destroying wallet/two'); - } - - # Check that history has been updated correctly. - $history .= <<"EOO"; -$date create - by $user from $host -$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 - is ($one->history, $history, 'History is correct to this point'); -} - -# 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', 18 unless -f 't/data/test.keytab'; - - # Test setting synchronization attributes, which can also be done without - # configuration. - my $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - ok (defined ($one), 'Creating wallet/one succeeds'); - my $expected = <<"EOO"; - Type: keytab - Name: wallet/one - Created by: $user - Created from: $host - Created on: $date -EOO - is ($one->show, $expected, 'Show output displays no attributes'); - is ($one->attr ('foo', [ 'bar' ], @trace), undef, - 'Setting unknown attribute fails'); - is ($one->error, 'unknown attribute foo', ' with the right error'); - 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', [ 'kaserver' ], @trace), undef, - ' and setting an unknown sync target fails'); - 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'); - - # 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'); - is ($one->error, undef, ' and there is no error'); - $expected = <<"EOO"; - Type: keytab - Name: wallet/one - Synced with: kaserver - Created by: $user - Created from: $host - Created on: $date -EOO - is ($one->show, $expected, ' and show now displays the attribute'); - $history .= <<"EOO"; -$date create - by $user from $host -EOO - is ($one->history, $history, ' and history is correct for attributes'); - is ($one->attr ('sync', [], @trace), 1, - '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 - by $user from $host -$date destroy - by $user from $host -EOO - is ($one->history, $history, ' and history is correct for removal'); -} - -# Tests for enctype restriction. -SKIP: { - skip 'no keytab configuration', 36 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 = '.'; - my $realm = $Wallet::Config::KEYTAB_REALM; - my $principal = $Wallet::Config::KEYTAB_PRINCIPAL; - - # Create an object for testing and determine the enctypes we have to work - # with. - my $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - if (defined ($one)) { - ok (1, 'Creating wallet/one succeeds'); - } else { - is ($@, '', 'Creating wallet/one succeeds'); - } - my $keytab = $one->get (@trace); - ok (defined ($keytab), ' and retrieving the keytab works'); - my @enctypes = grep { $_ ne 'UNKNOWN' } enctypes ($keytab); - $history .= <<"EOO"; -$date create - by $user from $host -$date get - by $user from $host -EOO - is ($one->history, $history, ' and history is still correct'); - - # No enctypes we recognize? - skip 'no recognized enctypes', 34 unless @enctypes; - - # Set those encryption types and make sure we get back a limited keytab. - is ($one->attr ('enctypes', [ @enctypes ], @trace), 1, - 'Setting enctypes works'); - is ($one->error, undef, ' with no error'); - for my $enctype (@enctypes) { - $history .= "$date add $enctype to attribute enctypes\n"; - $history .= " by $user from $host\n"; - } - my @values = $one->attr ('enctypes'); - is ("@values", "@enctypes", ' and we get back the right enctype list'); - my $eshow = join ("\n" . (' ' x 17), @enctypes); - $eshow =~ s/\s+\z/\n/; - $expected = <<"EOO"; - Type: keytab - Name: wallet/one - Enctypes: $eshow - Created by: $user - Created from: $host - Created on: $date - Downloaded by: $user -Downloaded from: $host - Downloaded on: $date -EOO - is ($one->show, $expected, ' and show now displays the enctype list'); - $keytab = $one->get (@trace); - ok (defined ($keytab), ' and retrieving the keytab still works'); - @values = enctypes ($keytab); - is ("@values", "@enctypes", ' and the keytab has the right keys'); - is ($one->attr ('enctypes', [ 'foo-bar' ], @trace), undef, - 'Setting an unrecognized enctype fails'); - is ($one->error, 'unknown encryption type foo-bar', - ' with the right error message'); - is ($one->show, $expected, ' and we did rollback properly'); - $history .= <<"EOO"; -$date get - by $user from $host -EOO - is ($one->history, $history, 'History is correct to this point'); - - # 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) { - next if $enctype eq $enctypes[0]; - $history .= "$date remove $enctype from attribute enctypes\n"; - $history .= " by $user from $host\n"; - } - @values = $one->attr ('enctypes'); - is ("@values", $enctypes[0], ' and we get back the right value'); - $keytab = $one->get (@trace); - ok (defined ($keytab), ' and retrieving the keytab still works'); - 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'); - is ("@values", $enctypes[1], ' 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[1], ' and it has the right enctype'); - is ($one->attr ('enctypes', [ @enctypes[0..1] ], @trace), 1, - 'Setting two enctypes works'); - @values = $one->attr ('enctypes'); - is ("@values", "@enctypes[0..1]", ' and we get back the right values'); - $keytab = $one->get (@trace); - ok (defined ($keytab), ' and retrieving the keytab still works'); - @values = enctypes ($keytab); - is ("@values", "@enctypes[0..1]", ' and it has the right enctypes'); - - # Check the history trace. Put back all the enctypes for consistent - # status whether or not we skipped this section. - $history .= <<"EOO"; -$date get - by $user from $host -$date remove $enctypes[0] from attribute enctypes - by $user from $host -$date add $enctypes[1] to attribute enctypes - by $user from $host -$date get - by $user from $host -$date add $enctypes[0] to attribute enctypes - by $user from $host -$date get - by $user from $host -EOO - is ($one->attr ('enctypes', [ @enctypes ], @trace), 1, - 'Restoring all enctypes works'); - for my $enctype (@enctypes) { - next if $enctype eq $enctypes[0]; - next if $enctype eq $enctypes[1]; - $history .= "$date add $enctype to attribute enctypes\n"; - $history .= " by $user from $host\n"; - } - is ($one->history, $history, 'History is correct to this point'); - } - - # Test clearing enctypes. - is ($one->attr ('enctypes', [], @trace), 1, 'Clearing enctypes works'); - for my $enctype (@enctypes) { - $history .= "$date remove $enctype from attribute enctypes\n"; - $history .= " by $user from $host\n"; - } - @values = $one->attr ('enctypes'); - ok (@values == 0, ' and now there are no enctypes'); - is ($one->error, undef, ' and no error'); - - # Test deleting enctypes on object destruction. - is ($one->attr ('enctypes', [ $enctypes[0] ], @trace), 1, - 'Setting a single enctype works'); - is ($one->destroy (@trace), 1, ' and destroying the object works'); - $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - ok (defined ($one), ' as does recreating it'); - @values = $one->attr ('enctypes'); - ok (@values == 0, ' and now there are no enctypes'); - is ($one->error, undef, ' and no error'); - - # All done. Clean up and check history. - is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); - $history .= <<"EOO"; -$date add $enctypes[0] to attribute enctypes - 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'); -} - -# Clean up. -$admin->destroy; -END { - unlink ('wallet-db', 'krb5cc_temp', 'krb5cc_test', 'test-acl', 'test-pid'); -} diff --git a/perl/t/object.t b/perl/t/object.t deleted file mode 100755 index 0432a23..0000000 --- a/perl/t/object.t +++ /dev/null @@ -1,353 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the basic object implementation. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2011, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use POSIX qw(strftime); -use Test::More tests => 137; - -use Wallet::ACL; -use Wallet::Admin; -use Wallet::Config; -use Wallet::Object::Base; - -use lib 't/lib'; -use Util; - -# Some global defaults to use. -my $user = 'admin@EXAMPLE.COM'; -my $host = 'localhost'; -my @trace = ($user, $host, time); -my $princ = 'service/test@EXAMPLE.COM'; - -# Use Wallet::Admin to set up the database. -db_setup; -my $admin = eval { Wallet::Admin->new }; -is ($@, '', 'Database connection succeeded'); -is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -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, $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, $schema, @trace) - }; -like ($@, qr/^cannot create object \Qkeytab:$princ: /, 'Repeating fails'); -$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', '', $schema, @trace) }; -is ($@, "invalid object name\n", ' as does an empty name'); -$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, $schema) }; -is ($@, '', 'Object new did not die'); -ok ($object->isa ('Wallet::Object::Base'), ' and returned the right class'); - -# Simple accessor tests. -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', $schema); - -# Owner. -is ($object->owner, undef, 'Owner is not set to start'); -if ($object->owner ('ADMIN', @trace)) { - ok (1, ' and setting it to ADMIN works'); -} else { - is ($object->error, '', ' and setting it to ADMIN works'); -} -is ($object->owner, $acl->id, ' at which point it is ADMIN'); -ok (! $object->owner ('unknown', @trace), - ' but setting it to something bogus fails'); -is ($object->error, 'ACL unknown not found', ' with the right error'); -if ($object->owner ('', @trace)) { - ok (1, ' and clearing it works'); -} else { - is ($object->error, '', ' and clearing it works'); -} -is ($object->owner, undef, ' at which point it is cleared'); -is ($object->owner ('ADMIN', @trace), 1, ' and setting it again works'); - -# Expires. -is ($object->expires, undef, 'Expires is not set to start'); -my $now = strftime ('%Y-%m-%d %T', localtime time); -if ($object->expires ($now, @trace)) { - ok (1, ' and setting it works'); -} else { - is ($object->error, '', ' and setting it works'); -} -is ($object->expires, $now, ' at which point it matches'); -ok (! $object->expires ('13/13/13 13:13:13', @trace), - ' but setting it to something bogus fails'); -is ($object->error, 'malformed expiration time 13/13/13 13:13:13', - ' with the right error'); -if ($object->expires ('', @trace)) { - ok (1, ' and clearing it works'); -} else { - is ($object->error, '', ' and clearing it works'); -} -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"); - if ($object->acl ($type, $acl->id, @trace)) { - ok (1, ' and setting it to ADMIN (numeric) works'); - } else { - is ($object->error, '', ' and setting it to ADMIN (numeric) works'); - } - is ($object->acl ($type), $acl->id, ' at which point it is ADMIN'); - ok (! $object->acl ($type, 22, @trace), - ' but setting it to something bogus fails'); - is ($object->error, 'ACL 22 not found', ' with the right error'); - if ($object->acl ($type, '', @trace)) { - ok (1, ' and clearing it works'); - } else { - is ($object->error, '', ' and clearing it works'); - } - is ($object->acl ($type), undef, ' at which point it is cleared'); - is ($object->acl ($type, $acl->id, @trace), 1, - ' and setting it again works'); -} - -# Flags. -my @flags = $object->flag_list; -is (scalar (@flags), 0, 'No flags set to start'); -is ($object->flag_check ('locked'), 0, ' and locked is not set'); -is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); -is ($object->flag_check ('locked'), 1, ' and now locked is set'); -@flags = $object->flag_list; -is (scalar (@flags), 1, ' and there is one flag'); -is ($flags[0], 'locked', ' which is locked'); -is ($object->flag_set ('locked', @trace), undef, 'Setting locked again fails'); -is ($object->error, - "cannot set flag locked on keytab:$princ: flag already set", - ' with the right error'); -is ($object->flag_set ('unchanging', @trace), 1, - ' but setting unchanging works'); -is ($object->flag_check ('unchanging'), 1, ' and unchanging is now set'); -@flags = $object->flag_list; -is (scalar (@flags), 2, ' and there are two flags'); -is ($flags[0], 'locked', ' which are locked'); -is ($flags[1], 'unchanging', ' and unchanging'); -is ($object->flag_clear ('locked', @trace), 1, 'Clearing locked works'); -is ($object->flag_check ('locked'), 0, ' and now it is not set'); -is ($object->flag_check ('unchanging'), 1, ' but unchanging still is'); -is ($object->flag_clear ('locked', @trace), undef, - ' and clearing it again fails'); -is ($object->error, - "cannot clear flag locked on keytab:$princ: flag not set", - ' with the right error'); -if ($object->flag_set ('locked', @trace)) { - ok (1, ' and setting it again works'); -} else { - is ($object->error, '', ' and setting it again works'); -} - -# Attributes. Very boring. -is ($object->attr ('foo'), undef, 'Retrieving an attribute fails'); -is ($object->error, 'unknown attribute foo', ' with the right error'); -is ($object->attr ('foo', [ 'foo' ], @trace), undef, ' and setting fails'); -is ($object->error, 'unknown attribute foo', ' with the right error'); - -# Test stub methods and locked status. -is ($object->store ("Some data", @trace), undef, 'Store fails'); -is ($object->error, "cannot store keytab:${princ}: object is locked", - ' because the object is locked'); -is ($object->owner ('', @trace), undef, ' and setting owner fails'); -is ($object->error, "cannot modify keytab:${princ}: object is locked", - ' for the same reason'); -is ($object->owner, 1, ' but retrieving the owner works'); -is ($object->expires ('', @trace), undef, ' and setting expires fails'); -is ($object->error, "cannot modify keytab:${princ}: object is locked", - ' for the same reason'); -is ($object->expires, $now, ' but retrieving expires works'); -for my $acl (qw/get store show destroy flags/) { - is ($object->acl ($acl, '', @trace), undef, " and setting $acl ACL fails"); - is ($object->error, "cannot modify keytab:${princ}: object is locked", - ' for the same reason'); - is ($object->acl ($acl), 1, " but retrieving $acl ACL works"); -} -is ($object->flag_check ('locked'), 1, ' and checking flags works'); -@flags = $object->flag_list; -is (scalar (@flags), 2, ' and listing flags works'); -is ("@flags", 'locked unchanging', ' and returns the right data'); -is ($object->flag_clear ('locked', @trace), 1, 'Clearing locked succeeds'); -eval { $object->get (@trace) }; -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - 'Get fails with the right error'); -ok (! $object->store ("Some data", @trace), 'Store fails'); -is ($object->error, "cannot store keytab:$princ: object type is immutable", - ' with the right error'); - -# Test show. -my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); -my $output = <<"EOO"; - Type: keytab - Name: $princ - Owner: ADMIN - Get ACL: ADMIN - Store ACL: ADMIN - Show ACL: ADMIN - 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 - Created on: $date - -Members of ACL ADMIN (id: 1) are: - krb5 $user -EOO -is ($object->show, $output, 'Show output is correct'); -is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); -$output = <<"EOO"; - Type: keytab - Name: $princ - Owner: ADMIN - Get ACL: ADMIN - Store ACL: ADMIN - Show ACL: ADMIN - 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 - Created on: $date - -Members of ACL ADMIN (id: 1) are: - krb5 $user -EOO -is ($object->show, $output, ' and show still works and is correct'); - -# Test destroy. -is ($object->destroy (@trace), undef, 'Destroy fails'); -is ($object->error, "cannot destroy keytab:${princ}: object is locked", - ' because of the locked status'); -is ($object->flag_clear ('locked', @trace), 1, - ' and clearing locked status works'); -if ($object->destroy (@trace)) { - ok (1, 'Destroy is successful'); -} else { - is ($object->error, '', 'Destroy is successful'); -} -$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, $schema, @trace) - }; -ok (defined ($object), 'Recreating the object succeeds'); -$output = <<"EOO"; -$date create - by $user from $host -$date set owner to ADMIN (1) - by $user from $host -$date unset owner (was ADMIN (1)) - by $user from $host -$date set owner to ADMIN (1) - by $user from $host -$date set expires to $now - by $user from $host -$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)) - by $user from $host -$date set acl_get to ADMIN (1) - by $user from $host -$date set acl_store to ADMIN (1) - by $user from $host -$date unset acl_store (was ADMIN (1)) - by $user from $host -$date set acl_store to ADMIN (1) - by $user from $host -$date set acl_show to ADMIN (1) - by $user from $host -$date unset acl_show (was ADMIN (1)) - by $user from $host -$date set acl_show to ADMIN (1) - by $user from $host -$date set acl_destroy to ADMIN (1) - by $user from $host -$date unset acl_destroy (was ADMIN (1)) - by $user from $host -$date set acl_destroy to ADMIN (1) - by $user from $host -$date set acl_flags to ADMIN (1) - by $user from $host -$date unset acl_flags (was ADMIN (1)) - by $user from $host -$date set acl_flags to ADMIN (1) - by $user from $host -$date set flag locked - by $user from $host -$date set flag unchanging - by $user from $host -$date clear flag locked - by $user from $host -$date set flag locked - by $user from $host -$date clear flag locked - by $user from $host -$date set flag locked - by $user from $host -$date clear flag locked - by $user from $host -$date destroy - by $user from $host -$date create - by $user from $host -EOO -is ($object->history, $output, ' and the history is correct'); - -# Clean up. -$admin->destroy; -END { - unlink 'wallet-db'; -} diff --git a/perl/t/object/base.t b/perl/t/object/base.t new file mode 100755 index 0000000..0432a23 --- /dev/null +++ b/perl/t/object/base.t @@ -0,0 +1,353 @@ +#!/usr/bin/perl -w +# +# Tests for the basic object implementation. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2011, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 137; + +use Wallet::ACL; +use Wallet::Admin; +use Wallet::Config; +use Wallet::Object::Base; + +use lib 't/lib'; +use Util; + +# Some global defaults to use. +my $user = 'admin@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($user, $host, time); +my $princ = 'service/test@EXAMPLE.COM'; + +# Use Wallet::Admin to set up the database. +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); +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, $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, $schema, @trace) + }; +like ($@, qr/^cannot create object \Qkeytab:$princ: /, 'Repeating fails'); +$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', '', $schema, @trace) }; +is ($@, "invalid object name\n", ' as does an empty name'); +$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, $schema) }; +is ($@, '', 'Object new did not die'); +ok ($object->isa ('Wallet::Object::Base'), ' and returned the right class'); + +# Simple accessor tests. +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', $schema); + +# Owner. +is ($object->owner, undef, 'Owner is not set to start'); +if ($object->owner ('ADMIN', @trace)) { + ok (1, ' and setting it to ADMIN works'); +} else { + is ($object->error, '', ' and setting it to ADMIN works'); +} +is ($object->owner, $acl->id, ' at which point it is ADMIN'); +ok (! $object->owner ('unknown', @trace), + ' but setting it to something bogus fails'); +is ($object->error, 'ACL unknown not found', ' with the right error'); +if ($object->owner ('', @trace)) { + ok (1, ' and clearing it works'); +} else { + is ($object->error, '', ' and clearing it works'); +} +is ($object->owner, undef, ' at which point it is cleared'); +is ($object->owner ('ADMIN', @trace), 1, ' and setting it again works'); + +# Expires. +is ($object->expires, undef, 'Expires is not set to start'); +my $now = strftime ('%Y-%m-%d %T', localtime time); +if ($object->expires ($now, @trace)) { + ok (1, ' and setting it works'); +} else { + is ($object->error, '', ' and setting it works'); +} +is ($object->expires, $now, ' at which point it matches'); +ok (! $object->expires ('13/13/13 13:13:13', @trace), + ' but setting it to something bogus fails'); +is ($object->error, 'malformed expiration time 13/13/13 13:13:13', + ' with the right error'); +if ($object->expires ('', @trace)) { + ok (1, ' and clearing it works'); +} else { + is ($object->error, '', ' and clearing it works'); +} +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"); + if ($object->acl ($type, $acl->id, @trace)) { + ok (1, ' and setting it to ADMIN (numeric) works'); + } else { + is ($object->error, '', ' and setting it to ADMIN (numeric) works'); + } + is ($object->acl ($type), $acl->id, ' at which point it is ADMIN'); + ok (! $object->acl ($type, 22, @trace), + ' but setting it to something bogus fails'); + is ($object->error, 'ACL 22 not found', ' with the right error'); + if ($object->acl ($type, '', @trace)) { + ok (1, ' and clearing it works'); + } else { + is ($object->error, '', ' and clearing it works'); + } + is ($object->acl ($type), undef, ' at which point it is cleared'); + is ($object->acl ($type, $acl->id, @trace), 1, + ' and setting it again works'); +} + +# Flags. +my @flags = $object->flag_list; +is (scalar (@flags), 0, 'No flags set to start'); +is ($object->flag_check ('locked'), 0, ' and locked is not set'); +is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); +is ($object->flag_check ('locked'), 1, ' and now locked is set'); +@flags = $object->flag_list; +is (scalar (@flags), 1, ' and there is one flag'); +is ($flags[0], 'locked', ' which is locked'); +is ($object->flag_set ('locked', @trace), undef, 'Setting locked again fails'); +is ($object->error, + "cannot set flag locked on keytab:$princ: flag already set", + ' with the right error'); +is ($object->flag_set ('unchanging', @trace), 1, + ' but setting unchanging works'); +is ($object->flag_check ('unchanging'), 1, ' and unchanging is now set'); +@flags = $object->flag_list; +is (scalar (@flags), 2, ' and there are two flags'); +is ($flags[0], 'locked', ' which are locked'); +is ($flags[1], 'unchanging', ' and unchanging'); +is ($object->flag_clear ('locked', @trace), 1, 'Clearing locked works'); +is ($object->flag_check ('locked'), 0, ' and now it is not set'); +is ($object->flag_check ('unchanging'), 1, ' but unchanging still is'); +is ($object->flag_clear ('locked', @trace), undef, + ' and clearing it again fails'); +is ($object->error, + "cannot clear flag locked on keytab:$princ: flag not set", + ' with the right error'); +if ($object->flag_set ('locked', @trace)) { + ok (1, ' and setting it again works'); +} else { + is ($object->error, '', ' and setting it again works'); +} + +# Attributes. Very boring. +is ($object->attr ('foo'), undef, 'Retrieving an attribute fails'); +is ($object->error, 'unknown attribute foo', ' with the right error'); +is ($object->attr ('foo', [ 'foo' ], @trace), undef, ' and setting fails'); +is ($object->error, 'unknown attribute foo', ' with the right error'); + +# Test stub methods and locked status. +is ($object->store ("Some data", @trace), undef, 'Store fails'); +is ($object->error, "cannot store keytab:${princ}: object is locked", + ' because the object is locked'); +is ($object->owner ('', @trace), undef, ' and setting owner fails'); +is ($object->error, "cannot modify keytab:${princ}: object is locked", + ' for the same reason'); +is ($object->owner, 1, ' but retrieving the owner works'); +is ($object->expires ('', @trace), undef, ' and setting expires fails'); +is ($object->error, "cannot modify keytab:${princ}: object is locked", + ' for the same reason'); +is ($object->expires, $now, ' but retrieving expires works'); +for my $acl (qw/get store show destroy flags/) { + is ($object->acl ($acl, '', @trace), undef, " and setting $acl ACL fails"); + is ($object->error, "cannot modify keytab:${princ}: object is locked", + ' for the same reason'); + is ($object->acl ($acl), 1, " but retrieving $acl ACL works"); +} +is ($object->flag_check ('locked'), 1, ' and checking flags works'); +@flags = $object->flag_list; +is (scalar (@flags), 2, ' and listing flags works'); +is ("@flags", 'locked unchanging', ' and returns the right data'); +is ($object->flag_clear ('locked', @trace), 1, 'Clearing locked succeeds'); +eval { $object->get (@trace) }; +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + 'Get fails with the right error'); +ok (! $object->store ("Some data", @trace), 'Store fails'); +is ($object->error, "cannot store keytab:$princ: object type is immutable", + ' with the right error'); + +# Test show. +my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); +my $output = <<"EOO"; + Type: keytab + Name: $princ + Owner: ADMIN + Get ACL: ADMIN + Store ACL: ADMIN + Show ACL: ADMIN + 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 + Created on: $date + +Members of ACL ADMIN (id: 1) are: + krb5 $user +EOO +is ($object->show, $output, 'Show output is correct'); +is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); +$output = <<"EOO"; + Type: keytab + Name: $princ + Owner: ADMIN + Get ACL: ADMIN + Store ACL: ADMIN + Show ACL: ADMIN + 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 + Created on: $date + +Members of ACL ADMIN (id: 1) are: + krb5 $user +EOO +is ($object->show, $output, ' and show still works and is correct'); + +# Test destroy. +is ($object->destroy (@trace), undef, 'Destroy fails'); +is ($object->error, "cannot destroy keytab:${princ}: object is locked", + ' because of the locked status'); +is ($object->flag_clear ('locked', @trace), 1, + ' and clearing locked status works'); +if ($object->destroy (@trace)) { + ok (1, 'Destroy is successful'); +} else { + is ($object->error, '', 'Destroy is successful'); +} +$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, $schema, @trace) + }; +ok (defined ($object), 'Recreating the object succeeds'); +$output = <<"EOO"; +$date create + by $user from $host +$date set owner to ADMIN (1) + by $user from $host +$date unset owner (was ADMIN (1)) + by $user from $host +$date set owner to ADMIN (1) + by $user from $host +$date set expires to $now + by $user from $host +$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)) + by $user from $host +$date set acl_get to ADMIN (1) + by $user from $host +$date set acl_store to ADMIN (1) + by $user from $host +$date unset acl_store (was ADMIN (1)) + by $user from $host +$date set acl_store to ADMIN (1) + by $user from $host +$date set acl_show to ADMIN (1) + by $user from $host +$date unset acl_show (was ADMIN (1)) + by $user from $host +$date set acl_show to ADMIN (1) + by $user from $host +$date set acl_destroy to ADMIN (1) + by $user from $host +$date unset acl_destroy (was ADMIN (1)) + by $user from $host +$date set acl_destroy to ADMIN (1) + by $user from $host +$date set acl_flags to ADMIN (1) + by $user from $host +$date unset acl_flags (was ADMIN (1)) + by $user from $host +$date set acl_flags to ADMIN (1) + by $user from $host +$date set flag locked + by $user from $host +$date set flag unchanging + by $user from $host +$date clear flag locked + by $user from $host +$date set flag locked + by $user from $host +$date clear flag locked + by $user from $host +$date set flag locked + by $user from $host +$date clear flag locked + by $user from $host +$date destroy + by $user from $host +$date create + by $user from $host +EOO +is ($object->history, $output, ' and the history is correct'); + +# Clean up. +$admin->destroy; +END { + unlink 'wallet-db'; +} diff --git a/perl/t/object/duo.t b/perl/t/object/duo.t new file mode 100755 index 0000000..4229afe --- /dev/null +++ b/perl/t/object/duo.t @@ -0,0 +1,157 @@ +#!/usr/bin/perl +# +# Tests for the Duo integration object implementation. +# +# Written by Russ Allbery +# Copyright 2014 +# 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; + +BEGIN { + eval 'use Net::Duo'; + plan skip_all => 'Net::Duo required for testing duo' + if $@; + eval 'use Net::Duo::Mock::Agent'; + plan skip_all => 'Net::Duo::Mock::Agent required for testing duo' + if $@; +} + +BEGIN { + use_ok('Wallet::Admin'); + use_ok('Wallet::Config'); + use_ok('Wallet::Object::Duo'); +} + +use lib 't/lib'; +use Util; + +# Some global defaults to use. +my $user = 'admin@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($user, $host, time); +my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); + +# Flush all output immediately. +$| = 1; + +# Use Wallet::Admin to set up the database. +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); +my $schema = $admin->schema; + +# Create a mock object to use for Duo calls. +my $mock = Net::Duo::Mock::Agent->new ({ key_file => 't/data/duo/keys.json' }); + +# Test error handling in the absence of configuration. +my $object = eval { + Wallet::Object::Duo->new ('duo', 'test', $schema); +}; +is ($object, undef, 'Wallet::Object::Duo new with no config failed'); +is ($@, "duo object implementation not configured\n", '...with correct error'); +$object = eval { + Wallet::Object::Duo->create ('duo', 'test', $schema, @trace); +}; +is ($object, undef, 'Wallet::Object::Duo creation with no config failed'); +is ($@, "duo object implementation not configured\n", '...with correct error'); + +# Set up the Duo configuration. +$Wallet::Config::DUO_AGENT = $mock; +$Wallet::Config::DUO_KEY_FILE = 't/data/duo/keys.json'; + +# Test creating an integration. +note ('Test creating an integration'); +my $expected = { + name => 'test', + notes => 'Managed by wallet', + type => 'unix', +}; +$mock->expect ( + { + method => 'POST', + uri => '/admin/v1/integrations', + content => $expected, + response_file => 't/data/duo/integration.json', + } +); +$object = Wallet::Object::Duo->create ('duo', 'test', $schema, @trace); +isa_ok ($object, 'Wallet::Object::Duo'); + +# Check the metadata about the new wallet object. +$expected = <<"EOO"; + Type: duo + Name: test + Duo key: DIRWIH0ZZPV4G88B37VQ + Created by: $user + Created from: $host + Created on: $date +EOO +is ($object->show, $expected, 'Show output is correct'); + +# Test retrieving the integration information. +note ('Test retrieving an integration'); +$mock->expect ( + { + method => 'GET', + uri => '/admin/v1/integrations/DIRWIH0ZZPV4G88B37VQ', + response_file => 't/data/duo/integration.json', + } +); +my $data = $object->get (@trace); +ok (defined ($data), 'Retrieval succeeds'); +$expected = <<'EOO'; +[duo] +ikey = DIRWIH0ZZPV4G88B37VQ +skey = QO4ZLqQVRIOZYkHfdPDORfcNf8LeXIbCWwHazY7o +host = example-admin.duosecurity.com +EOO +is ($data, $expected, '...and integration data is correct'); + +# Ensure that we can't retrieve the object when locked. +is ($object->flag_set ('locked', @trace), 1, + 'Setting object to locked succeeds'); +is ($object->get, undef, '...and now get fails'); +is ($object->error, 'cannot get duo:test: object is locked', + '...with correct error'); +is ($object->flag_clear ('locked', @trace), 1, + '...and clearing locked flag works'); + +# Create a new object by wallet type and name. +$object = Wallet::Object::Duo->new ('duo', 'test', $schema); + +# Test deleting an integration. We can't test this entirely properly because +# currently Net::Duo::Mock::Agent doesn't support stacking multiple expected +# calls and delete makes two calls. +note ('Test deleting an integration'); +$mock->expect ( + { + method => 'GET', + uri => '/admin/v1/integrations/DIRWIH0ZZPV4G88B37VQ', + response_file => 't/data/duo/integration.json', + } +); +TODO: { + local $TODO = 'Net::Duo::Mock::Agent not yet capable'; + + is ($object->destroy (@trace), 1, 'Duo object deletion succeeded'); + $object = eval { Wallet::Object::Duo->new ('duo', 'test', $schema) }; + is ($object, undef, '...and now object cannot be retrieved'); + is ($@, "cannot find duo:test\n", '...with correct error'); +} + +# Clean up. +$admin->destroy; +END { + unlink ('wallet-db'); +} + +# Done testing. +done_testing (); diff --git a/perl/t/object/file.t b/perl/t/object/file.t new file mode 100755 index 0000000..0aecd9d --- /dev/null +++ b/perl/t/object/file.t @@ -0,0 +1,150 @@ +#!/usr/bin/perl -w +# +# Tests for the file object implementation. +# +# Written by Russ Allbery +# Copyright 2008, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 56; + +use Wallet::Admin; +use Wallet::Config; +use Wallet::Object::File; + +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-files') == 0 or die "cannot remove test-files\n"; +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); +my $schema = $admin->schema; + +# Use this to accumulate the history traces so that we can check history. +my $history = ''; +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', $schema, @trace) + }; +ok (defined ($object), 'Creating a basic file object succeeds'); +ok ($object->isa ('Wallet::Object::File'), ' and is the right class'); +is ($object->get (@trace), undef, ' and get fails'); +is ($object->error, 'file support not configured', ' with the right error'); +is ($object->store (@trace), undef, ' and store fails'); +is ($object->error, 'file support not configured', ' with the right error'); +is ($object->destroy (@trace), 1, ' but destroy succeeds'); + +# Set up our configuration. +mkdir 'test-files' or die "cannot create test-files: $!\n"; +$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', $schema, @trace) + }; +ok (defined ($object), 'Creating a basic file object succeeds'); +ok ($object->isa ('Wallet::Object::File'), ' and is the right class'); +is ($object->get (@trace), undef, ' and get fails'); +is ($object->error, 'cannot get file:test: object has not been stored', + ' with the right error'); +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', $schema, @trace) + }; +ok (defined ($object), 'Recreating the object succeeds'); +is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); +ok (-d 'test-files/09', ' and the hash bucket was created'); +ok (-f 'test-files/09/test', ' and the file exists'); +is (contents ('test-files/09/test'), 'foo', ' with the right contents'); +is ($object->get (@trace), "foo\n", ' and get returns correctly'); +unlink 'test-files/09/test'; +is ($object->get (@trace), undef, ' and get fails if we delete it'); +is ($object->error, 'cannot get file:test: object has not been stored', + ' as if it had not been stored'); +is ($object->store ("bar\n\0baz\n", @trace), 1, ' but storing again works'); +ok (-f 'test-files/09/test', ' and the file exists'); +is (contents ('test-files/09/test'), 'bar', ' with the right contents'); +is ($object->get (@trace), "bar\n\0baz\n", ' and get returns correctly'); + +# Try exceeding the store size. +$Wallet::Config::FILE_MAX_SIZE = 1024; +is ($object->store ('x' x 1024, @trace), 1, + ' and storing exactly 1024 characters works'); +is ($object->get (@trace), 'x' x 1024, ' and get returns the right thing'); +is ($object->store ('x' x 1025, @trace), undef, + ' but storing 1025 characters fails'); +is ($object->error, 'data exceeds maximum of 1024 bytes', + ' with the right error'); + +# Try storing the empty data object. +is ($object->store ('', @trace), 1, 'Storing the empty object works'); +is ($object->get (@trace), '', ' and get returns the right thing'); + +# Test destruction. +is ($object->destroy (@trace), 1, 'Destroying the object works'); +ok (! -f 'test-files/09/test', ' and the file is gone'); + +# Now try some aggressive names. +$object = eval { + 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'); +ok (-d 'test-files/39', ' and the hash bucket was created'); +ok (-f 'test-files/39/%2E%2E%2Ffoo', ' and the file exists'); +is (contents ('test-files/39/%2E%2E%2Ffoo'), 'foo', + ' with the right contents'); +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", $schema, @trace) + }; +ok (defined ($object), 'Creating nul succeeds'); +is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); +ok (-d 'test-files/93', ' and the hash bucket was created'); +ok (-f 'test-files/93/%00', ' and the file exists'); +is (contents ('test-files/93/%00'), 'foo', + ' with the right contents'); +is ($object->get (@trace), "foo\n", ' and get returns correctly'); +is ($object->destroy (@trace), 1, 'Destroying the object works'); +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', $schema, @trace) + }; +ok (defined ($object), 'Recreating the object succeeds'); +is ($object->store ("foo\n", @trace), undef, + ' and storing data in it fails'); +like ($object->error, qr/^cannot create file bucket 09: /, + ' with the right error'); +is ($object->get (@trace), undef, ' and get fails'); +like ($object->error, qr/^cannot create file bucket 09: /, + ' with the right error'); +is ($object->destroy (@trace), 1, ' but destroying the object succeeds'); + +# Clean up. +$admin->destroy; +END { + unlink ('wallet-db'); +} diff --git a/perl/t/object/keytab.t b/perl/t/object/keytab.t new file mode 100755 index 0000000..127762a --- /dev/null +++ b/perl/t/object/keytab.t @@ -0,0 +1,771 @@ +#!/usr/bin/perl -w +# +# Tests for the keytab object implementation. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2009, 2010, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 141; + +BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } + +use DBI; +use Wallet::Admin; +use Wallet::Config; +use Wallet::Kadmin; +use Wallet::Object::Keytab; + +use lib 't/lib'; +use Util; + +# Mapping of klist -ke encryption type names to the strings that Kerberos uses +# internally. It's very annoying to have to maintain this, and it probably +# breaks with Heimdal. +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-hmac-sha1-96', + 'arcfour with hmac/md5' => 'rc4-hmac'); + +# Some global defaults to use. +my $user = 'admin@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($user, $host, time); + +# Flush all output immediately. +$| = 1; + +# Run a command and throw away the output, returning the exit status. +sub system_quiet { + my ($command, @args) = @_; + my $pid = fork; + if (not defined $pid) { + die "cannot fork: $!\n"; + } elsif ($pid == 0) { + open (STDIN, '<', '/dev/null') or die "cannot reopen stdin: $!\n"; + open (STDOUT, '>', '/dev/null') or die "cannot reopen stdout: $!\n"; + open (STDERR, '>', '/dev/null') or die "cannot reopen stderr: $!\n"; + exec ($command, @args) or die "cannot exec $command: $!\n"; + } else { + waitpid ($pid, 0); + return $?; + } +} + +# Create a principal out of Kerberos. Only usable once the configuration has +# been set up. +sub create { + my ($principal) = @_; + my $kadmin = Wallet::Kadmin->new; + return $kadmin->create ($principal); +} + +# Destroy a principal out of Kerberos. Only usable once the configuration has +# been set up. +sub destroy { + my ($principal) = @_; + my $kadmin = Wallet::Kadmin->new; + return $kadmin->destroy ($principal); +} + +# 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; + 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 (grep { -x "$_/kgetcred" } split (':', $ENV{PATH})) { + return (system_quiet ('kgetcred', $principal) == 0); + } else { + warn "# No kvno or kgetcred found\n"; + return; + } +} + +# 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 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; + + my @enctypes; + 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+ /; + 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) { + @enctypes = (); + 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; +} + +# Use Wallet::Admin to set up the database. +unlink ('krb5cc_temp', 'krb5cc_test', 'test-acl', 'test-pid'); +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); +my $schema = $admin->schema; +my $dbh = $admin->dbh; + +# Use this to accumulate the history traces so that we can check history. +my $history = ''; +my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); + +# Basic keytab creation and manipulation tests. +SKIP: { + skip 'no keytab configuration', 52 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'); + my $realm = $Wallet::Config::KEYTAB_REALM; + + # Clean up the principals we're going to use. + destroy ('wallet/one'); + destroy ('wallet/two'); + + # 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', $schema, + @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", $schema, + @trace) + }; + is ($object, undef, 'Creating malformed principal fails'); + 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', '', $schema, @trace) + }; + is ($object, undef, 'Creating empty principal fails'); + 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', $schema, + @trace) + }; + if (defined ($object)) { + ok (defined ($object), 'Creating good principal succeeds'); + } else { + is ($@, '', 'Creating good principal succeeds'); + } + ok ($object->isa ('Wallet::Object::Keytab'), ' and is the right class'); + ok (created ('wallet/one'), ' and the principal was created'); + create ('wallet/two'); + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/two', $schema, + @trace) + }; + 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, $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', $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'); + is ($object->get (@trace), undef, ' and get fails'); + is ($object->error, "cannot get keytab:wallet/one: object is locked", + ' because it is locked'); + is ($object->flag_clear ('locked', @trace), 1, + ' and clearing locked works'); + my $data = $object->get (@trace); + if (defined ($data)) { + ok (defined ($data), ' and getting the keytab works'); + } else { + is ($object->error, '', ' and getting the keytab works'); + } + ok (! -f "./keytab.$$", ' and the temporary file was cleaned up'); + 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. + my $expected = <<"EOO"; + Type: keytab + Name: wallet/one + Created by: $user + Created from: $host + Created on: $date + Downloaded by: $user +Downloaded from: $host + Downloaded on: $date +EOO + is ($object->show, $expected, 'Show output is correct'); + + # Test error handling on keytab retrieval. + 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'); + like ($object->error, + qr{^error creating keytab for wallet/one\@\Q$realm\E: }, + ' with the right error'); + is ($object->destroy (@trace), 1, ' but we can still destroy it'); + + # Test principal deletion on object destruction. + $object = eval { + 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'); + 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", + ' because it is locked'); + is ($object->flag_clear ('locked', @trace), 1, + ' and clearing locked works'); + is ($object->destroy (@trace), 1, ' and destroying it succeeds'); + ok (! created ('wallet/one'), ' and now it does not exist'); + + # Test history (which should still work after the object is deleted). + $history .= <<"EOO"; +$date create + by $user from $host +$date set flag locked + by $user from $host +$date clear flag locked + by $user from $host +$date get + by $user from $host +$date destroy + by $user from $host +$date create + by $user from $host +$date set flag locked + by $user from $host +$date clear flag locked + by $user from $host +$date destroy + by $user from $host +EOO + is ($object->history, $history, 'History is correct to this point'); + + # Test configuration errors. + undef $Wallet::Config::KEYTAB_FILE; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + is ($object, undef, 'Creating with bad configuration fails'); + is ($@, "keytab object implementation not configured\n", + ' with the right error'); + $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; + undef $Wallet::Config::KEYTAB_PRINCIPAL; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + is ($object, undef, ' likewise with another missing variable'); + is ($@, "keytab object implementation not configured\n", + ' with the right error'); + $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); + undef $Wallet::Config::KEYTAB_REALM; + $object = eval { + 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_REALM = contents ('t/data/test.realm'); + undef $Wallet::Config::KEYTAB_KRBTYPE; + $object = eval { + 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', $schema, + @trace) + }; + is ($object, undef, ' and one set to an invalid value'); + is ($@, "unknown KEYTAB_KRBTYPE setting: Active Directory\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 +# can't find remctld. +SKIP: { + skip 'no keytab configuration', 31 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 = '.'; + my $realm = $Wallet::Config::KEYTAB_REALM; + my $principal = $Wallet::Config::KEYTAB_PRINCIPAL; + + # Create the objects for testing and set the unchanging flag. + my $one = eval { + 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', $schema, + @trace); + }; + ok (defined ($two), 'Creating wallet/two succeeds'); + is ($two->flag_set ('unchanging', @trace), 1, ' and setting unchanging'); + + # Finally we can test. First the MIT Kerberos tests. + SKIP: { + 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', 16 unless $remctld; + eval { require Net::Remctl }; + 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', + '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 = $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'); + 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; + unlink 'krb5cc_good'; + } + + # 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', 11 + if (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'mit'); + my $data = $one->get (@trace); + ok (defined $data, 'Get of unchanging keytab works'); + 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; + $second =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; + ok (keytab_valid ($second, 'wallet/one'), ' and the keytab is valid'); + ok (keytab_valid ($data, 'wallet/one'), ' as is the first keytab'); + 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 (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'); + is ($two->destroy (@trace), 1, ' as does destroying wallet/two'); + } + + # Check that history has been updated correctly. + $history .= <<"EOO"; +$date create + by $user from $host +$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 + is ($one->history, $history, 'History is correct to this point'); +} + +# 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', 18 unless -f 't/data/test.keytab'; + + # Test setting synchronization attributes, which can also be done without + # configuration. + my $one = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + ok (defined ($one), 'Creating wallet/one succeeds'); + my $expected = <<"EOO"; + Type: keytab + Name: wallet/one + Created by: $user + Created from: $host + Created on: $date +EOO + is ($one->show, $expected, 'Show output displays no attributes'); + is ($one->attr ('foo', [ 'bar' ], @trace), undef, + 'Setting unknown attribute fails'); + is ($one->error, 'unknown attribute foo', ' with the right error'); + 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', [ 'kaserver' ], @trace), undef, + ' and setting an unknown sync target fails'); + 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'); + + # 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'); + is ($one->error, undef, ' and there is no error'); + $expected = <<"EOO"; + Type: keytab + Name: wallet/one + Synced with: kaserver + Created by: $user + Created from: $host + Created on: $date +EOO + is ($one->show, $expected, ' and show now displays the attribute'); + $history .= <<"EOO"; +$date create + by $user from $host +EOO + is ($one->history, $history, ' and history is correct for attributes'); + is ($one->attr ('sync', [], @trace), 1, + '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 + by $user from $host +$date destroy + by $user from $host +EOO + is ($one->history, $history, ' and history is correct for removal'); +} + +# Tests for enctype restriction. +SKIP: { + skip 'no keytab configuration', 36 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 = '.'; + my $realm = $Wallet::Config::KEYTAB_REALM; + my $principal = $Wallet::Config::KEYTAB_PRINCIPAL; + + # Create an object for testing and determine the enctypes we have to work + # with. + my $one = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + if (defined ($one)) { + ok (1, 'Creating wallet/one succeeds'); + } else { + is ($@, '', 'Creating wallet/one succeeds'); + } + my $keytab = $one->get (@trace); + ok (defined ($keytab), ' and retrieving the keytab works'); + my @enctypes = grep { $_ ne 'UNKNOWN' } enctypes ($keytab); + $history .= <<"EOO"; +$date create + by $user from $host +$date get + by $user from $host +EOO + is ($one->history, $history, ' and history is still correct'); + + # No enctypes we recognize? + skip 'no recognized enctypes', 34 unless @enctypes; + + # Set those encryption types and make sure we get back a limited keytab. + is ($one->attr ('enctypes', [ @enctypes ], @trace), 1, + 'Setting enctypes works'); + is ($one->error, undef, ' with no error'); + for my $enctype (@enctypes) { + $history .= "$date add $enctype to attribute enctypes\n"; + $history .= " by $user from $host\n"; + } + my @values = $one->attr ('enctypes'); + is ("@values", "@enctypes", ' and we get back the right enctype list'); + my $eshow = join ("\n" . (' ' x 17), @enctypes); + $eshow =~ s/\s+\z/\n/; + $expected = <<"EOO"; + Type: keytab + Name: wallet/one + Enctypes: $eshow + Created by: $user + Created from: $host + Created on: $date + Downloaded by: $user +Downloaded from: $host + Downloaded on: $date +EOO + is ($one->show, $expected, ' and show now displays the enctype list'); + $keytab = $one->get (@trace); + ok (defined ($keytab), ' and retrieving the keytab still works'); + @values = enctypes ($keytab); + is ("@values", "@enctypes", ' and the keytab has the right keys'); + is ($one->attr ('enctypes', [ 'foo-bar' ], @trace), undef, + 'Setting an unrecognized enctype fails'); + is ($one->error, 'unknown encryption type foo-bar', + ' with the right error message'); + is ($one->show, $expected, ' and we did rollback properly'); + $history .= <<"EOO"; +$date get + by $user from $host +EOO + is ($one->history, $history, 'History is correct to this point'); + + # 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) { + next if $enctype eq $enctypes[0]; + $history .= "$date remove $enctype from attribute enctypes\n"; + $history .= " by $user from $host\n"; + } + @values = $one->attr ('enctypes'); + is ("@values", $enctypes[0], ' and we get back the right value'); + $keytab = $one->get (@trace); + ok (defined ($keytab), ' and retrieving the keytab still works'); + 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'); + is ("@values", $enctypes[1], ' 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[1], ' and it has the right enctype'); + is ($one->attr ('enctypes', [ @enctypes[0..1] ], @trace), 1, + 'Setting two enctypes works'); + @values = $one->attr ('enctypes'); + is ("@values", "@enctypes[0..1]", ' and we get back the right values'); + $keytab = $one->get (@trace); + ok (defined ($keytab), ' and retrieving the keytab still works'); + @values = enctypes ($keytab); + is ("@values", "@enctypes[0..1]", ' and it has the right enctypes'); + + # Check the history trace. Put back all the enctypes for consistent + # status whether or not we skipped this section. + $history .= <<"EOO"; +$date get + by $user from $host +$date remove $enctypes[0] from attribute enctypes + by $user from $host +$date add $enctypes[1] to attribute enctypes + by $user from $host +$date get + by $user from $host +$date add $enctypes[0] to attribute enctypes + by $user from $host +$date get + by $user from $host +EOO + is ($one->attr ('enctypes', [ @enctypes ], @trace), 1, + 'Restoring all enctypes works'); + for my $enctype (@enctypes) { + next if $enctype eq $enctypes[0]; + next if $enctype eq $enctypes[1]; + $history .= "$date add $enctype to attribute enctypes\n"; + $history .= " by $user from $host\n"; + } + is ($one->history, $history, 'History is correct to this point'); + } + + # Test clearing enctypes. + is ($one->attr ('enctypes', [], @trace), 1, 'Clearing enctypes works'); + for my $enctype (@enctypes) { + $history .= "$date remove $enctype from attribute enctypes\n"; + $history .= " by $user from $host\n"; + } + @values = $one->attr ('enctypes'); + ok (@values == 0, ' and now there are no enctypes'); + is ($one->error, undef, ' and no error'); + + # Test deleting enctypes on object destruction. + is ($one->attr ('enctypes', [ $enctypes[0] ], @trace), 1, + 'Setting a single enctype works'); + is ($one->destroy (@trace), 1, ' and destroying the object works'); + $one = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + ok (defined ($one), ' as does recreating it'); + @values = $one->attr ('enctypes'); + ok (@values == 0, ' and now there are no enctypes'); + is ($one->error, undef, ' and no error'); + + # All done. Clean up and check history. + is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); + $history .= <<"EOO"; +$date add $enctypes[0] to attribute enctypes + 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'); +} + +# Clean up. +$admin->destroy; +END { + unlink ('wallet-db', 'krb5cc_temp', 'krb5cc_test', 'test-acl', 'test-pid'); +} diff --git a/perl/t/object/wa-keyring.t b/perl/t/object/wa-keyring.t new file mode 100755 index 0000000..8d8e1fe --- /dev/null +++ b/perl/t/object/wa-keyring.t @@ -0,0 +1,184 @@ +#!/usr/bin/perl +# +# Tests for the WebAuth keyring object implementation. +# +# Written by Russ Allbery +# Copyright 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use strict; +use warnings; + +use Test::More; + +BEGIN { + eval 'use WebAuth 3.06 qw(WA_KEY_AES WA_AES_128)'; + plan skip_all => 'WebAuth 3.06 required for testing wa-keyring' + if $@; +} + +use POSIX qw(strftime); +use WebAuth::Key 1.01 (); +use WebAuth::Keyring 1.02 (); + +BEGIN { + plan tests => 68; + 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 $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', $schema, @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', $schema, @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', $schema, @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', $schema, @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; +END { + unlink ('wallet-db'); +} diff --git a/perl/t/pod-spelling.t b/perl/t/pod-spelling.t deleted file mode 100755 index 577a99e..0000000 --- a/perl/t/pod-spelling.t +++ /dev/null @@ -1,74 +0,0 @@ -#!/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 -# -# See LICENSE for licensing terms. - -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 deleted file mode 100755 index dfcf88e..0000000 --- a/perl/t/pod.t +++ /dev/null @@ -1,15 +0,0 @@ -#!/usr/bin/perl -w -# -# Test POD formatting for the wallet Perl modules. -# -# Written by Russ Allbery -# Copyright 2007, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use strict; -use Test::More; -eval 'use Test::Pod 1.00'; -plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; -all_pod_files_ok (); diff --git a/perl/t/policy/stanford.t b/perl/t/policy/stanford.t new file mode 100755 index 0000000..555086c --- /dev/null +++ b/perl/t/policy/stanford.t @@ -0,0 +1,260 @@ +#!/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, 2014 +# 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 => 101; + +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 afs/testcell.stanford.edu); + +# Various invalid keytab names. +my @INVALID_KEYTABS = qw(example host/example service/example.stanford.edu + thisistoolong/cgi not-valid/cgi unknown/example.stanford.edu + afs/testcell); + +# Various valid file names. +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 + 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 + 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 + 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 + 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/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'; +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 (@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"); +} + +# 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' +); + +# 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( + [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 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_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)) { + 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; +END { + unlink 'wallet-db'; +} diff --git a/perl/t/report.t b/perl/t/report.t deleted file mode 100755 index 9563362..0000000 --- a/perl/t/report.t +++ /dev/null @@ -1,330 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the wallet reporting interface. -# -# Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 197; - -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'); - -# 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; -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'); - -# 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'); -@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 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'); -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'); - -# 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'); -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'); - -# 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'); - -# Set up a file bucket so that we can create an object we can retrieve. -system ('rm -rf test-files') == 0 or die "cannot remove test-files\n"; -mkdir 'test-files' or die "cannot create test-files: $!\n"; -$Wallet::Config::FILE_BUCKET = 'test-files'; - -# Create a file object and ensure that it shows up in the unused list. -is ($server->create ('file', 'test'), 1, 'Creating file:test succeeds'); -is ($server->owner ('file', 'test', 'ADMIN'), 1, - ' and setting its owner works'); -@objects = $report->objects ('unused'); -is (scalar (@objects), 4, 'There are now four unused objects'); -is ($objects[0][0], 'base', ' and the first has the right type'); -is ($objects[0][1], 'service/admin', ' and the right name'); -is ($objects[1][0], 'base', ' and the second has the right type'); -is ($objects[1][1], 'service/foo', ' and the right name'); -is ($objects[2][0], 'base', ' and the third has the right type'); -is ($objects[2][1], 'service/null', ' and the right name'); -is ($objects[3][0], 'file', ' and the fourth has the right type'); -is ($objects[3][1], 'test', ' and the right name'); - -# Store something and retrieve it, and then check that the file object fell -# off of the list. -is ($server->store ('file', 'test', 'Some data'), 1, - 'Storing data in file:test succeeds'); -is ($server->get ('file', 'test'), 'Some data', ' and retrieving it works'); -@objects = $report->objects ('unused'); -is (scalar (@objects), 3, ' and now there are three unused objects'); -is ($objects[0][0], 'base', ' and the first has the right type'); -is ($objects[0][1], 'service/admin', ' and the right name'); -is ($objects[1][0], 'base', ' and the second has the right type'); -is ($objects[1][1], 'service/foo', ' and the right name'); -is ($objects[2][0], 'base', ' and the third has the right type'); -is ($objects[2][1], 'service/null', ' and the right name'); - -# The third and fourth ACLs are both empty and should show up as duplicate. -@acls = $report->acls ('duplicate'); -is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); -is (scalar (@{ $acls[0] }), 2, ' with two members'); -is ($acls[0][0], 'fourth', ' and the first member is correct'); -is ($acls[0][1], 'third', ' and the second member is correct'); - -# Add the same line to both ACLs. They should still show up as duplicate. -is ($server->acl_add ('fourth', 'base', 'bar'), 1, - 'Adding a line to the fourth ACL works'); -is ($server->acl_add ('third', 'base', 'bar'), 1, - ' and adding a line to the third ACL works'); -@acls = $report->acls ('duplicate'); -is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); -is (scalar (@{ $acls[0] }), 2, ' with two members'); -is ($acls[0][0], 'fourth', ' and the first member is correct'); -is ($acls[0][1], 'third', ' and the second member is correct'); - -# Add another line to the third ACL. Now we match second. -is ($server->acl_add ('third', 'base', 'foo'), 1, - 'Adding another line to the third ACL works'); -@acls = $report->acls ('duplicate'); -is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); -is (scalar (@{ $acls[0] }), 2, ' with two members'); -is ($acls[0][0], 'second', ' and the first member is correct'); -is ($acls[0][1], 'third', ' and the second member is correct'); - -# Add yet another line to the third ACL. Now all ACLs are distinct. -is ($server->acl_add ('third', 'base', 'baz'), 1, - 'Adding another line to the third ACL works'); -@acls = $report->acls ('duplicate'); -is (scalar (@acls), 0, 'There are no duplicate ACLs'); -is ($report->error, undef, ' and no error'); - -# Clean up. -$admin->destroy; -system ('rm -r test-files') == 0 or die "cannot remove test-files\n"; -END { - unlink 'wallet-db'; -} diff --git a/perl/t/server.t b/perl/t/server.t deleted file mode 100755 index 9026439..0000000 --- a/perl/t/server.t +++ /dev/null @@ -1,1040 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the wallet server API. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011, 2012, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 382; - -use POSIX qw(strftime); -use Wallet::Admin; -use Wallet::Config; -use Wallet::Schema; -use Wallet::Server; - -use lib 't/lib'; -use Util; - -# Some global defaults to use. -my $admin = 'admin@EXAMPLE.COM'; -my $user1 = 'alice@EXAMPLE.COM'; -my $user2 = 'bob@EXAMPLE.COM'; -my $host = 'localhost'; -my @trace = ($admin, $host); - -# Use Wallet::Admin to set up the database. -db_setup; -my $setup = eval { Wallet::Admin->new }; -is ($@, '', 'Database initialization did not die'); -is ($setup->reinitialize ($admin), 1, 'Database initialization succeeded'); - -# Now test the new method. -$server = eval { Wallet::Server->new (@trace) }; -is ($@, '', 'Reopening with new did not die'); -ok ($server->isa ('Wallet::Server'), ' and returned the right class'); -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'); - -# We're currently running as the administrator, so everything should succeed. -# Set up a bunch of data for us to test with, starting with some ACLs. Test -# the error handling while we're at it. -is ($server->acl_show ('ADMIN'), - "Members of ACL ADMIN (id: 1) are:\n krb5 $admin\n", - 'Showing the ADMIN ACL works'); -is ($server->acl_show (1), - "Members of ACL ADMIN (id: 1) are:\n krb5 $admin\n", - ' including by number'); -my $history = <<"EOO"; -DATE create - by $admin from $host -DATE add krb5 $admin - by $admin from $host -EOO -my $result = $server->acl_history ('ADMIN'); -$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($result, $history, ' and displaying history works'); -$result = $server->acl_history (1); -$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -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'); -like ($server->error, qr/^cannot create ACL user1: /, - ' and returns a good error'); -is ($server->acl_create ('ADMIN'), undef, ' and cannot create ADMIN'); -like ($server->error, qr/^cannot create ACL ADMIN: /, - ' and returns a good error'); -is ($server->acl_create ('user2'), 1, 'Create another ACL'); -is ($server->acl_create ('both'), 1, ' and one for both users'); -is ($server->acl_create ('test2'), 1, ' and an empty one'); -is ($server->acl_create ('test'), 1, ' and another test one'); -is ($server->acl_rename ('empty', 'test'), undef, - 'Cannot rename nonexistent ACL'); -is ($server->error, 'ACL empty not found', ' and returns the right error'); -is ($server->acl_rename ('test', 'test2'), undef, - ' and cannot rename to an existing name'); -like ($server->error, qr/^cannot rename ACL 6 to test2: /, - ' and returns the right error'); -is ($server->acl_rename ('test', 'empty'), 1, 'Renaming does work'); -is ($server->acl_rename ('test', 'empty'), undef, ' but not twice'); -is ($server->error, 'ACL test not found', ' and returns the right error'); -is ($server->acl_show ('test'), undef, ' and show fails'); -is ($server->error, 'ACL test not found', ' and returns the right error'); -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_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'); -is ($server->error, 'unknown ACL scheme krb4', ' with the right error'); -is ($server->acl_add ('user1', 'krb5', $user1), 1, - ' but works with the right scheme'); -is ($server->acl_add ('user2', 'krb5', $user2), 1, 'Add another entry'); -is ($server->acl_add ('both', 'krb5', $user1), 1, ' and another'); -is ($server->acl_add ('both', 'krb5', $user2), 1, - ' and another to the same ACL'); -is ($server->acl_show ('both'), - "Members of ACL both (id: 4) are:\n krb5 $user1\n krb5 $user2\n", - ' and show returns the correct result'); -$history = <<"EOO"; -DATE create - by $admin from $host -DATE add krb5 $user1 - by $admin from $host -DATE add krb5 $user2 - by $admin from $host -EOO -$result = $server->acl_history ('both'); -$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($result, $history, ' as does history'); -is ($server->acl_add ('empty', 'krb5', $user1), 1, ' and another to empty'); -is ($server->acl_add ('test', 'krb5', $user1), undef, - ' but adding to an unknown ACL fails'); -is ($server->error, 'ACL test not found', ' and returns the right error'); -is ($server->acl_remove ('test', 'krb5', $user1), undef, - 'Removing from a nonexistent ACL fails'); -is ($server->error, 'ACL test not found', ' and returns the right error'); -is ($server->acl_remove ('empty', 'krb5', $user2), undef, - ' and removing an entry not there fails'); -is ($server->error, - "cannot remove krb5:$user2 from 6: entry not found in ACL", - ' and returns the right error'); -is ($server->acl_show ('empty'), - "Members of ACL empty (id: 6) are:\n krb5 $user1\n", - ' and show returns the correct status'); -is ($server->acl_remove ('empty', 'krb5', $user1), 1, - ' but removing a good one works'); -is ($server->acl_remove ('empty', 'krb5', $user1), undef, - ' but does not work twice'); -is ($server->error, - "cannot remove krb5:$user1 from 6: entry not found in ACL", - ' and returns the right error'); -is ($server->acl_show ('empty'), "Members of ACL empty (id: 6) are:\n", - ' and show returns the correct status'); - -# Make sure we can't cripple the ADMIN ACL. -is ($server->acl_destroy ('ADMIN'), undef, 'Cannot destroy the ADMIN ACL'); -is ($server->error, 'cannot destroy the ADMIN ACL', ' with the right error'); -is ($server->acl_rename ('ADMIN', 'foo'), undef, ' or rename it'); -is ($server->error, 'cannot rename the ADMIN ACL', ' with the right error'); -is ($server->acl_remove ('ADMIN', 'krb5', $admin), undef, - ' or remove its last entry'); -is ($server->error, 'cannot remove last ADMIN ACL entry', - ' with the right error'); -is ($server->acl_add ('ADMIN', 'krb5', $user1), 1, - ' but we can add another entry'); -is ($server->acl_remove ('ADMIN', 'krb5', $user1), 1, ' and then remove it'); -is ($server->acl_remove ('ADMIN', 'krb5', $user1), undef, - ' and remove a user not on it'); -is ($server->error, - "cannot remove krb5:$user1 from 1: entry not found in ACL", - ' and get the right error'); - -# Now, create a few objects to use for testing and test the object API while -# we're at it. -is ($server->create ('base', 'service/admin'), 1, - 'Creating an object works'); -is ($server->create ('base', 'service/admin'), undef, ' but not twice'); -like ($server->error, qr{^cannot create object base:service/admin: }, - ' and returns the right error'); -is ($server->check ('base', 'service/admin'), 1, ' and check works'); -is ($server->create ('srvtab', 'service.admin'), undef, - 'Creating an unknown object fails'); -is ($server->error, 'unknown object type srvtab', ' with the right error'); -is ($server->check ('srvtab', 'service.admin'), undef, ' and check fails'); -is ($server->error, 'unknown object type srvtab', ' with the right error'); -is ($server->create ('', 'service.admin'), undef, - ' and likewise with an empty type'); -is ($server->error, 'unknown object type ', ' with the right error'); -is ($server->create ('base', 'service/user1'), 1, - ' but we can create a base object'); -is ($server->create ('base', 'service/user2'), 1, ' and another'); -is ($server->create ('base', 'service/both'), 1, ' and another'); -is ($server->create ('base', 'service/test'), 1, ' and another'); -is ($server->create ('base', ''), undef, ' but not with an empty name'); -is ($server->error, 'invalid object name', ' with the right error'); -is ($server->destroy ('base', 'service/none'), undef, - 'Destroying an unknown object fails'); -is ($server->error, 'cannot find base:service/none', ' with the right error'); -is ($server->destroy ('srvtab', 'service/test'), undef, - ' and destroying an unknown type fails'); -is ($server->error, 'unknown object type srvtab', ' with a different error'); -is ($server->destroy ('base', 'service/test'), 1, - ' but destroying a good object works'); -is ($server->check ('base', 'service/test'), 0, - ' and now check says it is not there'); -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, - 'Retrieving expires on an unknown object fails'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->expires ('base', 'service/test', $now), undef, - ' and setting it also fails'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->expires ('base', 'service/admin'), undef, - 'Retrieving expires for the right object returns undef'); -is ($server->error, undef, ' but there is no error'); -is ($server->expires ('base', 'service/admin', $now), 1, - ' and we can set it'); -is ($server->expires ('base', 'service/admin'), $now, - ' and get the value back'); -is ($server->expires ('base', 'service/admin', ''), 1, ' and clear it'); -is ($server->expires ('base', 'service/admin'), undef, ' and now it is gone'); -is ($server->error, undef, ' and still no error'); - -# Test attributes. -is ($server->attr ('base', 'service/admin', 'foo'), undef, - 'Getting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but called the method'); -is ($server->attr ('base', 'service/admin', 'foo', 'foo'), undef, - ' and setting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' and called the method'); - -# Because we're admin, we should be able to show one of these objects, but we -# still shouldn't be able to get or store since there are no ACLs. -is ($server->show ('base', 'service/test'), undef, - 'Cannot show nonexistent object'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -my $show = $server->show ('base', 'service/admin'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/; -my $expected = <<"EOO"; - Type: base - Name: service/admin - Created by: $admin - Created from: $host - Created on: 0 -EOO -is ($show, $expected, ' but showing an existing object works'); -is ($server->get ('base', 'service/admin'), undef, 'Getting an object fails'); -is ($server->error, "$admin not authorized to get base:service/admin", - ' with the right error'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and storing the object also fails'); -is ($server->error, "$admin not authorized to store base:service/admin", - ' with the right error'); - -# Grant only the get ACL, which should give us partial permissions. -is ($server->acl ('base', 'service/test', 'get', 'ADMIN'), undef, - 'Setting ACL on unknown object fails'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->acl ('base', 'service/admin', 'foo', 'ADMIN'), undef, - ' as does setting an unknown ACL'); -is ($server->error, 'invalid ACL type foo', ' with the right error'); -is ($server->acl ('base', 'service/admin', 'get', 'test2'), undef, - ' as does setting it to an unknown ACL'); -is ($server->error, 'ACL test2 not found', ' with the right error'); -is ($server->acl ('base', 'service/admin', 'get', 'ADMIN'), 1, - ' but setting the right ACL works'); -$result = eval { $server->get ('base', 'service/admin') }; -is ($result, undef, 'Get still fails'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' but the method is called'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and storing the object still fails'); -is ($server->error, "$admin not authorized to store base:service/admin", - ' with the right error'); -is ($server->acl ('base', 'service/admin', 'get', ''), 1, - 'Clearing the ACL works'); -is ($server->get ('base', 'service/admin'), undef, ' and now get fails'); -is ($server->error, "$admin not authorized to get base:service/admin", - ' with the right error'); -is ($server->acl ('base', 'service/admin', 'store', 'ADMIN'), 1, - 'Setting the store ACL works'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and now store fails'); -is ($server->error, - "cannot store base:service/admin: object type is immutable", - ' with a different error message'); -is ($server->get ('base', 'service/admin'), undef, ' and get still fails'); -is ($server->error, "$admin not authorized to get base:service/admin", - ' with the right error'); -is ($server->acl ('base', 'service/admin', 'store', ''), 1, - 'Clearing the ACL works'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and storing the object now fails'); -is ($server->error, "$admin not authorized to store base:service/admin", - ' with the right error'); - -# Test manipulating the owner. -is ($server->owner ('base', 'service/test'), undef, - 'Owner of nonexistent object fails'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->owner ('base', 'service/test', 'ADMIN'), undef, - ' as does setting it'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->owner ('base', 'service/admin'), undef, - 'Owner of existing object is also undef'); -is ($server->error, undef, ' but there is no error'); -is ($server->owner ('base', 'service/admin', 'test2'), undef, - 'Setting it to an unknown ACL fails'); -is ($server->error, 'ACL test2 not found', ' with the right error'); -is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, - 'Setting it to ADMIN works'); -$result = eval { $server->get ('base', 'service/admin') }; -is ($result, undef, ' and get still fails'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' but the method is called'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and now store fails'); -is ($server->error, - "cannot store base:service/admin: object type is immutable", - ' with a different error message'); -is ($server->acl ('base', 'service/admin', 'get', 'empty'), 1, - 'Setting the get ACL succeeds'); -is ($server->get ('base', 'service/admin'), undef, ' and get now fails'); -is ($server->error, "$admin not authorized to get base:service/admin", - ' with the right error'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' but store fails'); -is ($server->error, - "cannot store base:service/admin: object type is immutable", - ' with the same error message'); -is ($server->acl ('base', 'service/admin', 'store', 'empty'), 1, - ' until we do the same thing with store'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and now store fails'); -is ($server->error, "$admin not authorized to store base:service/admin", - ' due to permissions'); -is ($server->acl ('base', 'service/admin', 'store', ''), 1, - 'Clearing the store ACL works'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and fixes that'); -is ($server->error, - "cannot store base:service/admin: object type is immutable", - ' since we are back to immutable'); -is ($server->owner ('base', 'service/admin', ''), 1, - ' but clearing the owner works'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and now store fails'); -is ($server->error, "$admin not authorized to store base:service/admin", - ' due to permissions again'); -is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, - ' and setting the owner again works'); - -# Test manipulating flags. -is ($server->flag_clear ('base', 'service/admin', 'locked'), undef, - 'Clearing an unset flag fails'); -is ($server->error, - "cannot clear flag locked on base:service/admin: flag not set", - ' with the right error'); -if ($server->flag_set ('base', 'service/admin', 'locked')) { - ok (1, ' but setting it works'); -} else { - is ($server->error, '', ' but setting it works'); -} -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' now store fails'); -is ($server->error, 'cannot store base:service/admin: object is locked', - ' because the object is locked'); -is ($server->expires ('base', 'service/admin', ''), undef, - ' and expires fails'); -is ($server->error, 'cannot modify base:service/admin: object is locked', - ' because the object is locked'); -is ($server->owner ('base', 'service/admin', ''), undef, ' and owner fails'); -is ($server->error, 'cannot modify base:service/admin: object is locked', - ' because the object is locked'); -for my $acl (qw/get store show destroy flags/) { - is ($server->acl ('base', 'service/admin', $acl, ''), undef, - " and setting $acl ACL fails"); - is ($server->error, 'cannot modify base:service/admin: object is locked', - ' for the same reason'); -} -is ($server->flag_clear ('base', 'service/admin', 'locked'), 1, - ' and then clearing it works'); -is ($server->owner ('base', 'service/admin', ''), 1, - ' and then clearing owner works'); -is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, - ' and setting unchanging works'); -is ($server->flag_clear ('base', 'service/admin', 'locked'), undef, - ' and clearing locked still does not'); -is ($server->error, - "cannot clear flag locked on base:service/admin: flag not set", - ' with the right error'); -is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, - ' and clearing unchanging works'); - -# Test history. -$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) - by $admin from $host -DATE set acl_get to ADMIN (1) - by $admin from $host -DATE unset acl_get (was ADMIN (1)) - by $admin from $host -DATE set acl_store to ADMIN (1) - by $admin from $host -DATE unset acl_store (was ADMIN (1)) - by $admin from $host -DATE set owner to ADMIN (1) - by $admin from $host -DATE set acl_get to empty (6) - by $admin from $host -DATE set acl_store to empty (6) - by $admin from $host -DATE unset acl_store (was empty (6)) - by $admin from $host -DATE unset owner (was ADMIN (1)) - by $admin from $host -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 ADMIN (1)) - by $admin from $host -DATE set flag unchanging - by $admin from $host -DATE clear flag unchanging - by $admin from $host -EOO -my $seen = $server->history ('base', 'service/admin'); -$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($seen, $history, 'History for service/admin is correct'); - -# Now let's set up some additional ACLs for future tests. -is ($server->owner ('base', 'service/user1', 'user1'), 1, 'Set user1 owner'); -is ($server->owner ('base', 'service/user2', 'user2'), 1, 'Set user2 owner'); -is ($server->owner ('base', 'service/both', 'both'), 1, 'Set both owner'); -is ($server->acl ('base', 'service/both', 'show', 'user1'), 1, ' and show'); -is ($server->acl ('base', 'service/both', 'destroy', 'user2'), 1, - ' and destroy'); -is ($server->acl ('base', 'service/both', 'flags', 'user1'), 1, ' and flags'); -is ($server->acl ('base', 'service/admin', 'store', 'user1'), 1, - 'Set admin store'); - -# Okay, now we can switch users and be sure we don't have admin rights. -$server = eval { Wallet::Server->new ($user1, $host) }; -is ($@, '', 'Switching users works'); -is ($server->acl_create ('new'), undef, ' and now we cannot create ACLs'); -is ($server->error, "$user1 not authorized to create ACL", ' with error'); -is ($server->acl_rename ('user1', 'alice'), undef, ' or rename ACLs'); -is ($server->error, "$user1 not authorized to rename ACL user1", - ' with error'); -is ($server->acl_show ('user1'), undef, ' or show ACLs'); -is ($server->error, "$user1 not authorized to show ACL user1", ' with error'); -is ($server->acl_history ('user1'), undef, ' or see history for ACLs'); -is ($server->error, "$user1 not authorized to see history of ACL user1", - ' with error'); -is ($server->acl_destroy ('user2'), undef, ' or destroy ACLs'); -is ($server->error, "$user1 not authorized to destroy ACL user2", - ' with error'); -is ($server->acl_add ('user1', 'krb5', $user2), undef, ' or add to ACLs'); -is ($server->error, "$user1 not authorized to add to ACL user1", - ' with error'); -is ($server->acl_remove ('user1', 'krb5', $user1), undef, - ' or remove from ACLs'); -is ($server->error, "$user1 not authorized to remove from ACL user1", - ' with error'); -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->owner ('base', 'service/user1', 'user2'), undef, - ' or set the owner'); -is ($server->error, - "$user1 not authorized to set owner for base:service/user1", - ' with error'); -is ($server->expires ('base', 'service/user1', $now), undef, - ' or set expires'); -is ($server->error, - "$user1 not authorized to set expires for base:service/user1", - ' with error'); -is ($server->acl ('base', 'service/user1', 'get', 'user1'), undef, - ' or set an ACL'); -is ($server->error, - "$user1 not authorized to set ACL for base:service/user1", - ' with error'); -is ($server->flag_set ('base', 'service/user1', 'unchanging'), undef, - ' or set flags'); -is ($server->error, - "$user1 not authorized to set flags for base:service/user1", - ' with error'); -is ($server->flag_clear ('base', 'service/user1', 'unchanging'), undef, - ' or clear flags'); -is ($server->error, - "$user1 not authorized to set flags for base:service/user1", - ' with error'); - -# However, we can perform object actions on things we own. -$result = eval { $server->get ('base', 'service/user1') }; -is ($result, undef, 'We can get an object we own'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' and the method is called'); -is ($server->store ('base', 'service/user1', 'stuff'), undef, - ' or store an object we own'); -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 - -Members of ACL user1 (id: 2) are: - krb5 $user1 -EOO -is ($show, $expected, ' and show an object we own'); -$history = <<"EOO"; -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; -is ($seen, $history, ' and see history for an object we own'); -is ($server->attr ('base', 'service/user1', 'foo'), undef, - ' and getting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but calls the method'); -is ($server->attr ('base', 'service/user1', 'foo', 'foo'), undef, - ' and setting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but calls the method'); - -# But not on things we don't own. -is ($server->get ('base', 'service/user2'), undef, - 'But we cannot get an object we do not own'); -is ($server->error, "$user1 not authorized to get base:service/user2", - ' with the right error'); -is ($server->store ('base', 'service/user2', 'stuff'), undef, - ' or store it'); -is ($server->error, "$user1 not authorized to store base:service/user2", - ' with the right error'); -is ($server->show ('base', 'service/user2'), undef, ' or show it'); -is ($server->error, "$user1 not authorized to show base:service/user2", - ' with the right error'); -is ($server->history ('base', 'service/user2'), undef, - ' or see history for it'); -is ($server->error, "$user1 not authorized to show base:service/user2", - ' with the right error'); -is ($server->attr ('base', 'service/user2', 'foo'), undef, - ' or get attributes'); -is ($server->error, - "$user1 not authorized to get attributes for base:service/user2", - ' with the right error'); -is ($server->attr ('base', 'service/user2', 'foo', ''), undef, - ' and set attributes'); -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') }; -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->store ('base', 'service/both', 'stuff'), undef, - ' or store an object we jointly own'); -is ($server->error, - "cannot store base:service/both: object type is immutable", - ' and the method is called'); -is ($server->flag_set ('base', 'service/both', 'unchanging'), 1, - ' and set flags on an object we have an ACL'); -is ($server->flag_set ('base', 'service/both', 'locked'), 1, ' both flags'); -$show = $server->show ('base', 'service/both'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; -$expected = <<"EOO"; - Type: base - Name: service/both - Owner: both - Show ACL: user1 - Destroy ACL: user2 - Flags ACL: user1 - Flags: locked unchanging - Created by: $admin - Created from: $host - Created on: 0 - -Members of ACL both (id: 4) are: - krb5 $user1 - krb5 $user2 - -Members of ACL user1 (id: 2) are: - krb5 $user1 - -Members of ACL user2 (id: 3) are: - krb5 $user2 -EOO -is ($show, $expected, ' and show an object we jointly own'); -$history = <<"EOO"; -DATE create - by $admin from $host -DATE set owner to both (4) - by $admin from $host -DATE set acl_show to user1 (2) - by $admin from $host -DATE set acl_destroy to user2 (3) - by $admin from $host -DATE set acl_flags to user1 (2) - by $admin from $host -DATE set flag unchanging - by $user1 from $host -DATE set flag locked - by $user1 from $host -EOO -$seen = $server->history ('base', 'service/both'); -$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($seen, $history, ' and see history for an object we jointly own'); -is ($server->store ('base', 'service/both', 'stuff'), undef, - ' but not store data'); -is ($server->error, 'cannot store base:service/both: object is locked', - ' when the object is locked'); -is ($server->flag_clear ('base', 'service/both', 'locked'), 1, - ' and clear flags'); -is ($server->destroy ('base', 'service/both'), undef, - ' but not destroy it'); -is ($server->error, "$user1 not authorized to destroy base:service/both", - ' due to permissions'); -is ($server->attr ('base', 'service/both', 'foo'), undef, - 'Getting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but calls the method'); -is ($server->attr ('base', 'service/both', 'foo', ''), undef, - ' and setting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but calls the method'); -is ($server->attr ('base', 'service/admin', 'foo', ''), undef, - ' but setting an attribute on service/admin fails'); -is ($server->error, 'unknown attribute foo', ' and calls the method'); -is ($server->attr ('base', 'service/admin', 'foo'), undef, - ' while getting an attribute on service/admin fails'); -is ($server->error, - "$user1 not authorized to get attributes for base:service/admin", - ' with a permission error'); - -# Now switch to the other user and make sure we can do things on objects we -# own. -$server = eval { Wallet::Server->new ($user2, $host) }; -is ($@, '', 'Switching users works'); -$result = eval { $server->get ('base', 'service/user2') }; -is ($result, undef, 'We can get an object we own'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' and the method is called'); -is ($server->store ('base', 'service/user2', 'stuff'), undef, - ' or store an object we own'); -is ($server->error, - "cannot store base:service/user2: object type is immutable", - ' and the method is called'); -$show = $server->show ('base', 'service/user2'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; -$expected = <<"EOO"; - Type: base - Name: service/user2 - Owner: user2 - Created by: $admin - Created from: $host - Created on: 0 - -Members of ACL user2 (id: 3) are: - krb5 $user2 -EOO -is ($show, $expected, ' and show an object we own'); -$history = <<"EOO"; -DATE create - by $admin from $host -DATE set owner to user2 (3) - by $admin from $host -EOO -$seen = $server->history ('base', 'service/user2'); -$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($seen, $history, ' and see history for an object we own'); - -# But not on things we don't own. -is ($server->get ('base', 'service/user1'), undef, - 'But we cannot get an object we do not own'); -is ($server->error, "$user2 not authorized to get base:service/user1", - ' with the right error'); -is ($server->store ('base', 'service/user1', 'stuff'), undef, - ' or store it'); -is ($server->error, "$user2 not authorized to store base:service/user1", - ' with the right error'); -is ($server->show ('base', 'service/user1'), undef, ' or show it'); -is ($server->error, "$user2 not authorized to show base:service/user1", - ' with the right error'); -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'); - -# 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", - ' and the method is called'); -is ($server->store ('base', 'service/both', 'stuff'), undef, - ' or store an object we jointly own'); -is ($server->error, - "cannot store base:service/both: object type is immutable", - ' and the method is called'); -is ($server->show ('base', 'service/both'), undef, ' but we cannot show it'); -is ($server->error, "$user2 not authorized to show base:service/both", - ' with the right error'); -is ($server->history ('base', 'service/both'), undef, - ' or see history for it'); -is ($server->error, "$user2 not authorized to show base:service/both", - ' with the right error'); -is ($server->flag_set ('base', 'service/both', 'locked'), undef, - ' or set flags on it'); -is ($server->error, - "$user2 not authorized to set flags for base:service/both", - ' with the right error'); -is ($server->flag_clear ('base', 'service/both', 'unchanging'), undef, - ' or clear flags on it'); -is ($server->error, - "$user2 not authorized to set flags for base:service/both", - ' with the right error'); -is ($server->attr ('base', 'service/both', 'foo'), undef, - ' or getting an attribute'); -is ($server->error, - "$user2 not authorized to get attributes for base:service/both", - ' with the right error'); -is ($server->attr ('base', 'service/both', 'foo', 'foo'), undef, - ' but setting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but calls the method'); -is ($server->destroy ('base', 'service/both'), 1, ' and we can destroy it'); -is ($server->get ('base', 'service/both'), undef, ' and now cannot get it'); -is ($server->error, 'cannot find base:service/both', ' because it is gone'); -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 -# a default owner of default (the same as the both ACL), $user1 to create -# service/default-both with a default owner of both (but a different -# definition than the existing ACL), and $user2 to create service/default-2 -# with a default owner of user2 (with the same definition as the existing -# ACL). -# -# Also add service/default-get and service/default-store to test auto-creation -# on get and store, and service/default-admin to test auto-creation when one -# is an admin. -package Wallet::Config; -sub default_owner { - my ($type, $name) = @_; - if ($type eq 'base' and $name eq 'service/default') { - return ('default', [ 'krb5', $user1 ], [ 'krb5', $user2 ]); - } elsif ($type eq 'base' and $name eq 'service/default-both') { - return ('both', [ 'krb5', $user1 ]); - } elsif ($type eq 'base' and $name eq 'service/default-2') { - return ('user2', [ 'krb5', $user2 ]); - } elsif ($type eq 'base' and $name eq 'service/default-get') { - return ('user2', [ 'krb5', $user2 ]); - } elsif ($type eq 'base' and $name eq 'service/default-store') { - return ('user2', [ 'krb5', $user2 ]); - } elsif ($type eq 'base' and $name eq 'service/default-admin') { - return ('auto-admin', [ 'krb5', $admin ]); - } elsif ($type eq 'base' and $name eq 'host/default') { - return ('auto-host', [ 'krb5', $admin ]); - } else { - return; - } -} -package main; - -# 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", - ' due to lack of authorization'); -is ($server->autocreate ('base', 'service/default'), 1, - ' but autocreation succeeds'); -is ($server->autocreate ('base', 'service/foo'), undef, - ' but not any object'); -is ($server->error, "$user2 not authorized to create base:service/foo", - ' with the right error'); -$show = $server->show ('base', 'service/default'); -if (defined $show) { - $show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; - $expected = <<"EOO"; - Type: base - Name: service/default - Owner: default - Created by: $user2 - Created from: $host - Created on: 0 - -Members of ACL default (id: 7) are: - krb5 $user1 - krb5 $user2 -EOO - is ($show, $expected, ' and the created object and ACL are correct'); -} else { - is ($server->error, undef, ' and the created object and ACL are correct'); -} - -# Try the other basic cases in default_owner. -is ($server->autocreate ('base', 'service/default-both'), undef, - 'Creating an object with an ACL mismatch fails'); -is ($server->error, "ACL both exists and doesn't match default", - ' with the right error'); -is ($server->autocreate ('base', 'service/default-2'), 1, - 'Creating an object with an existing ACL works'); -$show = $server->show ('base', 'service/default-2'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; -$expected = <<"EOO"; - Type: base - Name: service/default-2 - Owner: user2 - Created by: $user2 - Created from: $host - Created on: 0 - -Members of ACL user2 (id: 3) are: - krb5 $user2 -EOO -is ($show, $expected, ' and the created object and ACL are correct'); - -# Auto-creation does not work on get or store; this is done by the client. -$result = eval { $server->get ('base', 'service/default-get') }; -is ($result, undef, 'Auto-creation on get fails'); -is ($@, '', ' does not die'); -is ($server->error, 'cannot find base:service/default-get', - ' and fails with the right error'); -is ($server->store ('base', 'service/default-store', 'stuff'), undef, - 'Auto-creation on store fails'); -is ($server->error, 'cannot find base:service/default-store', - ' with the right error'); - -# Switch back to admin to test auto-creation. -$server = eval { Wallet::Server->new ($admin, $host) }; -is ($@, '', 'Switching users back to admin works'); -is ($server->autocreate ('base', 'service/default-admin'), 1, - 'Autocreation works for admin'); -$show = $server->show ('base', 'service/default-admin'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; -$expected = <<"EOO"; - Type: base - Name: service/default-admin - Owner: auto-admin - Created by: $admin - Created from: $host - Created on: 0 - -Members of ACL auto-admin (id: 8) are: - krb5 $admin -EOO -is ($show, $expected, ' and the created object and ACL are correct'); -is ($server->destroy ('base', 'service/default-admin'), 1, - ' and we can destroy it'); - -# Test naming enforcement. Permit any base service/* name, but only permit -# base host/* if the host is fully qualified and ends in .example.edu. -package Wallet::Config; -sub verify_name { - my ($type, $name) = @_; - if ($type eq 'base' and $name =~ m,^service/,) { - return; - } elsif ($type eq 'base' and $name =~ m,^host/(.*),) { - my $host = $1; - return "host $host must be fully qualified (add .example.edu)" - unless $host =~ /\./; - return "host $host not in .example.edu domain" - unless $host =~ /\.example\.edu$/; - return; - } else { - return; - } -} -package main; - -# Recreate service/default-admin, which should succeed, and then try the -# various host/* principals. -is ($server->create ('base', 'service/default-admin'), 1, - 'Creating default/admin succeeds'); -if ($server->create ('base', 'host/default.example.edu')) { - ok (1, ' as does creating host/default.example.edu'); -} else { - is ($server->error, '', ' as does creating host/default.example.edu'); -} -is ($server->destroy ('base', 'service/default-admin'), 1, - ' and destroying default-admin works'); -is ($server->destroy ('base', 'host/default.example.edu'), 1, - ' and destroying host/default.example.edu works'); -is ($server->create ('base', 'host/default'), undef, - ' but an unqualified host fails'); -is ($server->error, 'base:host/default rejected: host default must be fully' - . ' qualified (add .example.edu)', ' with the right error'); -is ($server->create ('base', 'host/default.stanford.edu'), undef, - ' and a host in the wrong domain fails'); -is ($server->error, 'base:host/default.stanford.edu rejected: host' - . ' default.stanford.edu not in .example.edu domain', - ' with the right error'); -is ($server->autocreate ('base', 'service/default-admin'), 1, - 'Creating default/admin succeeds'); -is ($server->autocreate ('base', 'host/default'), undef, - ' but an unqualified host fails'); -is ($server->error, 'base:host/default rejected: host default must be fully' - . ' qualified (add .example.edu)', ' with the right error'); -is ($server->acl_show ('auto-host'), undef, ' and the ACL is not present'); -is ($server->error, 'ACL auto-host not found', ' with the right error'); -is ($server->autocreate ('base', 'host/default.stanford.edu'), undef, - ' and a host in the wrong domain fails'); -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'); - -# 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; -END { - unlink 'wallet-db'; -} - -# Now test handling of some configuration errors. -undef $Wallet::Config::DB_DRIVER; -$server = eval { Wallet::Server->new ($user2, $host) }; -is ($@, "database connection information not configured\n", - 'Fail if DB_DRIVER is not set'); -$Wallet::Config::DB_DRIVER = 'SQLite'; -undef $Wallet::Config::DB_INFO; -$server = eval { Wallet::Server->new ($user2, $host) }; -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/unable to open database file/, - ' or if the database connection fails'); diff --git a/perl/t/stanford-naming.t b/perl/t/stanford-naming.t deleted file mode 100755 index 555086c..0000000 --- a/perl/t/stanford-naming.t +++ /dev/null @@ -1,260 +0,0 @@ -#!/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, 2014 -# 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 => 101; - -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 afs/testcell.stanford.edu); - -# Various invalid keytab names. -my @INVALID_KEYTABS = qw(example host/example service/example.stanford.edu - thisistoolong/cgi not-valid/cgi unknown/example.stanford.edu - afs/testcell); - -# Various valid file names. -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 - 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 - 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 - 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 - 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/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'; -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 (@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"); -} - -# 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' -); - -# 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( - [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 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_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)) { - 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; -END { - unlink 'wallet-db'; -} diff --git a/perl/t/util/kadmin.t b/perl/t/util/kadmin.t new file mode 100755 index 0000000..8eabc6b --- /dev/null +++ b/perl/t/util/kadmin.t @@ -0,0 +1,117 @@ +#!/usr/bin/perl -w +# +# Tests for the kadmin object implementation. +# +# Written by Jon Robertson +# Copyright 2009, 2010, 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 34; + +BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } + +use Wallet::Admin; +use Wallet::Config; +use Wallet::Kadmin; +use Wallet::Kadmin::MIT; + +# Only load Wallet::Kadmin::Heimdal if a required module is found. +my $heimdal_kadm5 = 0; +eval 'use Heimdal::Kadm5'; +if (!$@) { + $heimdal_kadm5 = 1; + require Wallet::Kadmin::Heimdal; +} + +use lib 't/lib'; +use Util; + +# 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'); +$callback = sub { return 2 }; +$kadmin->fork_callback ($callback); +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. 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', 2 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 ($@, "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', 16 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 = '.'; + + # 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'); + 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. + 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'); + 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'); + is ($kadmin->exists ('wallet/one'), 0, ' and now it does not exist'); + 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%, + ' and the right error message is set'); + is ($kadmin->destroy ('wallet/one'), 1, ' and deleting it again works'); + + unlink 'krb5cc_test'; +} diff --git a/perl/t/verifier-ldap-attr.t b/perl/t/verifier-ldap-attr.t deleted file mode 100755 index d8e416b..0000000 --- a/perl/t/verifier-ldap-attr.t +++ /dev/null @@ -1,73 +0,0 @@ -#!/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, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More; - -use lib 't/lib'; -use Util; - -# 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'; -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", 9 - 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'); -} diff --git a/perl/t/verifier-netdb.t b/perl/t/verifier-netdb.t deleted file mode 100755 index d8fe561..0000000 --- a/perl/t/verifier-netdb.t +++ /dev/null @@ -1,45 +0,0 @@ -#!/usr/bin/perl -w -# -# 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, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 5; - -use Wallet::ACL::NetDB; - -use lib 't/lib'; -use Util; - -my $netdb = 'netdb-node-roles-rc.stanford.edu'; -my $host = 'windlord.stanford.edu'; -my $user = 'rra@stanford.edu'; - -# Determine the local principal. -my $klist = `klist 2>&1` || ''; -SKIP: { - skip "tests useful only with Stanford Kerberos tickets", 5 - unless ($klist =~ /^(Default p|\s+P)rincipal: \S+\@stanford\.edu$/m); - - # Set up our configuration. - $Wallet::Config::NETDB_REALM = 'stanford.edu'; - $Wallet::Config::NETDB_REMCTL_CACHE = $ENV{KRB5CCNAME}; - $Wallet::Config::NETDB_REMCTL_HOST = $netdb; - - # Finally, we can test. - $verifier = eval { Wallet::ACL::NetDB->new }; - ok (defined $verifier, ' and now creation succeeds'); - is ($@, q{}, ' with no errors'); - ok ($verifier->isa ('Wallet::ACL::NetDB'), ' and returns the right class'); - is ($verifier->check ($user, $host), 1, "Checking $host succeeds"); - is ($verifier->check ('test-user@stanford.edu', $host), 0, - ' but fails with another user'); -} diff --git a/perl/t/verifier.t b/perl/t/verifier.t deleted file mode 100755 index 5697ae6..0000000 --- a/perl/t/verifier.t +++ /dev/null @@ -1,155 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the basic wallet ACL verifiers. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -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; - -use lib 't/lib'; -use Util; - -my $verifier = Wallet::ACL::Base->new; -ok (defined $verifier, 'Wallet::ACL::Base creation'); -ok ($verifier->isa ('Wallet::ACL::Base'), ' and class verification'); -is ($verifier->check ('eagle@eyrie.org', 'eagle@eyrie.org'), 0, - 'Default check declines'); -is ($verifier->error, undef, 'No error set'); - -$verifier = Wallet::ACL::Krb5->new; -ok (defined $verifier, 'Wallet::ACL::Krb5 creation'); -ok ($verifier->isa ('Wallet::ACL::Krb5'), ' and class verification'); -is ($verifier->check ('eagle@eyrie.org', 'eagle@eyrie.org'), 1, - 'Simple check'); -is ($verifier->check ('eagle@eyrie.org', 'thoron@stanford.edu'), 0, - 'Simple failure'); -is ($verifier->error, undef, 'No error set'); -is ($verifier->check (undef, 'eagle@eyrie.org'), undef, - 'Undefined principal'); -is ($verifier->error, 'no principal specified', ' and right error'); -is ($verifier->check ('eagle@eyrie.org', ''), 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 ('eagle@eyrie.org', ''), undef, 'Empty ACL'); -is ($verifier->error, 'no ACL specified', ' and right error'); -is ($verifier->check ('eagle@eyrie.org', '(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: { - skip 'no keytab configuration', 34 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', 34 unless $remctld; - eval { require Net::Remctl }; - skip 'Net::Remctl not available', 34 if $@; - - # Set up our configuration. - $Wallet::Config::NETDB_REALM = 'EXAMPLE.COM'; - my $principal = contents ('t/data/test.principal'); - - # Now spawn our remctld server and get a ticket cache. - unlink ('krb5cc_test', 'test-acl', 'test-pid'); - remctld_spawn ($remctld, $principal, 't/data/test.keytab', - 't/data/netdb.conf'); - $ENV{KRB5CCNAME} = 'krb5cc_test'; - getcreds ('t/data/test.keytab', $principal); - - # Finally, we can test. - my $verifier = eval { Wallet::ACL::NetDB->new }; - is ($verifier, undef, 'Constructor fails without configuration'); - is ($@, "NetDB ACL support not configured\n", ' with the right exception'); - $Wallet::Config::NETDB_REMCTL_CACHE = 'krb5cc_test'; - $verifier = eval { Wallet::ACL::NetDB->new }; - is ($verifier, undef, ' and still fails without host'); - is ($@, "NetDB ACL support not configured\n", ' with the right exception'); - $Wallet::Config::NETDB_REMCTL_HOST = 'localhost'; - $Wallet::Config::NETDB_REMCTL_PRINCIPAL = $principal; - $Wallet::Config::NETDB_REMCTL_PORT = 14373; - $verifier = eval { Wallet::ACL::NetDB->new }; - ok (defined $verifier, ' and now creation succeeds'); - ok ($verifier->isa ('Wallet::ACL::NetDB'), ' and returns the right class'); - is ($verifier->check ('test-user', 'all'), undef, - ' but verification fails without an ACL'); - is ($verifier->error, 'cannot check NetDB ACL: Access denied', - ' with the right error'); - - # Create an ACL so that tests will start working. - open (ACL, '>', 'test-acl') or die "cannot create test-acl: $!\n"; - print ACL "$principal\n"; - close ACL; - is ($verifier->check ('test-user', 'all'), 1, - ' and now verification works'); - - # Test the successful verifications. - for my $node (qw/admin team user/) { - is ($verifier->check ('test-user', $node), 1, - "Verification succeeds for $node"); - } - - # Test various failures. - is ($verifier->check ('test-user', 'unknown'), 0, - 'Verification fails for unknown'); - is ($verifier->check ('test-user', 'none'), 0, ' and for none'); - is ($verifier->check (undef, 'all'), undef, - 'Undefined principal'); - is ($verifier->error, 'no principal specified', ' and right error'); - is ($verifier->check ('test-user', ''), undef, 'Empty ACL'); - is ($verifier->error, 'malformed netdb ACL', ' and right error'); - is ($verifier->check ('error', 'normal'), undef, 'Regular error'); - is ($verifier->error, 'error checking NetDB ACL: some error', - ' and correct error return'); - is ($verifier->check ('error', 'status'), undef, 'Status-only error'); - is ($verifier->error, 'error checking NetDB ACL', ' and correct error'); - is ($verifier->check ('unknown', 'unknown'), undef, 'Unknown node'); - is ($verifier->error, - 'error checking NetDB ACL: Unknown principal unknown', - ' and correct error'); - - # Test the Wallet::ACL::NetDB::Root subclass. We don't retest shared code - # (kind of grey-box of us), just the changed check behavior. - $verifier = eval { Wallet::ACL::NetDB::Root->new }; - if (defined $verifier) { - ok (1, 'Wallet::ACL::NetDB::Root creation succeeds'); - } else { - is ($@, '', 'Wallet::ACL::NetDB::Root creation succeeds'); - } - ok ($verifier->isa ('Wallet::ACL::NetDB::Root'), - ' and returns the right class'); - for my $node (qw/admin team user/) { - is ($verifier->check ('test-user', $node), 0, - "Verification fails for non-root user for $node"); - } - for my $node (qw/admin team user/) { - is ($verifier->check ('test-user/root', $node), 1, - "Verification succeeds for root user for $node"); - } - is ($verifier->check (undef, 'all'), undef, - 'Undefined principal'); - is ($verifier->error, 'no principal specified', ' and right error'); - - remctld_stop; - unlink ('krb5cc_test', 'test-acl', 'test-pid'); -} diff --git a/perl/t/verifier/basic.t b/perl/t/verifier/basic.t new file mode 100755 index 0000000..5697ae6 --- /dev/null +++ b/perl/t/verifier/basic.t @@ -0,0 +1,155 @@ +#!/usr/bin/perl -w +# +# Tests for the basic wallet ACL verifiers. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2010, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +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; + +use lib 't/lib'; +use Util; + +my $verifier = Wallet::ACL::Base->new; +ok (defined $verifier, 'Wallet::ACL::Base creation'); +ok ($verifier->isa ('Wallet::ACL::Base'), ' and class verification'); +is ($verifier->check ('eagle@eyrie.org', 'eagle@eyrie.org'), 0, + 'Default check declines'); +is ($verifier->error, undef, 'No error set'); + +$verifier = Wallet::ACL::Krb5->new; +ok (defined $verifier, 'Wallet::ACL::Krb5 creation'); +ok ($verifier->isa ('Wallet::ACL::Krb5'), ' and class verification'); +is ($verifier->check ('eagle@eyrie.org', 'eagle@eyrie.org'), 1, + 'Simple check'); +is ($verifier->check ('eagle@eyrie.org', 'thoron@stanford.edu'), 0, + 'Simple failure'); +is ($verifier->error, undef, 'No error set'); +is ($verifier->check (undef, 'eagle@eyrie.org'), undef, + 'Undefined principal'); +is ($verifier->error, 'no principal specified', ' and right error'); +is ($verifier->check ('eagle@eyrie.org', ''), 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 ('eagle@eyrie.org', ''), undef, 'Empty ACL'); +is ($verifier->error, 'no ACL specified', ' and right error'); +is ($verifier->check ('eagle@eyrie.org', '(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: { + skip 'no keytab configuration', 34 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', 34 unless $remctld; + eval { require Net::Remctl }; + skip 'Net::Remctl not available', 34 if $@; + + # Set up our configuration. + $Wallet::Config::NETDB_REALM = 'EXAMPLE.COM'; + my $principal = contents ('t/data/test.principal'); + + # Now spawn our remctld server and get a ticket cache. + unlink ('krb5cc_test', 'test-acl', 'test-pid'); + remctld_spawn ($remctld, $principal, 't/data/test.keytab', + 't/data/netdb.conf'); + $ENV{KRB5CCNAME} = 'krb5cc_test'; + getcreds ('t/data/test.keytab', $principal); + + # Finally, we can test. + my $verifier = eval { Wallet::ACL::NetDB->new }; + is ($verifier, undef, 'Constructor fails without configuration'); + is ($@, "NetDB ACL support not configured\n", ' with the right exception'); + $Wallet::Config::NETDB_REMCTL_CACHE = 'krb5cc_test'; + $verifier = eval { Wallet::ACL::NetDB->new }; + is ($verifier, undef, ' and still fails without host'); + is ($@, "NetDB ACL support not configured\n", ' with the right exception'); + $Wallet::Config::NETDB_REMCTL_HOST = 'localhost'; + $Wallet::Config::NETDB_REMCTL_PRINCIPAL = $principal; + $Wallet::Config::NETDB_REMCTL_PORT = 14373; + $verifier = eval { Wallet::ACL::NetDB->new }; + ok (defined $verifier, ' and now creation succeeds'); + ok ($verifier->isa ('Wallet::ACL::NetDB'), ' and returns the right class'); + is ($verifier->check ('test-user', 'all'), undef, + ' but verification fails without an ACL'); + is ($verifier->error, 'cannot check NetDB ACL: Access denied', + ' with the right error'); + + # Create an ACL so that tests will start working. + open (ACL, '>', 'test-acl') or die "cannot create test-acl: $!\n"; + print ACL "$principal\n"; + close ACL; + is ($verifier->check ('test-user', 'all'), 1, + ' and now verification works'); + + # Test the successful verifications. + for my $node (qw/admin team user/) { + is ($verifier->check ('test-user', $node), 1, + "Verification succeeds for $node"); + } + + # Test various failures. + is ($verifier->check ('test-user', 'unknown'), 0, + 'Verification fails for unknown'); + is ($verifier->check ('test-user', 'none'), 0, ' and for none'); + is ($verifier->check (undef, 'all'), undef, + 'Undefined principal'); + is ($verifier->error, 'no principal specified', ' and right error'); + is ($verifier->check ('test-user', ''), undef, 'Empty ACL'); + is ($verifier->error, 'malformed netdb ACL', ' and right error'); + is ($verifier->check ('error', 'normal'), undef, 'Regular error'); + is ($verifier->error, 'error checking NetDB ACL: some error', + ' and correct error return'); + is ($verifier->check ('error', 'status'), undef, 'Status-only error'); + is ($verifier->error, 'error checking NetDB ACL', ' and correct error'); + is ($verifier->check ('unknown', 'unknown'), undef, 'Unknown node'); + is ($verifier->error, + 'error checking NetDB ACL: Unknown principal unknown', + ' and correct error'); + + # Test the Wallet::ACL::NetDB::Root subclass. We don't retest shared code + # (kind of grey-box of us), just the changed check behavior. + $verifier = eval { Wallet::ACL::NetDB::Root->new }; + if (defined $verifier) { + ok (1, 'Wallet::ACL::NetDB::Root creation succeeds'); + } else { + is ($@, '', 'Wallet::ACL::NetDB::Root creation succeeds'); + } + ok ($verifier->isa ('Wallet::ACL::NetDB::Root'), + ' and returns the right class'); + for my $node (qw/admin team user/) { + is ($verifier->check ('test-user', $node), 0, + "Verification fails for non-root user for $node"); + } + for my $node (qw/admin team user/) { + is ($verifier->check ('test-user/root', $node), 1, + "Verification succeeds for root user for $node"); + } + is ($verifier->check (undef, 'all'), undef, + 'Undefined principal'); + is ($verifier->error, 'no principal specified', ' and right error'); + + remctld_stop; + unlink ('krb5cc_test', 'test-acl', 'test-pid'); +} diff --git a/perl/t/verifier/ldap-attr.t b/perl/t/verifier/ldap-attr.t new file mode 100755 index 0000000..d8e416b --- /dev/null +++ b/perl/t/verifier/ldap-attr.t @@ -0,0 +1,73 @@ +#!/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, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More; + +use lib 't/lib'; +use Util; + +# 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'; +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", 9 + 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'); +} diff --git a/perl/t/verifier/netdb.t b/perl/t/verifier/netdb.t new file mode 100755 index 0000000..d8fe561 --- /dev/null +++ b/perl/t/verifier/netdb.t @@ -0,0 +1,45 @@ +#!/usr/bin/perl -w +# +# 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, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 5; + +use Wallet::ACL::NetDB; + +use lib 't/lib'; +use Util; + +my $netdb = 'netdb-node-roles-rc.stanford.edu'; +my $host = 'windlord.stanford.edu'; +my $user = 'rra@stanford.edu'; + +# Determine the local principal. +my $klist = `klist 2>&1` || ''; +SKIP: { + skip "tests useful only with Stanford Kerberos tickets", 5 + unless ($klist =~ /^(Default p|\s+P)rincipal: \S+\@stanford\.edu$/m); + + # Set up our configuration. + $Wallet::Config::NETDB_REALM = 'stanford.edu'; + $Wallet::Config::NETDB_REMCTL_CACHE = $ENV{KRB5CCNAME}; + $Wallet::Config::NETDB_REMCTL_HOST = $netdb; + + # Finally, we can test. + $verifier = eval { Wallet::ACL::NetDB->new }; + ok (defined $verifier, ' and now creation succeeds'); + is ($@, q{}, ' with no errors'); + ok ($verifier->isa ('Wallet::ACL::NetDB'), ' and returns the right class'); + is ($verifier->check ($user, $host), 1, "Checking $host succeeds"); + is ($verifier->check ('test-user@stanford.edu', $host), 0, + ' but fails with another user'); +} diff --git a/perl/t/wa-keyring.t b/perl/t/wa-keyring.t deleted file mode 100755 index 8d8e1fe..0000000 --- a/perl/t/wa-keyring.t +++ /dev/null @@ -1,184 +0,0 @@ -#!/usr/bin/perl -# -# Tests for the WebAuth keyring object implementation. -# -# Written by Russ Allbery -# Copyright 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use strict; -use warnings; - -use Test::More; - -BEGIN { - eval 'use WebAuth 3.06 qw(WA_KEY_AES WA_AES_128)'; - plan skip_all => 'WebAuth 3.06 required for testing wa-keyring' - if $@; -} - -use POSIX qw(strftime); -use WebAuth::Key 1.01 (); -use WebAuth::Keyring 1.02 (); - -BEGIN { - plan tests => 68; - 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 $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', $schema, @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', $schema, @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', $schema, @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', $schema, @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; -END { - unlink ('wallet-db'); -} -- cgit v1.2.3