diff options
Diffstat (limited to 'perl/t/general')
| -rwxr-xr-x | perl/t/general/acl.t | 232 | ||||
| -rwxr-xr-x | perl/t/general/admin.t | 106 | ||||
| -rwxr-xr-x | perl/t/general/config.t | 44 | ||||
| -rwxr-xr-x | perl/t/general/init.t | 58 | ||||
| -rwxr-xr-x | perl/t/general/report.t | 330 | ||||
| -rwxr-xr-x | perl/t/general/server.t | 1040 |
6 files changed, 1810 insertions, 0 deletions
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 <eagle@eyrie.org> +# 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 <eagle@eyrie.org> +# 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 <eagle@eyrie.org> +# 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 <eagle@eyrie.org> +# 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 <eagle@eyrie.org> +# 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 <eagle@eyrie.org> +# 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'); |