path: root/perl/t/general/server.t

#!/usr/bin/perl
#
# 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 strict;
use warnings;

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.
my $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');
is ($server->acl_history ('ADMIN'), '', ' and initial history is empty');
is ($server->acl_history (1), '', ' 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');
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
EOO
my $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');