summaryrefslogtreecommitdiff
path: root/perl
diff options
context:
space:
mode:
authorBill MacAllister <whm@dropbox.com>2015-12-18 21:54:52 +0000
committerBill MacAllister <whm@dropbox.com>2015-12-18 21:54:52 +0000
commitf61bff40b0c76b01b89f8b977eb27fdef9409c2a (patch)
tree9812f0b1c38e001d6ddd8d7343adc40fa800e338 /perl
parent0eb853eb2ef7e7063c0219ce2cbd1e239d5579b7 (diff)
parent4a777845b06b62a6deb1df5e69cc9b21226c3c2f (diff)
Merge branch 'master' into ad-keytabs
Conflicts: NEWS
Diffstat (limited to 'perl')
-rw-r--r--perl/lib/Wallet/ACL.pm96
-rw-r--r--perl/lib/Wallet/ACL/Base.pm13
-rw-r--r--perl/lib/Wallet/ACL/LDAP/Attribute/Root.pm128
-rw-r--r--perl/lib/Wallet/ACL/Nested.pm189
-rw-r--r--perl/lib/Wallet/Admin.pm21
-rw-r--r--perl/lib/Wallet/Config.pm71
-rw-r--r--perl/lib/Wallet/Object/Base.pm9
-rw-r--r--perl/lib/Wallet/Object/Duo.pm121
-rw-r--r--perl/lib/Wallet/Object/Duo/LDAPProxy.pm202
-rw-r--r--perl/lib/Wallet/Object/Duo/PAM.pm205
-rw-r--r--perl/lib/Wallet/Object/Duo/RDP.pm204
-rw-r--r--perl/lib/Wallet/Object/Duo/RadiusProxy.pm204
-rw-r--r--perl/lib/Wallet/Object/Keytab.pm59
-rw-r--r--perl/lib/Wallet/Object/Password.pm228
-rw-r--r--perl/lib/Wallet/Policy/Stanford.pm144
-rw-r--r--perl/lib/Wallet/Report.pm232
-rw-r--r--perl/lib/Wallet/Schema.pm4
-rw-r--r--perl/lib/Wallet/Schema/Result/AclScheme.pm4
-rw-r--r--perl/lib/Wallet/Server.pm57
-rw-r--r--perl/sql/wallet-1.3-update-duo.sql9
-rwxr-xr-xperl/t/general/acl.t155
-rwxr-xr-xperl/t/general/report.t51
-rwxr-xr-xperl/t/general/server.t10
-rwxr-xr-xperl/t/object/base.t5
-rw-r--r--perl/t/object/duo-ldap.t21
-rw-r--r--perl/t/object/duo-pam.t20
-rw-r--r--perl/t/object/duo-radius.t21
-rw-r--r--perl/t/object/duo-rdp.t20
-rw-r--r--perl/t/object/password.t124
-rwxr-xr-xperl/t/policy/stanford.t329
-rwxr-xr-xperl/t/verifier/ldap-attr.t39
-rwxr-xr-xperl/t/verifier/nested.t84
32 files changed, 1944 insertions, 1135 deletions
diff --git a/perl/lib/Wallet/ACL.pm b/perl/lib/Wallet/ACL.pm
index a3b0146..862b88f 100644
--- a/perl/lib/Wallet/ACL.pm
+++ b/perl/lib/Wallet/ACL.pm
@@ -1,7 +1,7 @@
# Wallet::ACL -- Implementation of ACLs in the wallet system.
#
# Written by Russ Allbery <eagle@eyrie.org>
-# Copyright 2007, 2008, 2010, 2013, 2014
+# Copyright 2007, 2008, 2010, 2013, 2014, 2015
# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
@@ -17,13 +17,14 @@ use strict;
use warnings;
use vars qw($VERSION);
+use Wallet::Object::Base;
use DateTime;
use DBI;
# This version should be increased on any code change to this module. Always
# use two digits for the minor version with a leading zero if necessary so
# that it will sort properly.
-$VERSION = '0.08';
+$VERSION = '0.09';
##############################################################################
# Constructors
@@ -197,16 +198,55 @@ sub rename {
$acls->ac_name ($name);
$acls->update;
$self->log_acl ('rename', undef, undef, $user, $host, $time);
+
+ # Find any references to this being used as a nested verifier and
+ # update the name. This really breaks out of the normal flow, but
+ # it's hard to do otherwise.
+ %search = (ae_scheme => 'nested',
+ ae_identifier => $self->{name},
+ );
+ my @entries = $self->{schema}->resultset('AclEntry')->search(\%search);
+ for my $entry (@entries) {
+ $entry->ae_identifier ($name);
+ $entry->update;
+ }
+
$guard->commit;
};
if ($@) {
- $self->error ("cannot rename ACL $self->{id} to $name: $@");
+ $self->error ("cannot rename ACL $self->{name} to $name: $@");
return;
}
$self->{name} = $name;
return 1;
}
+# Moves everything owned by one ACL to instead be owned by another. You'll
+# normally want to use rename, but this exists for cases where the replacing
+# ACL already exists and has things assigned to it. Returns true on success,
+# false on failure.
+sub replace {
+ my ($self, $replace_id, $user, $host, $time) = @_;
+ $time ||= time;
+
+ my %search = (ob_owner => $self->{id});
+ my @objects = $self->{schema}->resultset('Object')->search (\%search);
+ if (@objects) {
+ for my $object (@objects) {
+ my $type = $object->ob_type;
+ my $name = $object->ob_name;
+ my $object = eval {
+ Wallet::Object::Base->new($type, $name, $self->{schema});
+ };
+ $object->owner ($replace_id, $user, $host, $time);
+ }
+ } else {
+ $self->error ("no objects found for ACL $self->{name}");
+ return;
+ }
+ return 1;
+}
+
# Destroy the ACL, deleting it out of the database. Returns true on success,
# false on failure.
#
@@ -233,8 +273,20 @@ sub destroy {
die "ACL in use by ".$entry->ob_type.":".$entry->ob_name;
}
+ # Also make certain the ACL isn't being nested in another.
+ my %search = (ae_scheme => 'nested',
+ ae_identifier => $self->{name});
+ my %options = (join => 'acls',
+ prefetch => 'acls');
+ @entries = $self->{schema}->resultset('AclEntry')->search(\%search,
+ \%options);
+ if (@entries) {
+ my ($entry) = @entries;
+ die "ACL is nested in ACL ".$entry->acls->ac_name;
+ }
+
# Delete any entries (there may or may not be any).
- my %search = (ae_id => $self->{id});
+ %search = (ae_id => $self->{id});
@entries = $self->{schema}->resultset('AclEntry')->search(\%search);
for my $entry (@entries) {
$entry->delete;
@@ -257,7 +309,7 @@ sub destroy {
$guard->commit;
};
if ($@) {
- $self->error ("cannot destroy ACL $self->{id}: $@");
+ $self->error ("cannot destroy ACL $self->{name}: $@");
return;
}
return 1;
@@ -275,6 +327,22 @@ sub add {
$self->error ("unknown ACL scheme $scheme");
return;
}
+
+ # Check to make sure that this entry has a valid name for the scheme.
+ my $class = $self->scheme_mapping ($scheme);
+ my $object = eval {
+ $class->new ($identifier, $self->{schema});
+ };
+ if ($@) {
+ $self->error ("cannot create ACL verifier: $@");
+ return;
+ }
+ unless ($object && $object->syntax_check ($identifier)) {
+ $self->error ("invalid ACL identifier $identifier for $scheme");
+ return;
+ };
+
+ # Actually create the scheme.
eval {
my $guard = $self->{schema}->txn_scope_guard;
my %record = (ae_id => $self->{id},
@@ -285,7 +353,7 @@ sub add {
$guard->commit;
};
if ($@) {
- $self->error ("cannot add $scheme:$identifier to $self->{id}: $@");
+ $self->error ("cannot add $scheme:$identifier to $self->{name}: $@");
return;
}
return 1;
@@ -312,7 +380,7 @@ sub remove {
};
if ($@) {
my $entry = "$scheme:$identifier";
- $self->error ("cannot remove $entry from $self->{id}: $@");
+ $self->error ("cannot remove $entry from $self->{name}: $@");
return;
}
return 1;
@@ -340,7 +408,7 @@ sub list {
$guard->commit;
};
if ($@) {
- $self->error ("cannot retrieve ACL $self->{id}: $@");
+ $self->error ("cannot retrieve ACL $self->{name}: $@");
return;
} else {
return @entries;
@@ -395,7 +463,7 @@ sub history {
$guard->commit;
};
if ($@) {
- $self->error ("cannot read history for $self->{id}: $@");
+ $self->error ("cannot read history for $self->{name}: $@");
return;
}
return $output;
@@ -419,7 +487,7 @@ sub history {
push (@{ $self->{check_errors} }, "unknown scheme $scheme");
return;
}
- $verifier{$scheme} = $class->new;
+ $verifier{$scheme} = $class->new ($identifier, $self->{schema});
unless (defined $verifier{$scheme}) {
push (@{ $self->{check_errors} }, "cannot verify $scheme");
return;
@@ -643,6 +711,14 @@ On failure, the caller should call error() to get the error message.
Note that rename() operations are not logged in the ACL history.
+=item replace(ID)
+
+Replace this ACL with another. This goes through each object owned by
+the ACL and changes its ownership to the new ACL, leaving this ACL owning
+nothing (and probably then needing to be deleted). Returns true on
+success and false on failure. On failure, the caller should call error()
+to get the error message.
+
=item show()
Returns a human-readable description of this ACL, including its
diff --git a/perl/lib/Wallet/ACL/Base.pm b/perl/lib/Wallet/ACL/Base.pm
index a2b07cc..19ca612 100644
--- a/perl/lib/Wallet/ACL/Base.pm
+++ b/perl/lib/Wallet/ACL/Base.pm
@@ -20,7 +20,7 @@ use vars qw($VERSION);
# This version should be increased on any code change to this module. Always
# use two digits for the minor version with a leading zero if necessary so
# that it will sort properly.
-$VERSION = '0.02';
+$VERSION = '0.03';
##############################################################################
# Interface
@@ -37,6 +37,11 @@ sub new {
return $self;
}
+# The default name check method allows any name.
+sub syntax_check {
+ return 1;
+}
+
# The default check method denies all access.
sub check {
return 0;
@@ -92,6 +97,12 @@ inherit from it. It is not used directly.
Creates a new ACL verifier. The generic function provided here just
creates and blesses an object.
+=item syntax_check(PRINCIPAL, ACL)
+
+This method should be overridden by any child classes that want to
+implement validating the name of an ACL before creation. The default
+implementation allows any name for an ACL.
+
=item check(PRINCIPAL, ACL)
This method should always be overridden by child classes. The default
diff --git a/perl/lib/Wallet/ACL/LDAP/Attribute/Root.pm b/perl/lib/Wallet/ACL/LDAP/Attribute/Root.pm
new file mode 100644
index 0000000..eb30931
--- /dev/null
+++ b/perl/lib/Wallet/ACL/LDAP/Attribute/Root.pm
@@ -0,0 +1,128 @@
+# Wallet::ACL::LDAP::Attribute::Root -- Wallet LDAP ACL verifier (root instances).
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# From Wallet::ACL::NetDB::Root by Russ Allbery <eagle@eyrie.org>
+# Copyright 2015
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::LDAP::Attribute::Root;
+require 5.006;
+
+use strict;
+use warnings;
+use vars qw(@ISA $VERSION);
+
+use Wallet::ACL::LDAP::Attribute;
+use Wallet::Config;
+
+@ISA = qw(Wallet::ACL::LDAP::Attribute);
+
+# This version should be increased on any code change to this module. Always
+# use two digits for the minor version with a leading zero if necessary so
+# that it will sort properly.
+$VERSION = '0.01';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# Override the check method of Wallet::ACL::LDAP::Attribute to require that
+# the principal be a root instance and to strip /root out of the principal
+# name before checking roles.
+sub check {
+ my ($self, $principal, $acl) = @_;
+ undef $self->{error};
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ unless ($principal =~ s%^([^/\@]+)/root(\@|\z)%$1$2%) {
+ return 0;
+ }
+ return $self->SUPER::check ($principal, $acl);
+}
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL Allbery LDAP verifier
+
+=head1 NAME
+
+Wallet::ACL::LDAP::Attribute::Root - Wallet ACL verifier for LDAP attributes (root instances)
+
+=head1 SYNOPSIS
+
+ my $verifier = Wallet::ACL::LDAP::Attribute::Root->new;
+ my $status = $verifier->check ($principal, "$attr=$value");
+ if (not defined $status) {
+ die "Something failed: ", $verifier->error, "\n";
+ } elsif ($status) {
+ print "Access granted\n";
+ } else {
+ print "Access denied\n";
+ }
+
+=head1 DESCRIPTION
+
+Wallet::ACL::LDAP::Attribute::Root works identically to
+Wallet::ACL::LDAP::Attribute except that it requires the principal to
+be a root instance (in other words, to be in the form
+<principal>/root@<realm>) and strips the C</root> portion from the
+principal before checking against the LDAP attribute and value. As
+with the base LDAP Attribute ACL verifier, the value of such a
+C<ldap-attr-root> ACL is an attribute followed by an equal sign and a
+value, and the ACL grants access to a given principal if and only if
+the LDAP entry for that principal (with C</root> stripped) has that
+attribute set to that value.
+
+To use this object, the same configuration parameters must be set as for
+Wallet::ACL::LDAP::Attribute. See Wallet::Config(3) for details on
+those configuration parameters and information about how to set wallet
+configuration.
+
+=head1 METHODS
+
+=over 4
+
+=item check(PRINCIPAL, ACL)
+
+Returns true if PRINCIPAL is granted access according to ACL, false if
+not, and undef on an error (see L<"DIAGNOSTICS"> below). ACL must be an
+attribute name and a value, separated by an equal sign (with no
+whitespace). PRINCIPAL will be granted access if it has an instance of
+C<root> and if (with C</root> stripped off) its LDAP entry contains
+that attribute with that value
+
+=back
+
+=head1 DIAGNOSTICS
+
+Same as for Wallet::ACL::LDAP::Attribute.
+
+=head1 CAVEATS
+
+The instance to strip is not currently configurable.
+
+=head1 SEE ALSO
+
+Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3),
+Wallet::ACL::LDAP::Attribute(3), Wallet::Config(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHORS
+
+Jon Robertson <jonrober@stanford.edu>
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/ACL/Nested.pm b/perl/lib/Wallet/ACL/Nested.pm
new file mode 100644
index 0000000..07833f8
--- /dev/null
+++ b/perl/lib/Wallet/ACL/Nested.pm
@@ -0,0 +1,189 @@
+# Wallet::ACL::Nested - ACL class for nesting ACLs
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2015
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::Nested;
+require 5.006;
+
+use strict;
+use warnings;
+use vars qw($VERSION @ISA);
+
+use Wallet::ACL::Base;
+
+@ISA = qw(Wallet::ACL::Base);
+
+# This version should be increased on any code change to this module. Always
+# use two digits for the minor version with a leading zero if necessary so
+# that it will sort properly.
+$VERSION = '0.01';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# Creates a new persistant verifier, taking a database handle to use for
+# syntax check validation.
+sub new {
+ my $type = shift;
+ my ($name, $schema) = @_;
+ my $self = {
+ schema => $schema,
+ expanded => {},
+ };
+ bless ($self, $type);
+ return $self;
+}
+
+# Name checking requires checking that there's an existing ACL already by
+# this name. Try to create the ACL object and use that to determine.
+sub syntax_check {
+ my ($self, $group) = @_;
+
+ my $acl;
+ eval { $acl = Wallet::ACL->new ($group, $self->{schema}) };
+ return 0 if $@;
+ return 0 unless $acl;
+ return 1;
+}
+
+# For checking a nested ACL, we need to expand each entry and then check
+# that entry. We also want to keep track of things already checked in order
+# to avoid any loops.
+sub check {
+ my ($self, $principal, $group) = @_;
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ unless ($group) {
+ $self->error ('malformed nested ACL');
+ return;
+ }
+
+ # Make an ACL object just so that we can use it to drop back into the
+ # normal ACL validation after we have expanded the nesting.
+ my $acl;
+ eval { $acl = Wallet::ACL->new ($group, $self->{schema}) };
+
+ # Get the list of all nested acl entries within this entry, and use it
+ # to go through each entry and decide if the given acl has access.
+ my @members = $self->get_membership ($group);
+ for my $entry (@members) {
+ my ($type, $name) = @{ $entry };
+ my $result = $acl->check_line ($principal, $type, $name);
+ return 1 if $result;
+ }
+ return 0;
+}
+
+# Get the membership of a group recursively. The final result will be a list
+# of arrayrefs like that from Wallet::ACL->list, but expanded for full
+# membership.
+sub get_membership {
+ my ($self, $group) = @_;
+
+ # Get the list of members for this nested acl. Consider any missing acls
+ # as empty.
+ my $schema = $self->{schema};
+ my @members;
+ eval {
+ my $acl = Wallet::ACL->new ($group, $schema);
+ @members = $acl->list;
+ };
+
+ # Now go through and expand any other nested groups into their own
+ # memberships.
+ my @expanded;
+ for my $entry (@members) {
+ my ($type, $name) = @{ $entry };
+ if ($type eq 'nested') {
+
+ # Keep track of things we've already expanded and don't look them
+ # up again.
+ next if exists $self->{expanded}{$name};
+ $self->{expanded}{$name} = 1;
+ push (@expanded, $self->get_membership ($name));
+
+ } else {
+ push (@expanded, $entry);
+ }
+ }
+
+ return @expanded;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL Allbery verifier verifiers
+
+=head1 NAME
+
+Wallet::ACL::Nested - Wallet ACL verifier to check another ACL
+
+=head1 SYNOPSIS
+
+ my $verifier = Wallet::ACL::Nested->new;
+ my $status = $verifier->check ($principal, $acl);
+ if (not defined $status) {
+ die "Something failed: ", $verifier->error, "\n";
+ } elsif ($status) {
+ print "Access granted\n";
+ } else {
+ print "Access denied\n";
+ }
+
+=head1 DESCRIPTION
+
+Wallet::ACL::Nested checks whether the principal is permitted by another
+named ACL and, if so, returns success. It is used to nest one ACL inside
+another.
+
+=head1 METHODS
+
+=over 4
+
+=item new()
+
+Creates a new ACL verifier.
+
+=item check(PRINCIPAL, ACL)
+
+Returns true if PRINCIPAL is granted access according to the nested ACL,
+specified by name. Returns false if it is not, and undef on error.
+
+=item error([ERROR ...])
+
+Returns the error of the last failing operation or undef if no operations
+have failed. Callers should call this function to get the error message
+after an undef return from any other instance method. The returned errors
+will generally come from the nested child ACL.
+
+=back
+
+=head1 SEE ALSO
+
+Wallet::ACL(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Jon Robertson <jonrober@stanford.edu>
+
+=cut
diff --git a/perl/lib/Wallet/Admin.pm b/perl/lib/Wallet/Admin.pm
index 8120e9c..b4246ba 100644
--- a/perl/lib/Wallet/Admin.pm
+++ b/perl/lib/Wallet/Admin.pm
@@ -115,22 +115,25 @@ sub default_data {
# acl_schemes default rows.
my ($r1) = $self->{schema}->resultset('AclScheme')->populate ([
[ qw/as_name as_class/ ],
- [ 'krb5', 'Wallet::ACL::Krb5' ],
- [ 'krb5-regex', 'Wallet::ACL::Krb5::Regex' ],
- [ 'ldap-attr', 'Wallet::ACL::LDAP::Attribute' ],
- [ 'netdb', 'Wallet::ACL::NetDB' ],
- [ 'netdb-root', 'Wallet::ACL::NetDB::Root' ],
+ [ 'krb5', 'Wallet::ACL::Krb5' ],
+ [ 'krb5-regex', 'Wallet::ACL::Krb5::Regex' ],
+ [ 'ldap-attr', 'Wallet::ACL::LDAP::Attribute' ],
+ [ 'ldap-attr-root', 'Wallet::ACL::LDAP::Attribute::Root' ],
+ [ 'nested', 'Wallet::ACL::Nested' ],
+ [ 'netdb', 'Wallet::ACL::NetDB' ],
+ [ 'netdb-root', 'Wallet::ACL::NetDB::Root' ],
]);
warn "default AclScheme not installed" unless defined $r1;
# types default rows.
my @record = ([ qw/ty_name ty_class/ ],
[ 'duo', 'Wallet::Object::Duo' ],
- [ 'duo-ldap', 'Wallet::Object::Duo::LDAPProxy' ],
- [ 'duo-pam', 'Wallet::Object::Duo::PAM' ],
- [ 'duo-radius', 'Wallet::Object::Duo::RadiusProxy' ],
- [ 'duo-rdp', 'Wallet::Object::Duo::RDP' ],
+ [ 'duo-ldap', 'Wallet::Object::Duo' ],
+ [ 'duo-pam', 'Wallet::Object::Duo' ],
+ [ 'duo-radius', 'Wallet::Object::Duo' ],
+ [ 'duo-rdp', 'Wallet::Object::Duo' ],
[ 'file', 'Wallet::Object::File' ],
+ [ 'password', 'Wallet::Object::Password' ],
[ 'keytab', 'Wallet::Object::Keytab' ],
[ 'wa-keyring', 'Wallet::Object::WAKeyring' ]);
($r1) = $self->{schema}->resultset('Type')->populate (\@record);
diff --git a/perl/lib/Wallet/Config.pm b/perl/lib/Wallet/Config.pm
index 2eb57f9..b3e1931 100644
--- a/perl/lib/Wallet/Config.pm
+++ b/perl/lib/Wallet/Config.pm
@@ -260,6 +260,49 @@ our $FILE_MAX_SIZE;
=back
+=head1 PASSWORD OBJECT CONFIGURATION
+
+These configuration variables only need to be set if you intend to use the
+C<password> object type (the Wallet::Object::Password class). You will also
+need to set the FILE_MAX_SIZE value from the file object configuration, as
+that is inherited.
+
+=over 4
+
+=item PWD_FILE_BUCKET
+
+The directory into which to store password objects. Password objects will
+be stored in subdirectories of this directory. See
+L<Wallet::Object::Password> for the full details of the naming scheme. This
+directory must be writable by the wallet server and the wallet server must
+be able to create subdirectories of it.
+
+PWD_FILE_BUCKET must be set to use file objects.
+
+=cut
+
+our $PWD_FILE_BUCKET;
+
+=item PWD_LENGTH_MIN
+
+The minimum length for any auto-generated password objects created when get
+is run before data is stored.
+
+=cut
+
+our $PWD_LENGTH_MIN = 20;
+
+=item PWD_LENGTH_MAX
+
+The maximum length for any auto-generated password objects created when get
+is run before data is stored.
+
+=cut
+
+our $PWD_LENGTH_MAX = 21;
+
+=back
+
=head1 KEYTAB OBJECT CONFIGURATION
These configuration variables only need to be set if you intend to use the
@@ -749,6 +792,34 @@ keytab objects for particular principals have fully-qualified hostnames:
Objects that aren't of type C<keytab> or which aren't for a host-based key
have no naming requirements enforced by this example.
+=head1 OBJECT HOST-BASED NAMES
+
+The above demonstrates having a host-based naming convention, where we
+expect one part of an object name to be the name of the host that this
+object is for. The most obvious examples are those keytab objects
+above, where we want certain keytab names to be in the form of
+<service>/<hostname>. It's then also useful to provide a Perl function
+named is_for_host which then can be used to tell if a given object is a
+host-based keytab for a specific host. This function is then called by
+the objects_hostname in Wallet::Report to give a list of all host-based
+objects for a given hostname. It should return true if the given object
+is a host-based object for the hostname, otherwise false.
+
+An example that matches the same policy as the last verify_name example
+would be:
+
+ sub is_for_host {
+ my ($type, $name, $hostname) = @_;
+ my %host_based = map { $_ => 1 }
+ qw(HTTP cifs host imap ldap nfs pop sieve smtp webauth);
+ return 0 unless $type eq 'keytab';
+ return 0 unless $name =~ m%/%;
+ my ($service, $instance) = split ('/', $name, 2);
+ return 0 unless $host_based{$service};
+ return 1 if $hostname eq $instance;
+ return 0;
+ }
+
=head1 ACL NAMING ENFORCEMENT
Similar to object names, by default wallet permits administrators to
diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm
index bdd61fb..97e6127 100644
--- a/perl/lib/Wallet/Object/Base.pm
+++ b/perl/lib/Wallet/Object/Base.pm
@@ -609,6 +609,15 @@ sub history {
# The get methods must always be overridden by the subclass.
sub get { die "Do not instantiate Wallet::Object::Base directly\n"; }
+# The update method should only work if a subclass supports it as something
+# different from get. That makes it explicit about whether the subclass has
+# a meaningful update.
+sub update {
+ my ($self) = @_;
+ $self->error ("update is not supported for this type, use get instead");
+ return;
+}
+
# Provide a default store implementation that returns an immutable object
# error so that auto-generated types don't have to provide their own.
sub store {
diff --git a/perl/lib/Wallet/Object/Duo.pm b/perl/lib/Wallet/Object/Duo.pm
index d08294b..d0901de 100644
--- a/perl/lib/Wallet/Object/Duo.pm
+++ b/perl/lib/Wallet/Object/Duo.pm
@@ -29,7 +29,100 @@ use Wallet::Object::Base;
# This version should be increased on any code change to this module. Always
# use two digits for the minor version with a leading zero if necessary so
# that it will sort properly.
-$VERSION = '0.02';
+$VERSION = '0.03';
+
+# Mappings from our types into what Duo calls the integration types.
+our %DUO_TYPES = (
+ 'duo' => {
+ integration => 'unix',
+ output => \&_output_generic,
+ },
+ 'duo-ldap' => {
+ integration => 'ldapproxy',
+ output => \&_output_ldap,
+ },
+ 'duo-pam' => {
+ integration => 'unix',
+ output => \&_output_pam,
+ },
+ 'duo-radius' => {
+ integration => 'radius',
+ output => \&_output_radius,
+ },
+ );
+
+# Extra types to add. These are all just named as the Duo integration name
+# with duo- before it and go to the generic output. Put them here to prevent
+# pages of settings. These are also not all actually set as types in the
+# types table to prevent overpopulation. You should manually create the
+# entries in that table for any Duo integrations you want to add.
+our @EXTRA_TYPES = ('accountsapi', 'adfs', 'adminapi', 'array', 'barracuda',
+ 'cisco', 'citrixcag', 'citrixns', 'confluence', 'drupal',
+ 'f5bigip', 'f5firepass', 'fortinet', 'jira', 'juniper',
+ 'juniperuac', 'lastpass', 'okta', 'onelogin', 'openvpn',
+ 'openvpnas', 'owa', 'paloalto', 'rdgateway', 'rdp',
+ 'rdweb', 'rest', 'rras', 'shibboleth', 'sonicwallsra',
+ 'splunk', 'tmg', 'uag', 'verify', 'vmwareview', 'websdk',
+ 'wordpress');
+for my $type (@EXTRA_TYPES) {
+ my $wallet_type = 'duo-'.$type;
+ $DUO_TYPES{$wallet_type}{integration} = $type;
+ $DUO_TYPES{$wallet_type}{output} = \&_output_generic;
+};
+
+##############################################################################
+# Get output methods
+##############################################################################
+
+# Output for any miscellaneous Duo integration, usually those that use a GUI
+# to set information and so don't need a custom configuration file.
+sub _output_generic {
+ my ($key, $secret, $hostname) = @_;
+
+ my $output;
+ $output .= "Integration key: $key\n";
+ $output .= "Secret key: $secret\n";
+ $output .= "Host: $hostname\n";
+
+ return $output;
+}
+
+# Output for the Duo unix integration, which hooks into the PAM stack.
+sub _output_pam {
+ my ($key, $secret, $hostname) = @_;
+
+ my $output = "[duo]\n";
+ $output .= "ikey = $key\n";
+ $output .= "skey = $secret\n";
+ $output .= "host = $hostname\n";
+
+ return $output;
+}
+
+# Output for the radius proxy, which can be plugged into the proxy config.
+sub _output_radius {
+ my ($key, $secret, $hostname) = @_;
+
+ my $output = "[radius_server_challenge]\n";
+ $output .= "ikey = $key\n";
+ $output .= "skey = $secret\n";
+ $output .= "api_host = $hostname\n";
+ $output .= "client = radius_client\n";
+
+ return $output;
+}
+
+# Output for the LDAP proxy, which can be plugged into the proxy config.
+sub _output_ldap {
+ my ($key, $secret, $hostname) = @_;
+
+ my $output = "[ldap_server_challenge]\n";
+ $output .= "ikey = $key\n";
+ $output .= "skey = $secret\n";
+ $output .= "api_host = $hostname\n";
+
+ return $output;
+}
##############################################################################
# Core methods
@@ -86,7 +179,7 @@ sub new {
# great here since we don't have a way to communicate the error back to the
# caller.
sub create {
- my ($class, $type, $name, $schema, $creator, $host, $time, $duo_type) = @_;
+ my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
# We have to have a Duo integration key file set.
if (not $Wallet::Config::DUO_KEY_FILE) {
@@ -95,6 +188,12 @@ sub create {
my $key_file = $Wallet::Config::DUO_KEY_FILE;
my $agent = $Wallet::Config::DUO_AGENT;
+ # Make sure this is actually a type we know about, since this handler
+ # can handle many types.
+ if (!exists $DUO_TYPES{$type}) {
+ die "$type is not a valid duo integration\n";
+ }
+
# Construct the Net::Duo::Admin object.
require Net::Duo::Admin;
my $duo = Net::Duo::Admin->new (
@@ -106,7 +205,7 @@ sub create {
# Create the object in Duo.
require Net::Duo::Admin::Integration;
- $duo_type ||= $Wallet::Config::DUO_TYPE;
+ my $duo_type = $DUO_TYPES{$type}{integration};
my %data = (
name => "$name ($duo_type)",
notes => 'Managed by wallet',
@@ -201,11 +300,17 @@ sub get {
my $json = JSON->new->utf8 (1)->relaxed (1);
my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
- # Construct the returned file.
- my $output;
- $output .= "Integration key: $key\n";
- $output .= 'Secret key: ' . $integration->secret_key . "\n";
- $output .= "Host: $config->{api_hostname}\n";
+ # Construct the returned file. Assume the generic handler in case there
+ # is no valid handler, though that shouldn't happen.
+ my $output_sub;
+ my $type = $self->{type};
+ if (exists $DUO_TYPES{$type}{output}) {
+ $output_sub = $DUO_TYPES{$type}{output};
+ } else {
+ $output_sub = \&_output_generic;
+ }
+ my $output = $output_sub->($key, $integration->secret_key,
+ $config->{api_hostname});
# Log the action and return.
$self->log_action ('get', $user, $host, $time);
diff --git a/perl/lib/Wallet/Object/Duo/LDAPProxy.pm b/perl/lib/Wallet/Object/Duo/LDAPProxy.pm
deleted file mode 100644
index 23894ac..0000000
--- a/perl/lib/Wallet/Object/Duo/LDAPProxy.pm
+++ /dev/null
@@ -1,202 +0,0 @@
-# Wallet::Object::Duo::LDAPProxy -- Duo auth proxy integration for LDAP
-#
-# Written by Jon Robertson <jonrober@stanford.edu>
-# Copyright 2014
-# The Board of Trustees of the Leland Stanford Junior University
-#
-# See LICENSE for licensing terms.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Wallet::Object::Duo::LDAPProxy;
-require 5.006;
-
-use strict;
-use warnings;
-use vars qw(@ISA $VERSION);
-
-use JSON;
-use Net::Duo::Admin;
-use Net::Duo::Admin::Integration;
-use Perl6::Slurp qw(slurp);
-use Wallet::Config ();
-use Wallet::Object::Duo;
-
-@ISA = qw(Wallet::Object::Duo);
-
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.01';
-
-##############################################################################
-# Core methods
-##############################################################################
-
-# Override create to provide the specific Duo integration type that will be
-# used in the remote Duo record.
-sub create {
- my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
-
- $time ||= time;
- my $self = $class->SUPER::create ($type, $name, $schema, $creator, $host,
- $time, 'ldapproxy');
- return $self;
-}
-
-# Override get to output the data in a specific format used for Duo LDAP
-# integration
-sub get {
- my ($self, $user, $host, $time) = @_;
- $time ||= time;
-
- # Check that the object isn't locked.
- my $id = $self->{type} . ':' . $self->{name};
- if ($self->flag_check ('locked')) {
- $self->error ("cannot get $id: object is locked");
- return;
- }
-
- # Retrieve the integration from Duo.
- my $key;
- eval {
- my %search = (du_name => $self->{name});
- my $row = $self->{schema}->resultset ('Duo')->find (\%search);
- $key = $row->get_column ('du_key');
- };
- if ($@) {
- $self->error ($@);
- return;
- }
- my $integration = Net::Duo::Admin::Integration->new ($self->{duo}, $key);
-
- # We also need the admin server name, which we can get from the Duo object
- # configuration with a bit of JSON decoding.
- my $json = JSON->new->utf8 (1)->relaxed (1);
- my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
-
- # Construct the returned file.
- my $output = "[ldap_server_challenge]\n";
- $output .= "ikey = $key\n";
- $output .= 'skey = ' . $integration->secret_key . "\n";
- $output .= "api_host = $config->{api_hostname}\n";
-
- # Log the action and return.
- $self->log_action ('get', $user, $host, $time);
- return $output;
-}
-
-1;
-__END__
-
-##############################################################################
-# Documentation
-##############################################################################
-
-=for stopwords
-Allbery Duo integration DBH keytab LDAP auth
-
-=head1 NAME
-
-Wallet::Object::Duo::LDAPProxy - Duo auth proxy integration for LDAP
-
-=head1 SYNOPSIS
-
- my @name = qw(duo-ldap host.example.com);
- my @trace = ($user, $host, time);
- my $object = Wallet::Object::Duo::LDAPProxy->create (@name, $schema, @trace);
- my $config = $object->get (@trace);
- $object->destroy (@trace);
-
-=head1 DESCRIPTION
-
-Wallet::Object::Duo::LDAPProxy is a representation of Duo
-integrations with the wallet, specifically to output Duo integrations
-in a format that can easily be pulled into configuring the Duo
-Authentication Proxy for LDAP. It implements the wallet object API
-and provides the necessary glue to create a Duo integration, return a
-configuration file containing the key and API information for that
-integration, and delete the integration from Duo when the wallet object
-is destroyed.
-
-The integration information is always returned in the configuration file
-format expected by the Authentication Proxy for Duo in configuring it
-for LDAP.
-
-This object can be retrieved repeatedly without changing the secret key,
-matching Duo's native behavior with integrations. To change the keys of
-the integration, delete it and recreate it.
-
-To use this object, at least one configuration parameter must be set. See
-L<Wallet::Config> for details on supported configuration parameters and
-information about how to set wallet configuration.
-
-=head1 METHODS
-
-This object mostly inherits from Wallet::Object::Duo. See the
-documentation for that class for all generic methods. Below are only
-those methods that are overridden or behave specially for this
-implementation.
-
-=over 4
-
-=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
-
-This will override the Wallet::Object::Duo class with the information
-needed to create a specific integration type in Duo. It creates a new
-object with the given TYPE and NAME (TYPE is normally C<duo-ldap> and
-must be for the rest of the wallet system to use the right class, but
-this module doesn't check for ease of subclassing), using DBH as the
-handle to the wallet metadata database. PRINCIPAL, HOSTNAME, and
-DATETIME are stored as history information. PRINCIPAL should be the
-user who is creating the object. If DATETIME isn't given, the current
-time is used.
-
-When a new Duo integration object is created, a new integration will be
-created in the configured Duo account and the integration key will be
-stored in the wallet object. If the integration already exists, create()
-will fail.
-
-If create() fails, it throws an exception.
-
-=item get(PRINCIPAL, HOSTNAME [, DATETIME])
-
-Retrieves the configuration information for the Duo integration and
-returns that information in the format expected by the configuration file
-for the Duo UNIX integration. Returns undef on failure. The caller
-should call error() to get the error message if get() returns undef.
-
-The returned configuration look look like:
-
- [ldap_server_challenge]
- ikey = <integration-key>
- skey = <secret-key>
- api_host = <api-hostname>
-
-The C<host> parameter will be taken from the configuration file pointed
-to by the DUO_KEY_FILE configuration variable.
-
-PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
-PRINCIPAL should be the user who is downloading the keytab. If DATETIME
-isn't given, the current time is used.
-
-=back
-
-=head1 LIMITATIONS
-
-Only one Duo account is supported for a given wallet implementation.
-
-=head1 SEE ALSO
-
-Net::Duo(3), Wallet::Config(3), Wallet::Object::Duo(3), wallet-backend(8)
-
-This module is part of the wallet system. The current version is
-available from L<http://www.eyrie.org/~eagle/software/wallet/>.
-
-=head1 AUTHORS
-
-Jon Robertson <jonrober@stanford.edu>
-
-=cut
diff --git a/perl/lib/Wallet/Object/Duo/PAM.pm b/perl/lib/Wallet/Object/Duo/PAM.pm
deleted file mode 100644
index d9d17f8..0000000
--- a/perl/lib/Wallet/Object/Duo/PAM.pm
+++ /dev/null
@@ -1,205 +0,0 @@
-# Wallet::Object::Duo::PAM -- Duo PAM int. object implementation for wallet
-#
-# Written by Russ Allbery <eagle@eyrie.org>
-# Jon Robertson <jonrober@stanford.edu>
-# Copyright 2014
-# The Board of Trustees of the Leland Stanford Junior University
-#
-# See LICENSE for licensing terms.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Wallet::Object::Duo::PAM;
-require 5.006;
-
-use strict;
-use warnings;
-use vars qw(@ISA $VERSION);
-
-use JSON;
-use Net::Duo::Admin;
-use Net::Duo::Admin::Integration;
-use Perl6::Slurp qw(slurp);
-use Wallet::Config ();
-use Wallet::Object::Duo;
-
-@ISA = qw(Wallet::Object::Duo);
-
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.01';
-
-##############################################################################
-# Core methods
-##############################################################################
-
-# Override create to provide the specific Duo integration type that will be
-# used in the remote Duo record.
-sub create {
- my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
-
- $time ||= time;
- my $self = $class->SUPER::create ($type, $name, $schema, $creator, $host,
- $time, 'unix');
- return $self;
-}
-
-# Override get to output the data in a specific format used by Duo's PAM
-# module.
-sub get {
- my ($self, $user, $host, $time) = @_;
- $time ||= time;
-
- # Check that the object isn't locked.
- my $id = $self->{type} . ':' . $self->{name};
- if ($self->flag_check ('locked')) {
- $self->error ("cannot get $id: object is locked");
- return;
- }
-
- # Retrieve the integration from Duo.
- my $key;
- eval {
- my %search = (du_name => $self->{name});
- my $row = $self->{schema}->resultset ('Duo')->find (\%search);
- $key = $row->get_column ('du_key');
- };
- if ($@) {
- $self->error ($@);
- return;
- }
- my $integration = Net::Duo::Admin::Integration->new ($self->{duo}, $key);
-
- # We also need the admin server name, which we can get from the Duo object
- # configuration with a bit of JSON decoding.
- my $json = JSON->new->utf8 (1)->relaxed (1);
- my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
-
- # Construct the returned file.
- my $output = "[duo]\n";
- $output .= "ikey = $key\n";
- $output .= 'skey = ' . $integration->secret_key . "\n";
- $output .= "host = $config->{api_hostname}\n";
-
- # Log the action and return.
- $self->log_action ('get', $user, $host, $time);
- return $output;
-}
-
-1;
-__END__
-
-##############################################################################
-# Documentation
-##############################################################################
-
-=for stopwords
-Allbery Duo integration DBH keytab
-
-=head1 NAME
-
-Wallet::Object::Duo::PAM - Duo PAM int. object implementation for wallet
-
-=head1 SYNOPSIS
-
- my @name = qw(duo-pam host.example.com);
- my @trace = ($user, $host, time);
- my $object = Wallet::Object::Duo::PAM->create (@name, $schema, @trace);
- my $config = $object->get (@trace);
- $object->destroy (@trace);
-
-=head1 DESCRIPTION
-
-Wallet::Object::Duo::PAM is a representation of Duo integrations with
-the wallet, specifically to output Duo integrations in a format that
-can easily be pulled into configuring the Duo PAM interface. It
-implements the wallet object API and provides the necessary glue to
-create a Duo integration, return a configuration file containing the key
-and API information for that integration, and delete the integration from
-Duo when the wallet object is destroyed.
-
-The integration information is always returned in the configuration file
-format expected by the Duo UNIX integration. The results of retrieving
-this object will be text, suitable for putting in the UNIX integration
-configuration file, containing the integration key, secret key, and admin
-hostname for that integration.
-
-This object can be retrieved repeatedly without changing the secret key,
-matching Duo's native behavior with integrations. To change the keys of
-the integration, delete it and recreate it.
-
-To use this object, at least one configuration parameter must be set. See
-L<Wallet::Config> for details on supported configuration parameters and
-information about how to set wallet configuration.
-
-=head1 METHODS
-
-This object mostly inherits from Wallet::Object::Duo. See the
-documentation for that class for all generic methods. Below are only
-those methods that are overridden or behave specially for this
-implementation.
-
-=over 4
-
-=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
-
-This will override the Wallet::Object::Duo class with the information
-needed to create a specific integration type in Duo. It creates a new
-object with the given TYPE and NAME (TYPE is normally C<duo-pam> and must
-be for the rest of the wallet system to use the right class, but this
-module doesn't check for ease of subclassing), using DBH as the handle
-to the wallet metadata database. PRINCIPAL, HOSTNAME, and DATETIME are
-stored as history information. PRINCIPAL should be the user who is
-creating the object. If DATETIME isn't given, the current time is
-used.
-
-When a new Duo integration object is created, a new integration will be
-created in the configured Duo account and the integration key will be
-stored in the wallet object. If the integration already exists, create()
-will fail.
-
-If create() fails, it throws an exception.
-
-=item get(PRINCIPAL, HOSTNAME [, DATETIME])
-
-Retrieves the configuration information for the Duo integration and
-returns that information in the format expected by the configuration file
-for the Duo UNIX integration. Returns undef on failure. The caller
-should call error() to get the error message if get() returns undef.
-
-The returned configuration look look like:
-
- [duo]
- ikey = <integration-key>
- skey = <secret-key>
- host = <api-hostname>
-
-The C<host> parameter will be taken from the configuration file pointed
-to by the DUO_KEY_FILE configuration variable.
-
-PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
-PRINCIPAL should be the user who is downloading the keytab. If DATETIME
-isn't given, the current time is used.
-
-=back
-
-=head1 LIMITATIONS
-
-Only one Duo account is supported for a given wallet implementation.
-
-=head1 SEE ALSO
-
-Net::Duo(3), Wallet::Config(3), Wallet::Object::Duo(3), wallet-backend(8)
-
-This module is part of the wallet system. The current version is
-available from L<http://www.eyrie.org/~eagle/software/wallet/>.
-
-=head1 AUTHORS
-
-Russ Allbery <eagle@eyrie.org>
-Jon Robertson <eagle@eyrie.org>
-
-=cut
diff --git a/perl/lib/Wallet/Object/Duo/RDP.pm b/perl/lib/Wallet/Object/Duo/RDP.pm
deleted file mode 100644
index c74661c..0000000
--- a/perl/lib/Wallet/Object/Duo/RDP.pm
+++ /dev/null
@@ -1,204 +0,0 @@
-# Wallet::Object::Duo::RDP -- Duo RDP int. object implementation for wallet
-#
-# Written by Russ Allbery <eagle@eyrie.org>
-# Jon Robertson <jonrober@stanford.edu>
-# Copyright 2014
-# The Board of Trustees of the Leland Stanford Junior University
-#
-# See LICENSE for licensing terms.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Wallet::Object::Duo::RDP;
-require 5.006;
-
-use strict;
-use warnings;
-use vars qw(@ISA $VERSION);
-
-use JSON;
-use Net::Duo::Admin;
-use Net::Duo::Admin::Integration;
-use Perl6::Slurp qw(slurp);
-use Wallet::Config ();
-use Wallet::Object::Duo;
-
-@ISA = qw(Wallet::Object::Duo);
-
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.01';
-
-##############################################################################
-# Core methods
-##############################################################################
-
-# Override create to provide the specific Duo integration type that will be
-# used in the remote Duo record.
-sub create {
- my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
-
- $time ||= time;
- my $self = $class->SUPER::create ($type, $name, $schema, $creator, $host,
- $time, 'rdp');
- return $self;
-}
-
-# Override get to output the data in a specific format used by Duo's RDP
-# module.
-sub get {
- my ($self, $user, $host, $time) = @_;
- $time ||= time;
-
- # Check that the object isn't locked.
- my $id = $self->{type} . ':' . $self->{name};
- if ($self->flag_check ('locked')) {
- $self->error ("cannot get $id: object is locked");
- return;
- }
-
- # Retrieve the integration from Duo.
- my $key;
- eval {
- my %search = (du_name => $self->{name});
- my $row = $self->{schema}->resultset ('Duo')->find (\%search);
- $key = $row->get_column ('du_key');
- };
- if ($@) {
- $self->error ($@);
- return;
- }
- my $integration = Net::Duo::Admin::Integration->new ($self->{duo}, $key);
-
- # We also need the admin server name, which we can get from the Duo object
- # configuration with a bit of JSON decoding.
- my $json = JSON->new->utf8 (1)->relaxed (1);
- my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
-
- # Construct the returned file.
- my $output;
- $output .= "Integration key: $key\n";
- $output .= 'Secret key: ' . $integration->secret_key . "\n";
- $output .= "Host: $config->{api_hostname}\n";
-
- # Log the action and return.
- $self->log_action ('get', $user, $host, $time);
- return $output;
-}
-
-1;
-__END__
-
-##############################################################################
-# Documentation
-##############################################################################
-
-=for stopwords
-Allbery Duo integration DBH keytab RDP
-
-=head1 NAME
-
-Wallet::Object::Duo::RDP - Duo RDP int. object implementation for wallet
-
-=head1 SYNOPSIS
-
- my @name = qw(duo-rdp host.example.com);
- my @trace = ($user, $host, time);
- my $object = Wallet::Object::Duo::RDP->create (@name, $schema, @trace);
- my $config = $object->get (@trace);
- $object->destroy (@trace);
-
-=head1 DESCRIPTION
-
-Wallet::Object::Duo::RDP is a representation of Duo integrations with
-the wallet, specifically to output Duo integrations to set up an RDP
-integration. This can be used to set up remote logins, or all Windows
-logins period if so selected in Duo's software. It implements the
-wallet object API and provides the necessary glue to create a Duo
-integration, return a configuration file containing the key and API
-information for that integration, and delete the integration from Duo
-when the wallet object is destroyed.
-
-Because the Duo RDP software is configured by a GUI, the information
-returned for a get operation is a simple set that's readable but not
-useful for directly plugging into a config file. The values would need
-to be cut and pasted into the GUI.
-
-This object can be retrieved repeatedly without changing the secret key,
-matching Duo's native behavior with integrations. To change the keys of
-the integration, delete it and recreate it.
-
-To use this object, at least one configuration parameter must be set. See
-L<Wallet::Config> for details on supported configuration parameters and
-information about how to set wallet configuration.
-
-=head1 METHODS
-
-This object mostly inherits from Wallet::Object::Duo. See the
-documentation for that class for all generic methods. Below are only
-those methods that are overridden or behave specially for this
-implementation.
-
-=over 4
-
-=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
-
-This will override the Wallet::Object::Duo class with the information
-needed to create a specific integration type in Duo. It creates a new
-object with the given TYPE and NAME (TYPE is normally C<duo-pam> and must
-be for the rest of the wallet system to use the right class, but this
-module doesn't check for ease of subclassing), using DBH as the handle
-to the wallet metadata database. PRINCIPAL, HOSTNAME, and DATETIME are
-stored as history information. PRINCIPAL should be the user who is
-creating the object. If DATETIME isn't given, the current time is
-used.
-
-When a new Duo integration object is created, a new integration will be
-created in the configured Duo account and the integration key will be
-stored in the wallet object. If the integration already exists, create()
-will fail.
-
-If create() fails, it throws an exception.
-
-=item get(PRINCIPAL, HOSTNAME [, DATETIME])
-
-Retrieves the configuration information for the Duo integration and
-returns that information in the format expected by the configuration file
-for the Duo UNIX integration. Returns undef on failure. The caller
-should call error() to get the error message if get() returns undef.
-
-The returned configuration look look like:
-
- Integration key: <integration-key>
- Secret key: <secret-key>
- Host: <api-hostname>
-
-The C<host> parameter will be taken from the configuration file pointed
-to by the DUO_KEY_FILE configuration variable.
-
-PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
-PRINCIPAL should be the user who is downloading the keytab. If DATETIME
-isn't given, the current time is used.
-
-=back
-
-=head1 LIMITATIONS
-
-Only one Duo account is supported for a given wallet implementation.
-
-=head1 SEE ALSO
-
-Net::Duo(3), Wallet::Config(3), Wallet::Object::Duo(3), wallet-backend(8)
-
-This module is part of the wallet system. The current version is
-available from L<http://www.eyrie.org/~eagle/software/wallet/>.
-
-=head1 AUTHORS
-
-Russ Allbery <eagle@eyrie.org>
-Jon Robertson <eagle@eyrie.org>
-
-=cut
diff --git a/perl/lib/Wallet/Object/Duo/RadiusProxy.pm b/perl/lib/Wallet/Object/Duo/RadiusProxy.pm
deleted file mode 100644
index a1f6e24..0000000
--- a/perl/lib/Wallet/Object/Duo/RadiusProxy.pm
+++ /dev/null
@@ -1,204 +0,0 @@
-# Wallet::Object::Duo::RadiusProxy -- Duo auth proxy integration for radius
-#
-# Written by Jon Robertson <jonrober@stanford.edu>
-# Copyright 2014
-# The Board of Trustees of the Leland Stanford Junior University
-#
-# See LICENSE for licensing terms.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Wallet::Object::Duo::RadiusProxy;
-require 5.006;
-
-use strict;
-use warnings;
-use vars qw(@ISA $VERSION);
-
-use JSON;
-use Net::Duo::Admin;
-use Net::Duo::Admin::Integration;
-use Perl6::Slurp qw(slurp);
-use Wallet::Config ();
-use Wallet::Object::Duo;
-
-@ISA = qw(Wallet::Object::Duo);
-
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.01';
-
-##############################################################################
-# Core methods
-##############################################################################
-
-# Override create to provide the specific Duo integration type that will be
-# used in the remote Duo record.
-sub create {
- my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
-
- $time ||= time;
- my $self = $class->SUPER::create ($type, $name, $schema, $creator, $host,
- $time, 'radius');
- return $self;
-}
-
-# Override get to output the data in a specific format used for Duo radius
-# integration
-sub get {
- my ($self, $user, $host, $time) = @_;
- $time ||= time;
-
- # Check that the object isn't locked.
- my $id = $self->{type} . ':' . $self->{name};
- if ($self->flag_check ('locked')) {
- $self->error ("cannot get $id: object is locked");
- return;
- }
-
- # Retrieve the integration from Duo.
- my $key;
- eval {
- my %search = (du_name => $self->{name});
- my $row = $self->{schema}->resultset ('Duo')->find (\%search);
- $key = $row->get_column ('du_key');
- };
- if ($@) {
- $self->error ($@);
- return;
- }
- my $integration = Net::Duo::Admin::Integration->new ($self->{duo}, $key);
-
- # We also need the admin server name, which we can get from the Duo object
- # configuration with a bit of JSON decoding.
- my $json = JSON->new->utf8 (1)->relaxed (1);
- my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
-
- # Construct the returned file.
- my $output = "[radius_server_challenge]\n";
- $output .= "ikey = $key\n";
- $output .= 'skey = ' . $integration->secret_key . "\n";
- $output .= "api_host = $config->{api_hostname}\n";
- $output .= "client = radius_client\n";
-
- # Log the action and return.
- $self->log_action ('get', $user, $host, $time);
- return $output;
-}
-
-1;
-__END__
-
-##############################################################################
-# Documentation
-##############################################################################
-
-=for stopwords
-Allbery Duo integration DBH keytab auth
-
-=head1 NAME
-
-Wallet::Object::Duo::RadiusProxy - Duo auth proxy integration for RADIUS
-
-=head1 SYNOPSIS
-
- my @name = qw(duo-radius host.example.com);
- my @trace = ($user, $host, time);
- my $object = Wallet::Object::Duo::RadiusProxy->create (@name, $schema, @trace);
- my $config = $object->get (@trace);
- $object->destroy (@trace);
-
-=head1 DESCRIPTION
-
-Wallet::Object::Duo::RadiusProxy is a representation of Duo
-integrations with the wallet, specifically to output Duo integrations
-in a format that can easily be pulled into configuring the Duo
-Authentication Proxy for Radius. It implements the wallet object API
-and provides the necessary glue to create a Duo integration, return a
-configuration file containing the key and API information for that
-integration, and delete the integration from Duo when the wallet object
-is destroyed.
-
-The integration information is always returned in the configuration file
-format expected by the Authentication Proxy for Duo in configuring it
-for Radius.
-
-This object can be retrieved repeatedly without changing the secret key,
-matching Duo's native behavior with integrations. To change the keys of
-the integration, delete it and recreate it.
-
-To use this object, at least one configuration parameter must be set. See
-L<Wallet::Config> for details on supported configuration parameters and
-information about how to set wallet configuration.
-
-=head1 METHODS
-
-This object mostly inherits from Wallet::Object::Duo. See the
-documentation for that class for all generic methods. Below are only
-those methods that are overridden or behave specially for this
-implementation.
-
-=over 4
-
-=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
-
-This will override the Wallet::Object::Duo class with the information
-needed to create a specific integration type in Duo. It creates a new
-object with the given TYPE and NAME (TYPE is normally C<duo-radius> and
-must be for the rest of the wallet system to use the right class, but
-this module doesn't check for ease of subclassing), using DBH as the
-handle to the wallet metadata database. PRINCIPAL, HOSTNAME, and
-DATETIME are stored as history information. PRINCIPAL should be the
-user who is creating the object. If DATETIME isn't given, the current
-time is used.
-
-When a new Duo integration object is created, a new integration will be
-created in the configured Duo account and the integration key will be
-stored in the wallet object. If the integration already exists, create()
-will fail.
-
-If create() fails, it throws an exception.
-
-=item get(PRINCIPAL, HOSTNAME [, DATETIME])
-
-Retrieves the configuration information for the Duo integration and
-returns that information in the format expected by the configuration file
-for the Duo UNIX integration. Returns undef on failure. The caller
-should call error() to get the error message if get() returns undef.
-
-The returned configuration look look like:
-
- [radius_server_challenge]
- ikey = <integration-key>
- skey = <secret-key>
- api_host = <api-hostname>
- client = radius_client
-
-The C<host> parameter will be taken from the configuration file pointed
-to by the DUO_KEY_FILE configuration variable.
-
-PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
-PRINCIPAL should be the user who is downloading the keytab. If DATETIME
-isn't given, the current time is used.
-
-=back
-
-=head1 LIMITATIONS
-
-Only one Duo account is supported for a given wallet implementation.
-
-=head1 SEE ALSO
-
-Net::Duo(3), Wallet::Config(3), Wallet::Object::Duo(3), wallet-backend(8)
-
-This module is part of the wallet system. The current version is
-available from L<http://www.eyrie.org/~eagle/software/wallet/>.
-
-=head1 AUTHORS
-
-Jon Robertson <jonrober@stanford.edu>
-
-=cut
diff --git a/perl/lib/Wallet/Object/Keytab.pm b/perl/lib/Wallet/Object/Keytab.pm
index 975179b..c625766 100644
--- a/perl/lib/Wallet/Object/Keytab.pm
+++ b/perl/lib/Wallet/Object/Keytab.pm
@@ -29,6 +29,37 @@ use Wallet::Kadmin;
$VERSION = '0.09';
##############################################################################
+# Shared methods
+##############################################################################
+
+# Generate a keytab into a temporary file and then return that as the return
+# value. Used by both get and update, as the only difference is how we
+# handle the unchanging flag.
+sub retrieve {
+ my ($self, $operation, $user, $host, $time) = @_;
+ $time ||= time;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot get $id: object is locked");
+ return;
+ }
+ my $kadmin = $self->{kadmin};
+ my $result;
+ if ($operation eq 'get' && $self->flag_check ('unchanging')) {
+ $result = $kadmin->keytab ($self->{name});
+ } else {
+ my @enctypes = $self->attr ('enctypes');
+ $result = $kadmin->keytab_rekey ($self->{name}, @enctypes);
+ }
+ if (defined $result) {
+ $self->log_action ($operation, $user, $host, $time);
+ } else {
+ $self->error ($kadmin->error);
+ }
+ return $result;
+}
+
+##############################################################################
# Enctype restriction
##############################################################################
@@ -314,25 +345,15 @@ sub destroy {
# return that as the return value.
sub get {
my ($self, $user, $host, $time) = @_;
- $time ||= time;
- my $id = $self->{type} . ':' . $self->{name};
- if ($self->flag_check ('locked')) {
- $self->error ("cannot get $id: object is locked");
- return;
- }
- my $kadmin = $self->{kadmin};
- my $result;
- if ($self->flag_check ('unchanging')) {
- $result = $kadmin->keytab ($self->{name});
- } else {
- my @enctypes = $self->attr ('enctypes');
- $result = $kadmin->keytab_rekey ($self->{name}, @enctypes);
- }
- if (defined $result) {
- $self->log_action ('get', $user, $host, $time);
- } else {
- $self->error ($kadmin->error);
- }
+ my $result = $self->retrieve ('get', $user, $host, $time);
+ return $result;
+}
+
+# Our update implementation. Generate a new keytab regardless of the
+# unchanging flag.
+sub update {
+ my ($self, $user, $host, $time) = @_;
+ my $result = $self->retrieve ('update', $user, $host, $time);
return $result;
}
diff --git a/perl/lib/Wallet/Object/Password.pm b/perl/lib/Wallet/Object/Password.pm
new file mode 100644
index 0000000..3fd6ec8
--- /dev/null
+++ b/perl/lib/Wallet/Object/Password.pm
@@ -0,0 +1,228 @@
+# Wallet::Object::Password -- Password object implementation for the wallet.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2015
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Object::Password;
+require 5.006;
+
+use strict;
+use warnings;
+use vars qw(@ISA $VERSION);
+
+use Crypt::GeneratePassword qw(chars);
+use Digest::MD5 qw(md5_hex);
+use Wallet::Config ();
+use Wallet::Object::File;
+
+@ISA = qw(Wallet::Object::File);
+
+# This version should be increased on any code change to this module. Always
+# use two digits for the minor version with a leading zero if necessary so
+# that it will sort properly.
+$VERSION = '0.01';
+
+##############################################################################
+# File naming
+##############################################################################
+
+# Returns the path into which that password object will be stored or undef on
+# error. On error, sets the internal error.
+sub file_path {
+ my ($self) = @_;
+ my $name = $self->{name};
+ unless ($Wallet::Config::PWD_FILE_BUCKET) {
+ $self->error ('password support not configured');
+ return;
+ }
+ unless ($name) {
+ $self->error ('password objects may not have empty names');
+ return;
+ }
+ my $hash = substr (md5_hex ($name), 0, 2);
+ $name =~ s/([^\w-])/sprintf ('%%%02X', ord ($1))/ge;
+ my $parent = "$Wallet::Config::PWD_FILE_BUCKET/$hash";
+ unless (-d $parent || mkdir ($parent, 0700)) {
+ $self->error ("cannot create password bucket $hash: $!");
+ return;
+ }
+ return "$Wallet::Config::PWD_FILE_BUCKET/$hash/$name";
+}
+
+##############################################################################
+# Shared methods
+##############################################################################
+
+# Return the contents of the file.
+sub retrieve {
+ my ($self, $operation, $user, $host, $time) = @_;
+ $time ||= time;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot get $id: object is locked");
+ return;
+ }
+ my $path = $self->file_path;
+ return unless $path;
+
+ # If nothing is yet stored, or we have requested an update, generate a
+ # random password and save it to the file.
+ my $schema = $self->{schema};
+ my %search = (ob_type => $self->{type},
+ ob_name => $self->{name});
+ my $object = $schema->resultset('Object')->find (\%search);
+ if (!$object->ob_stored_on || $operation eq 'update') {
+ unless (open (FILE, '>', $path)) {
+ $self->error ("cannot store initial settings for $id: $!\n");
+ return;
+ }
+ my $pass = chars ($Wallet::Config::PWD_LENGTH_MIN,
+ $Wallet::Config::PWD_LENGTH_MAX);
+ print FILE $pass;
+ $self->log_action ('store', $user, $host, $time);
+ unless (close FILE) {
+ $self->error ("cannot get $id: $!");
+ return;
+ }
+ }
+
+ unless (open (FILE, '<', $path)) {
+ $self->error ("cannot get $id: object has not been stored");
+ return;
+ }
+ local $/;
+ my $data = <FILE>;
+ unless (close FILE) {
+ $self->error ("cannot get $id: $!");
+ return;
+ }
+ $self->log_action ($operation, $user, $host, $time);
+ return $data;
+}
+
+##############################################################################
+# Core methods
+##############################################################################
+
+# Return the contents of the file.
+sub get {
+ my ($self, $user, $host, $time) = @_;
+ my $result = $self->retrieve ('get', $user, $host, $time);
+ return $result;
+}
+
+# Return the contents of the file after resetting them to a random string.
+sub update {
+ my ($self, $user, $host, $time) = @_;
+ my $result = $self->retrieve ('update', $user, $host, $time);
+ return $result;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=head1 NAME
+
+Wallet::Object::Password - Password object implementation for wallet
+
+=for stopwords
+API HOSTNAME DATETIME keytab remctld backend nul Allbery wallet-backend
+
+=head1 SYNOPSIS
+
+ my @name = qw(file mysql-lsdb)
+ my @trace = ($user, $host, time);
+ my $object = Wallet::Object::Password->create (@name, $schema, @trace);
+ unless ($object->store ("the-password\n")) {
+ die $object->error, "\n";
+ }
+ my $password = $object->get (@trace);
+ $object->destroy (@trace);
+
+=head1 DESCRIPTION
+
+Wallet::Object::Password is an extension of Wallet::Object::File,
+acting as a representation of simple file objects in the wallet. The
+difference between the two is that if there is no data stored in a
+password object when a user tries to get it for the first time, then a
+random string suited for a password will be generated and put into the
+object data.
+
+It implements the wallet object API and provides the necessary
+glue to store a file on the wallet server, retrieve it later, and delete
+it when the password object is deleted.
+
+To use this object, the configuration option specifying where on the
+wallet server to store password objects must be set. See
+L<Wallet::Config> for details on this configuration parameter and
+information about how to set wallet configuration.
+
+=head1 METHODS
+
+This object mostly inherits from Wallet::Object::File. See the
+documentation for that class for all generic methods. Below are only
+those methods that are overridden or behave specially for this
+implementation.
+
+=over 4
+
+=item get(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Retrieves the current contents of the file object or undef on error.
+store() must be called before get() will be successful. The caller should
+call error() to get the error message if get() returns undef. PRINCIPAL,
+HOSTNAME, and DATETIME are stored as history information. PRINCIPAL
+should be the user who is downloading the keytab. If DATETIME isn't
+given, the current time is used.
+
+=back
+
+=head1 FILES
+
+=over 4
+
+=item PWD_FILE_BUCKET/<hash>/<file>
+
+Password files are stored on the wallet server under the directory
+PWD_FILE_BUCKET as set in the wallet configuration. <hash> is the
+first two characters of the hex-encoded MD5 hash of the wallet password
+object name, used to not put too many files in the same directory.
+<file> is the name of the password object with all characters other
+than alphanumerics, underscores, and dashes replaced by C<%> and the
+hex code of the character.
+
+=back
+
+=head1 LIMITATIONS
+
+The wallet implementation itself can handle arbitrary password object
+names. However, due to limitations in the B<remctld> server usually
+used to run B<wallet-backend>, password object names containing nul
+characters (ASCII 0) may not be permitted. The file system used for
+storing file objects may impose a length limitation on the
+password object name.
+
+=head1 SEE ALSO
+
+remctld(8), Wallet::Config(3), Wallet::Object::File(3),
+wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Jon Robertson <jonrober@stanford.edu>
+
+=cut
diff --git a/perl/lib/Wallet/Policy/Stanford.pm b/perl/lib/Wallet/Policy/Stanford.pm
index a392476..86e204e 100644
--- a/perl/lib/Wallet/Policy/Stanford.pm
+++ b/perl/lib/Wallet/Policy/Stanford.pm
@@ -25,8 +25,8 @@ our (@EXPORT_OK, $VERSION);
# against circular module loading (not that we load any modules, but
# consistency is good).
BEGIN {
- $VERSION = '1.00';
- @EXPORT_OK = qw(default_owner verify_name);
+ $VERSION = '1.01';
+ @EXPORT_OK = qw(default_owner verify_name is_for_host);
}
##############################################################################
@@ -66,8 +66,9 @@ our %FILE_TYPE = (
'password-root' => { host => 1 },
'password-tivoli' => { host => 1 },
properties => { extra => 1 },
- 'ssh-dsa' => { host => 1 },
- 'ssh-rsa' => { host => 1 },
+ 'ssh-dsa' => { host => 1, extra => 1 },
+ 'ssh-rsa' => { host => 1, extra => 1 },
+ 'ssl-chain' => { host => 1, extra => 1 },
'ssl-key' => { host => 1, extra => 1 },
'ssl-keypair' => { host => 1, extra => 1 },
'ssl-keystore' => { extra => 1 },
@@ -75,6 +76,29 @@ our %FILE_TYPE = (
'tivoli-key' => { host => 1 },
);
+# Password object types. Most of these mimic file object types (which should
+# be gradually phased out).
+our %PASSWORD_TYPE = (
+ 'ipmi' => { host => 1 },
+ 'root' => { host => 1 },
+ 'tivoli' => { host => 1 },
+ 'system' => { host => 1, extra => 1, need_extra => 1 },
+ 'app' => { host => 1, extra => 1, need_extra => 1 },
+ 'service' => { extra => 1, need_extra => 1 },
+);
+
+# Mappings that let us determine the host for a host-based object, if any.
+our %HOST_FOR = (
+ 'keytab' => \&_host_for_keytab,
+ 'file' => \&_host_for_file,
+ 'password' => \&_host_for_password,
+ 'duo' => \&_host_for_duo,
+ 'duo-pam' => \&_host_for_duo,
+ 'duo-radius' => \&_host_for_duo,
+ 'duo-ldap' => \&_host_for_duo,
+ 'duo-rdp' => \&_host_for_duo,
+);
+
# Host-based file object types for the legacy file object naming scheme.
our @FILE_HOST_LEGACY = qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key);
@@ -144,6 +168,17 @@ sub _host_for_file_legacy {
return $host;
}
+# Map a password object name to a hostname. Returns undef if this password
+# object name doesn't map to a hostname.
+sub _host_for_password {
+ my ($name) = @_;
+
+ # Parse the name and check whether this is a host-based object.
+ my ($type, $host) = split('/', $name);
+ return if !$PASSWORD_TYPE{$type}{host};
+ return $host;
+}
+
# Map a file object name to a hostname. Returns undef if this file object
# name doesn't map to a hostname.
sub _host_for_file {
@@ -181,6 +216,23 @@ sub _host_for_duo {
return $name;
}
+# Take a object type and name, along with a host name, and use these to
+# decide if the given object is host-based and matches the given host.
+sub is_for_host {
+ my ($type, $name, $host) = @_;
+
+ # If we have a possible host mapping, get the host and see if it matches.
+ if (defined($HOST_FOR{$type})) {
+ my $object_host = $HOST_FOR{$type}->($name);
+ return 0 unless $object_host;
+ if ($host eq $object_host) {
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
# The default owner of host-based objects should be the host keytab and the
# NetDB ACL for that host, with one twist. If the creator of a new node is
# using a root instance, we want to require everyone managing that node be
@@ -188,20 +240,9 @@ sub _host_for_duo {
sub default_owner {
my ($type, $name) = @_;
- # How to determine the host for host-based objects.
- my %host_for = (
- 'keytab' => \&_host_for_keytab,
- 'file' => \&_host_for_file,
- 'duo' => \&_host_for_duo,
- 'duo-pam' => \&_host_for_duo,
- 'duo-radius' => \&_host_for_duo,
- 'duo-ldap' => \&_host_for_duo,
- 'duo-rdp' => \&_host_for_duo,
- );
-
# If we have a possible host mapping, see if we can use that.
- if (defined($host_for{$type})) {
- my $host = $host_for{$type}->($name);
+ if (defined($HOST_FOR{$type})) {
+ my $host = $HOST_FOR{$type}->($name);
if ($host) {
my $acl_name = "host/$host";
my @acl;
@@ -242,7 +283,7 @@ sub default_owner {
# hostnames, limit the acceptable characters for service/* keytabs, and
# enforce our naming constraints on */cgi principals.
#
-# Also use this function to require that IDG staff always do implicit object
+# Also use this function to require that ACS staff always do implicit object
# creation using a */root instance.
sub verify_name {
my ($type, $name, $user) = @_;
@@ -363,6 +404,8 @@ sub verify_name {
return "missing component in $name";
}
return;
+
+
} else {
# Legacy naming scheme.
my %groups = map { $_ => 1 } @GROUPS_LEGACY;
@@ -380,6 +423,71 @@ sub verify_name {
}
}
+ # Check password object naming conventions.
+ if ($type eq 'password') {
+ if ($name =~ m{ / }xms) {
+ my @name = split('/', $name);
+
+ # Names have between two and four components and all must be
+ # non-empty.
+ if (@name > 4) {
+ return "too many components in $name";
+ }
+ if (@name < 2) {
+ return "too few components in $name";
+ }
+ if (grep { $_ eq q{} } @name) {
+ return "empty component in $name";
+ }
+
+ # All objects start with the type. First check if this is a
+ # host-based type.
+ my $type = shift @name;
+ if ($PASSWORD_TYPE{$type} && $PASSWORD_TYPE{$type}{host}) {
+ my ($host, $extra) = @name;
+ if ($host !~ m{ [.] }xms) {
+ return "host name $host is not fully qualified";
+ }
+ if (defined($extra) && !$PASSWORD_TYPE{$type}{extra}) {
+ return "extraneous component at end of $name";
+ }
+ if (!defined($extra) && $PASSWORD_TYPE{$type}{need_extra}) {
+ return "missing component in $name";
+ }
+ return;
+ }
+
+ # Otherwise, the name is group-based. There be at least two
+ # remaining components.
+ if (@name < 2) {
+ return "too few components in $name";
+ }
+ my ($group, $service, $extra) = @name;
+
+ # Check the group.
+ if (!$ACL_FOR_GROUP{$group}) {
+ return "unknown group $group";
+ }
+
+ # Check the type. Be sure it's not host-based.
+ if (!$PASSWORD_TYPE{$type}) {
+ return "unknown type $type";
+ }
+ if ($PASSWORD_TYPE{$type}{host}) {
+ return "bad name for host-based file type $type";
+ }
+
+ # Check the extra data.
+ if (defined($extra) && !$PASSWORD_TYPE{$type}{extra}) {
+ return "extraneous component at end of $name";
+ }
+ if (!defined($extra) && $PASSWORD_TYPE{$type}{need_extra}) {
+ return "missing component in $name";
+ }
+ return;
+ }
+ }
+
# Check the naming conventions for all Duo object types. The object
# should simply be the host name for now.
if ($type =~ m{^duo(-\w+)?$}) {
diff --git a/perl/lib/Wallet/Report.pm b/perl/lib/Wallet/Report.pm
index bf48308..353cd97 100644
--- a/perl/lib/Wallet/Report.pm
+++ b/perl/lib/Wallet/Report.pm
@@ -175,6 +175,20 @@ sub objects_unused {
return (\%search, \%options);
}
+# Return the SQL statement to find all fiel objects that have been created
+# but have never had information stored (via store).
+sub objects_unstored {
+ my ($self) = @_;
+ my @objects;
+
+ my %search = (ob_stored_on => undef,
+ ob_type => 'file');
+ my %options = (order_by => [ qw/ob_type ob_name/ ],
+ select => [ qw/ob_type ob_name/ ]);
+
+ return (\%search, \%options);
+}
+
# Returns a list of all objects stored in the wallet database in the form of
# type and name pairs. On error and for an empty database, the empty list
# will be returned. To distinguish between an empty list and an error, call
@@ -190,7 +204,7 @@ sub objects {
if (!defined $type || $type eq '') {
($search_ref, $options_ref) = $self->objects_all;
} else {
- if ($type ne 'unused' && @args != 1) {
+ if ($type ne 'unused' && $type ne 'unstored' && @args != 1) {
$self->error ("object searches require one argument to search");
} elsif ($type eq 'type') {
($search_ref, $options_ref) = $self->objects_type (@args);
@@ -202,6 +216,8 @@ sub objects {
($search_ref, $options_ref) = $self->objects_acl (@args);
} elsif ($type eq 'unused') {
($search_ref, $options_ref) = $self->objects_unused (@args);
+ } elsif ($type eq 'unstored') {
+ ($search_ref, $options_ref) = $self->objects_unstored (@args);
} else {
$self->error ("do not know search type: $type");
}
@@ -226,12 +242,124 @@ sub objects {
return @objects;
}
+# Returns a list of all object_history records stored in the wallet database
+# including all of their fields. On error and for an empty database, the
+# empty list will be returned. To distinguish between an empty list and an
+# error, call error(), which will return undef if there was no error.
+# Farms out specific statement to another subroutine for specific search
+# types, but each case should return ob_type and ob_name in that order.
+sub objects_history {
+ my ($self, $search_type, @args) = @_;
+ undef $self->{error};
+
+ # All fields in the order we want to see them.
+ my @fields = ('oh_on', 'oh_by', 'oh_type', 'oh_name', 'oh_action',
+ 'oh_from');
+
+ # Get the search and options array refs from specific functions.
+ my %search = ();
+ my %options = (order_by => \@fields,
+ select => \@fields);
+
+ # Perform the search and return on any errors.
+ my @objects;
+ my $schema = $self->{schema};
+ eval {
+ my @objects_rs
+ = $schema->resultset('ObjectHistory')->search (\%search,
+ \%options);
+ for my $object_rs (@objects_rs) {
+ my @rec;
+ for my $field (@fields) {
+ push (@rec, $object_rs->get_column($field));
+ }
+ push (@objects, \@rec);
+ }
+ };
+ if ($@) {
+ $self->error ("cannot list objects: $@");
+ return;
+ }
+
+ return @objects;
+}
+
+# Returns a list of all objects stored in the wallet database in the form of
+# type and name pairs. On error and for an empty database, the empty list
+# will be returned. To distinguish between an empty list and an error, call
+# error(), which will return undef if there was no error. Farms out specific
+# statement to another subroutine for specific search types, but each case
+# should return ob_type and ob_name in that order.
+sub objects_hostname {
+ my ($self, $type, $hostname) = @_;
+ undef $self->{error};
+
+ # Make sure we have a given hostname.
+ if (!$hostname) {
+ $self->error ("object hosts requires one argument to search");
+ return;
+ }
+
+ # If we don't have a way to get host-based object lists, quit.
+ unless (defined &Wallet::Config::is_for_host) {
+ $self->error ('no host-based policy defined');
+ return;
+ }
+
+ # Search on all objects.
+ my %search = ();
+ my %options = (order_by => [ qw/ob_type ob_name/ ],
+ select => [ qw/ob_type ob_name/ ]);
+
+ my @objects;
+ my $schema = $self->{schema};
+ eval {
+ my @objects_rs = $schema->resultset('Object')->search (\%search,
+ \%options);
+
+ # Check to see if an object is for the given host and add to list if
+ # so.
+ for my $object_rs (@objects_rs) {
+ my $type = $object_rs->ob_type;
+ my $name = $object_rs->ob_name;
+ next unless &Wallet::Config::is_for_host($type, $name, $hostname);
+ push (@objects, [ $type, $name ]);
+ }
+ };
+ if ($@) {
+ $self->error ("cannot list objects: $@");
+ return;
+ }
+
+ return @objects;
+}
+
+##############################################################################
+# Type reports
+##############################################################################
+
+# Return an alphabetical list of all valid types set up, along with the class
+# that they belong to.
+sub types {
+ my ($self) = @_;
+
+ my (@types);
+ my @types_rs = $self->{schema}->resultset('Type')->all;
+ for my $type_rs (@types_rs) {
+ my $name = $type_rs->ty_name;
+ my $class = $type_rs->ty_class;
+ push(@types, [ $name, $class ]);
+ }
+
+ @types = sort { $a->[0] cmp $b->[0] } @types;
+ return @types;
+}
+
##############################################################################
# ACL reports
##############################################################################
-# Returns the SQL statement required to find and return all ACLs in the
-# database.
+# Returns the array of all ACLs in the database.
sub acls_all {
my ($self) = @_;
my @acls;
@@ -255,7 +383,7 @@ sub acls_all {
return (@acls);
}
-# Returns the SQL statement required to find all empty ACLs in the database.
+# Returns the array of all empty ACLs in the database.
sub acls_empty {
my ($self) = @_;
my @acls;
@@ -281,9 +409,36 @@ sub acls_empty {
return (@acls);
}
-# Returns the SQL statement and the field required to find ACLs containing the
-# specified entry. The identifier is automatically surrounded by wildcards to
-# do a substring search.
+# Returns the array of ACLs that nest a given ACL.
+sub acls_nesting {
+ my ($self, $name) = @_;
+ my @acls;
+
+ my $schema = $self->{schema};
+ my %search = (ae_scheme => 'nested',
+ ae_identifier => $name);
+ my %options = (join => 'acl_entries',
+ prefetch => 'acl_entries',
+ order_by => [ qw/ac_id/ ],
+ select => [ qw/ac_id ac_name/ ]);
+
+ eval {
+ my @acls_rs = $schema->resultset('Acl')->search (\%search, \%options);
+ for my $acl_rs (@acls_rs) {
+ push (@acls, [ $acl_rs->ac_id, $acl_rs->ac_name ]);
+ }
+ };
+
+ if ($@) {
+ $self->error ("cannot list ACLs: $@");
+ return;
+ }
+ return (@acls);
+}
+
+# Returns the array of all ACLs containing the specified entry. The given
+# identifier is automatically surrounded by wildcards to do a substring
+# search.
sub acls_entry {
my ($self, $type, $identifier) = @_;
my @acls;
@@ -311,7 +466,7 @@ sub acls_entry {
return (@acls);
}
-# Returns the SQL statement required to find unused ACLs.
+# Returns the array of all unused ACLs.
sub acls_unused {
my ($self) = @_;
my @acls;
@@ -424,6 +579,13 @@ sub acls {
@acls = $self->acls_empty;
} elsif ($type eq 'unused') {
@acls = $self->acls_unused;
+ } elsif ($type eq 'nesting') {
+ if (@args == 0) {
+ $self->error ('ACL nesting search requires an ACL to search');
+ return;
+ } else {
+ @acls = $self->acls_nesting (@args);
+ }
} else {
$self->error ("unknown search type: $type");
return;
@@ -469,6 +631,23 @@ sub owners {
return @owners;
}
+# Return an alphabetical list of all valid types set up, along with the class
+# that they belong to.
+sub acl_schemes {
+ my ($self) = @_;
+
+ my (@schemes);
+ my @acls_rs = $self->{schema}->resultset('AclScheme')->all;
+ for my $acl_rs (@acls_rs) {
+ my $name = $acl_rs->as_name;
+ my $class = $acl_rs->as_class;
+ push(@schemes, [ $name, $class ]);
+ }
+
+ @schemes = sort { $a->[0] cmp $b->[0] } @schemes;
+ return @schemes;
+}
+
##############################################################################
# Auditing
##############################################################################
@@ -633,14 +812,17 @@ Returns a list of all objects matching a search type and string in the
database, or all objects in the database if no search information is
given.
-There are five types of searches currently. C<type>, with a given type,
-will return only those entries where the type matches the given type.
-C<owner>, with a given owner, will only return those objects owned by the
-given ACL name or ID. C<flag>, with a given flag name, will only return
-those items with a flag set to the given value. C<acl> operates like
-C<owner>, but will return only those objects that have the given ACL name
-or ID on any of the possible ACL settings, not just owner. C<unused> will
-return all entries for which a get command has never been issued.
+There are several types of searches. C<type>, with a given type, will
+return only those entries where the type matches the given type.
+C<owner>, with a given owner, will only return those objects owned by
+the given ACL name or ID. C<flag>, with a given flag name, will only
+return those items with a flag set to the given value. C<acl> operates
+like C<owner>, but will return only those objects that have the given
+ACL name or ID on any of the possible ACL settings, not just owner.
+C<unused> will return all entries for which a get command has never
+been issued. C<unstored> will return all entries for which a store
+command has never been issued (limited to file type since storing isn't
+needed for other types).
The return value is a list of references to pairs of type and name. For
example, if two objects existed in the database, both of type C<keytab>
@@ -654,6 +836,24 @@ empty search result, the caller should call error(). error() is
guaranteed to return the error message if there was an error and undef if
there was no error.
+=item objects_history(TYPE)
+
+Returns a dump of the entire object history table. The return value is
+a list of references to each field in that table, in the following order:
+
+ oh_on, oh_by, oh_type, oh_name, oh_action, oh_from
+
+=item objects_hostname(TYPE, HOSTNAME)
+
+Returns a list of all host-based objects for a given hostname. The
+output is identical to the general objects command, but we need to
+separate this out because the way it searches is very different.
+
+Returns the empty list on failure. To distinguish between this and an
+empty search result, the caller should call error(). error() is
+guaranteed to return the error message if there was an error and undef if
+there was no error.
+
=item owners(TYPE, NAME)
Returns a list of all ACL lines contained in owner ACLs for objects
diff --git a/perl/lib/Wallet/Schema.pm b/perl/lib/Wallet/Schema.pm
index 5b850c0..386801a 100644
--- a/perl/lib/Wallet/Schema.pm
+++ b/perl/lib/Wallet/Schema.pm
@@ -114,6 +114,10 @@ Holds the supported ACL schemes and their corresponding Perl classes:
insert into acl_schemes (as_name, as_class)
values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute');
insert into acl_schemes (as_name, as_class)
+ values ('ldap-attr-root', 'Wallet::ACL::LDAP::Attribute::Root');
+ insert into acl_schemes (as_name, as_class)
+ values ('nested', 'Wallet::ACL::Nested');
+ insert into acl_schemes (as_name, as_class)
values ('netdb', 'Wallet::ACL::NetDB');
insert into acl_schemes (as_name, as_class)
values ('netdb-root', 'Wallet::ACL::NetDB::Root');
diff --git a/perl/lib/Wallet/Schema/Result/AclScheme.pm b/perl/lib/Wallet/Schema/Result/AclScheme.pm
index 91a58b2..be4ec09 100644
--- a/perl/lib/Wallet/Schema/Result/AclScheme.pm
+++ b/perl/lib/Wallet/Schema/Result/AclScheme.pm
@@ -36,6 +36,10 @@ By default it contains the following entries:
insert into acl_schemes (as_name, as_class)
values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute');
insert into acl_schemes (as_name, as_class)
+ values ('ldap-attr-root', 'Wallet::ACL::LDAP::Attribute::Root');
+ insert into acl_schemes (as_name, as_class)
+ values ('nested', 'Wallet::ACL::Nested');
+ insert into acl_schemes (as_name, as_class)
values ('netdb', 'Wallet::ACL::NetDB');
insert into acl_schemes (as_name, as_class)
values ('netdb-root', 'Wallet::ACL::NetDB::Root');
diff --git a/perl/lib/Wallet/Server.pm b/perl/lib/Wallet/Server.pm
index f6ea342..946ba10 100644
--- a/perl/lib/Wallet/Server.pm
+++ b/perl/lib/Wallet/Server.pm
@@ -154,8 +154,8 @@ sub create_check {
$self->error ($acl->error);
return;
}
- @entries = sort { $$a[0] cmp $$b[0] && $$a[1] cmp $$b[1] } @entries;
- @acl = sort { $$a[0] cmp $$b[0] && $$a[1] cmp $$b[1] } @acl;
+ @entries = sort { $$a[0] cmp $$b[0] || $$a[1] cmp $$b[1] } @entries;
+ @acl = sort { $$a[0] cmp $$b[0] || $$a[1] cmp $$b[1] } @acl;
my $okay = 1;
if (@entries != @acl) {
$okay = 0;
@@ -516,6 +516,21 @@ sub get {
return $result;
}
+# Retrieve the information associated with an object, updating the current
+# information if we are of a type that allows autogenerated information.
+# Returns undef and sets the internal error if the retrieval fails or if the
+# user isn't authorized. If the object doesn't exist, attempts dynamic
+# creation of the object using the default ACL mappings (if any).
+sub update {
+ my ($self, $type, $name) = @_;
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ return unless $self->acl_verify ($object, 'get');
+ my $result = $object->update ($self->{user}, $self->{host});
+ $self->error ($object->error) unless defined $result;
+ return $result;
+}
+
# Store new data in an object, or returns undef and sets the internal error if
# the object can't be found or if the user isn't authorized. Also don't
# permit storing undef, although storing the empty string is fine. If the
@@ -734,6 +749,36 @@ sub acl_rename {
return 1;
}
+# Move all ACLs owned by one ACL to another, or return undef and set the
+# internal error.
+sub acl_replace {
+ my ($self, $old_id, $replace_id) = @_;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->acl_error ($old_id, 'replace');
+ return;
+ }
+ my $acl = eval { Wallet::ACL->new ($old_id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ if ($acl->name eq 'ADMIN') {
+ $self->error ('cannot replace the ADMIN ACL');
+ return;
+ }
+ my $replace_acl = eval { Wallet::ACL->new ($replace_id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+
+ unless ($acl->replace ($replace_id, $self->{user}, $self->{host})) {
+ $self->error ($acl->error);
+ return;
+ }
+ return 1;
+}
+
# Destroy an ACL, deleting it out of the database. Returns true on success.
# On failure, returns undef, setting the internal error.
sub acl_destroy {
@@ -942,6 +987,14 @@ either the current name or the numeric ID. NEW must not be all-numeric.
To rename an ACL, the current user must be authorized by the ADMIN ACL.
Returns true on success and false on failure.
+=item acl_replace(OLD, NEW)
+
+Moves any object owned by the ACL identified by OLD to be instead owned by
+NEW. This goes through all objects owned by OLD and individually changes
+the owner, along with history updates. OLD and NEW may be either the name
+or the numeric ID. To replace an ACL, the current user must be authorized
+by the ADMIN ACL. Returns true on success and false on failure.
+
=item acl_show(ID)
Returns a human-readable description, including membership, of the ACL
diff --git a/perl/sql/wallet-1.3-update-duo.sql b/perl/sql/wallet-1.3-update-duo.sql
new file mode 100644
index 0000000..affadcd
--- /dev/null
+++ b/perl/sql/wallet-1.3-update-duo.sql
@@ -0,0 +1,9 @@
+--
+-- Run on installing wallet 1.3 in order to update what the Duo types
+-- point to for modules.
+--
+
+UPDATE types set ty_class='Wallet::Object::Duo' where ty_name='duo-ldap';
+UPDATE types set ty_class='Wallet::Object::Duo' where ty_name='duo-pam';
+UPDATE types set ty_class='Wallet::Object::Duo' where ty_name='duo-radius';
+UPDATE types set ty_class='Wallet::Object::Duo' where ty_name='duo-rdp';
diff --git a/perl/t/general/acl.t b/perl/t/general/acl.t
index 1dd5c53..4de7493 100755
--- a/perl/t/general/acl.t
+++ b/perl/t/general/acl.t
@@ -12,11 +12,11 @@ use strict;
use warnings;
use POSIX qw(strftime);
-use Test::More tests => 101;
+use Test::More tests => 115;
use Wallet::ACL;
use Wallet::Admin;
-use Wallet::Server;
+use Wallet::Object::Base;
use lib 't/lib';
use Util;
@@ -46,7 +46,7 @@ $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');
+ok (!defined ($acl), 'Creating a duplicate acl');
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');
@@ -62,32 +62,6 @@ 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', @trace)) {
- 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', @trace),
- ' 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');
@@ -124,14 +98,14 @@ 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:
+Members of ACL test (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",
+is ($acl->error, "cannot remove krb5:$admin from test: entry not found in ACL",
' with the right error');
if ($acl->remove ('krb5', $user1, @trace)) {
ok (1, ' but removing the first user works');
@@ -145,7 +119,7 @@ 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: /,
+like ($acl->error, qr/^cannot add \Qkrb5:$user2\E to test: /,
' with the right error');
if ($acl->add ('krb5', '', @trace)) {
ok (1, 'Adding a bad entry works');
@@ -159,7 +133,7 @@ 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:
+Members of ACL test (id: 2) are:
krb5
krb5 $user2
EOE
@@ -187,17 +161,50 @@ if ($acl->remove ('krb5', '', @trace)) {
}
@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->show, "Members of ACL test (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 rename.
+my $acl_nest = eval { Wallet::ACL->create ('test-nesting', $schema, @trace) };
+ok (defined ($acl_nest), 'ACL creation for setting up nested');
+if ($acl_nest->add ('nested', 'test', @trace)) {
+ ok (1, ' and adding the nesting');
+} else {
+ is ($acl_nest->error, '', ' and adding the nesting');
+}
+if ($acl->rename ('example', @trace)) {
+ 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', @trace),
+ ' but renaming to an existing name fails');
+like ($acl->error, qr/^cannot rename ACL example to ADMIN: /,
+ ' with the right error');
+@entries = $acl_nest->list;
+is ($entries[0][1], 'example', ' and the name in a nested ACL updated');
+
# Test history.
my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]);
my $history = <<"EOO";
$date create
by $admin from $host
-$date rename from test
- by $admin from $host
$date add krb5 $user1
by $admin from $host
$date add krb5 $user2
@@ -210,14 +217,24 @@ $date remove krb5 $user2
by $admin from $host
$date remove krb5
by $admin from $host
+$date rename from test
+ by $admin from $host
EOO
is ($acl->history, $history, 'History is correct');
# Test destroy.
+$acl->destroy (@trace);
+is ($acl->error, 'cannot destroy ACL example: ACL is nested in ACL test-nesting',
+ 'Destroying a nested ACL fails');
+if ($acl_nest->remove ('nested', 'example', @trace)) {
+ ok (1, ' and removing the nesting succeeds');
+} else {
+ is ($acl_nest->error, '', 'and removing the nesting succeeds');
+}
if ($acl->destroy (@trace)) {
- ok (1, 'Destroying the ACL works');
+ ok (1, ' and now destroying the ACL works');
} else {
- is ($acl->error, '', 'Destroying the ACL works');
+ is ($acl->error, '', ' and now destroying the ACL works');
}
$acl = eval { Wallet::ACL->new ('example', $schema) };
ok (!defined ($acl), ' and now cannot be found');
@@ -225,11 +242,71 @@ 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');
+@entries = $acl_nest->list;
+is (scalar (@entries), 0, ' and it is no longer a nested entry');
$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');
+like ($acl->id, qr{\A[34]\z}, ' and an ID of 3 or 4');
+
+# Test replace. by creating three acls, then assigning two objects to the
+# first, one to the second, and another to the third. Then replace the first
+# acl with the second, so that we can verify that multiple objects are moved,
+# that an object already belonging to the new acl is okay, and that the
+# objects with unrelated ACL are unaffected.
+my ($acl_old, $acl_new, $acl_other, $obj_old_one, $obj_old_two, $obj_new,
+ $obj_unrelated);
+eval {
+ $acl_old = Wallet::ACL->create ('example-old', $schema, @trace);
+ $acl_new = Wallet::ACL->create ('example-new', $schema, @trace);
+ $acl_other = Wallet::ACL->create ('example-other', $schema, @trace);
+};
+is ($@, '', 'ACLs needed for testing replace are created');
+eval {
+ $obj_old_one = Wallet::Object::Base->create ('keytab',
+ 'service/test1@EXAMPLE.COM',
+ $schema, @trace);
+ $obj_old_two = Wallet::Object::Base->create ('keytab',
+ 'service/test2@EXAMPLE.COM',
+ $schema, @trace);
+ $obj_new = Wallet::Object::Base->create ('keytab',
+ 'service/test3@EXAMPLE.COM',
+ $schema, @trace);
+ $obj_unrelated = Wallet::Object::Base->create ('keytab',
+ 'service/test4@EXAMPLE.COM',
+ $schema, @trace);
+};
+is ($@, '', ' and so were needed objects');
+if ($obj_old_one->owner ('example-old', @trace)
+ && $obj_old_two->owner ('example-old', @trace)
+ && $obj_new->owner ('example-new', @trace)
+ && $obj_unrelated->owner ('example-other', @trace)) {
+
+ ok (1, ' and setting initial ownership on the objects succeeds');
+}
+is ($acl_old->replace('example-new', @trace), 1,
+ ' and replace ran successfully');
+eval {
+ $obj_old_one = Wallet::Object::Base->new ('keytab',
+ 'service/test1@EXAMPLE.COM',
+ $schema);
+ $obj_old_two = Wallet::Object::Base->new ('keytab',
+ 'service/test2@EXAMPLE.COM',
+ $schema);
+ $obj_new = Wallet::Object::Base->new ('keytab',
+ 'service/test3@EXAMPLE.COM',
+ $schema);
+ $obj_unrelated = Wallet::Object::Base->new ('keytab',
+ 'service/test4@EXAMPLE.COM',
+ $schema);
+};
+is ($obj_old_one->owner, 'example-new', ' and first replace is correct');
+is ($obj_old_two->owner, 'example-new', ' and second replace is correct');
+is ($obj_new->owner, 'example-new',
+ ' and object already with new acl is correct');
+is ($obj_unrelated->owner, 'example-other',
+ ' and unrelated object ownership is correct');
# Clean up.
$setup->destroy;
diff --git a/perl/t/general/report.t b/perl/t/general/report.t
index 8d348ed..e47cdc6 100755
--- a/perl/t/general/report.t
+++ b/perl/t/general/report.t
@@ -11,7 +11,7 @@
use strict;
use warnings;
-use Test::More tests => 197;
+use Test::More tests => 223;
use Wallet::Admin;
use Wallet::Report;
@@ -41,6 +41,32 @@ 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');
+# Check to see that we have all types that we expect.
+my @types = $report->types;
+is (scalar (@types), 10, 'There are ten types created');
+is ($types[0][0], 'base', ' and the first member is correct');
+is ($types[1][0], 'duo', ' and the second member is correct');
+is ($types[2][0], 'duo-ldap', ' and the third member is correct');
+is ($types[3][0], 'duo-pam', ' and the fourth member is correct');
+is ($types[4][0], 'duo-radius', ' and the fifth member is correct');
+is ($types[5][0], 'duo-rdp', ' and the sixth member is correct');
+is ($types[6][0], 'file', ' and the seventh member is correct');
+is ($types[7][0], 'keytab', ' and the eighth member is correct');
+is ($types[8][0], 'password', ' and the nineth member is correct');
+is ($types[9][0], 'wa-keyring', ' and the tenth member is correct');
+
+# And that we have all schemes that we expect.
+my @schemes = $report->acl_schemes;
+is (scalar (@schemes), 8, 'There are seven acl schemes created');
+is ($schemes[0][0], 'base', ' and the first member is correct');
+is ($schemes[1][0], 'krb5', ' and the second member is correct');
+is ($schemes[2][0], 'krb5-regex', ' and the third member is correct');
+is ($schemes[3][0], 'ldap-attr', ' and the fourth member is correct');
+is ($schemes[4][0], 'ldap-attr-root', ' and the fifth member is correct');
+is ($schemes[5][0], 'nested', ' and the sixth member is correct');
+is ($schemes[6][0], 'netdb', ' and the seventh member is correct');
+is ($schemes[7][0], 'netdb-root', ' and the eighth member is correct');
+
# Create an object.
my $server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') };
is ($@, '', 'Creating a server instance did not die');
@@ -257,6 +283,22 @@ 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 a host-based object matching script so that we can test the host report.
+# The deactivation trick isn't needed here.
+package Wallet::Config;
+sub is_for_host {
+ my ($type, $name, $host) = @_;
+ my ($service, $principal) = split ('/', $name, 2);
+ return 0 unless $service && $principal;
+ return 1 if $host eq $principal;
+ return 0;
+}
+package main;
+@lines = $report->objects_hostname ('host', 'admin');
+is (scalar (@lines), 1, 'Searching for host-based objects 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 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";
@@ -325,6 +367,13 @@ is ($server->acl_add ('third', 'base', 'baz'), 1,
is (scalar (@acls), 0, 'There are no duplicate ACLs');
is ($report->error, undef, ' and no error');
+# See if the acl nesting report works correctly.
+is ($server->acl_add ('fourth', 'nested', 'second'), 1,
+ 'Adding an ACL as a nested entry for another works');
+@acls = $report->acls ('nesting', 'second');
+is (scalar (@acls), 1, ' and the nested report shows one nesting');
+is ($acls[0][1], 'fourth', ' with the correct ACL nesting it');
+
# Clean up.
$admin->destroy;
system ('rm -r test-files') == 0 or die "cannot remove test-files\n";
diff --git a/perl/t/general/server.t b/perl/t/general/server.t
index 0a527a5..8f4c16c 100755
--- a/perl/t/general/server.t
+++ b/perl/t/general/server.t
@@ -89,7 +89,7 @@ is ($server->acl_rename ('empty', 'test'), undef,
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: /,
+like ($server->error, qr/^cannot rename ACL test 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');
@@ -138,7 +138,7 @@ 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",
+ "cannot remove krb5:$user2 from empty: 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",
@@ -148,7 +148,7 @@ is ($server->acl_remove ('empty', 'krb5', $user1), 1,
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",
+ "cannot remove krb5:$user1 from empty: 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');
@@ -168,7 +168,7 @@ 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",
+ "cannot remove krb5:$user1 from ADMIN: 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
@@ -994,7 +994,7 @@ is ($server->owner ('base', 'service/acl-user', 'test-destroy'), 1,
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',
+ 'cannot destroy ACL test-destroy: 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');
diff --git a/perl/t/object/base.t b/perl/t/object/base.t
index ee9ff4b..8fedd64 100755
--- a/perl/t/object/base.t
+++ b/perl/t/object/base.t
@@ -12,7 +12,7 @@ use strict;
use warnings;
use POSIX qw(strftime);
-use Test::More tests => 137;
+use Test::More tests => 139;
use Wallet::ACL;
use Wallet::Admin;
@@ -208,6 +208,9 @@ is ($object->flag_clear ('locked', @trace), 1, 'Clearing locked succeeds');
eval { $object->get (@trace) };
is ($@, "Do not instantiate Wallet::Object::Base directly\n",
'Get fails with the right error');
+ok (!$object->update (@trace), 'Update fails');
+is ($object->error, 'update is not supported for this type, use get instead',
+ ' with the right error');
ok (! $object->store ("Some data", @trace), 'Store fails');
is ($object->error, "cannot store keytab:$princ: object type is immutable",
' with the right error');
diff --git a/perl/t/object/duo-ldap.t b/perl/t/object/duo-ldap.t
index 3648eba..8a00dbb 100644
--- a/perl/t/object/duo-ldap.t
+++ b/perl/t/object/duo-ldap.t
@@ -26,7 +26,7 @@ BEGIN {
BEGIN {
use_ok('Wallet::Admin');
use_ok('Wallet::Config');
- use_ok('Wallet::Object::Duo::LDAPProxy');
+ use_ok('Wallet::Object::Duo');
}
use lib 't/lib';
@@ -53,15 +53,14 @@ my $mock = Net::Duo::Mock::Agent->new ({ key_file => 't/data/duo/keys.json' });
# Test error handling in the absence of configuration.
my $object = eval {
- Wallet::Object::Duo::LDAPProxy->new ('duo-ldap', 'test', $schema);
+ Wallet::Object::Duo->new ('duo-ldap', 'test', $schema);
};
-is ($object, undef, 'Wallet::Object::Duo::LDAPProxy new with no config failed');
+is ($object, undef, 'Wallet::Object::Duo new with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
$object = eval {
- Wallet::Object::Duo::LDAPProxy->create ('duo-ldap', 'test', $schema,
- @trace);
+ Wallet::Object::Duo->create ('duo-ldap', 'test', $schema, @trace);
};
-is ($object, undef, 'Wallet::Object::Duo::LDAPProxy creation with no config failed');
+is ($object, undef, 'Wallet::Object::Duo creation with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
# Set up the Duo configuration.
@@ -83,9 +82,8 @@ $mock->expect (
response_file => 't/data/duo/integration.json',
}
);
-$object = Wallet::Object::Duo::LDAPProxy->create ('duo-ldap', 'test', $schema,
- @trace);
-isa_ok ($object, 'Wallet::Object::Duo::LDAPProxy');
+$object = Wallet::Object::Duo->create ('duo-ldap', 'test', $schema, @trace);
+isa_ok ($object, 'Wallet::Object::Duo');
# Check the metadata about the new wallet object.
$expected = <<"EOO";
@@ -127,7 +125,7 @@ is ($object->flag_clear ('locked', @trace), 1,
'...and clearing locked flag works');
# Create a new object by wallet type and name.
-$object = Wallet::Object::Duo::LDAPProxy->new ('duo-ldap', 'test', $schema);
+$object = Wallet::Object::Duo->new ('duo-ldap', 'test', $schema);
# Test deleting an integration. We can't test this entirely properly because
# currently Net::Duo::Mock::Agent doesn't support stacking multiple expected
@@ -144,8 +142,7 @@ TODO: {
local $TODO = 'Net::Duo::Mock::Agent not yet capable';
is ($object->destroy (@trace), 1, 'Duo object deletion succeeded');
- $object = eval { Wallet::Object::Duo::LDAPProxy->new ('duo-ldap', 'test',
- $schema) };
+ $object = eval { Wallet::Object::Duo->new ('duo-ldap', 'test', $schema) };
is ($object, undef, '...and now object cannot be retrieved');
is ($@, "cannot find duo:test\n", '...with correct error');
}
diff --git a/perl/t/object/duo-pam.t b/perl/t/object/duo-pam.t
index 7b88787..047343e 100644
--- a/perl/t/object/duo-pam.t
+++ b/perl/t/object/duo-pam.t
@@ -26,7 +26,7 @@ BEGIN {
BEGIN {
use_ok('Wallet::Admin');
use_ok('Wallet::Config');
- use_ok('Wallet::Object::Duo::PAM');
+ use_ok('Wallet::Object::Duo');
}
use lib 't/lib';
@@ -53,14 +53,14 @@ my $mock = Net::Duo::Mock::Agent->new ({ key_file => 't/data/duo/keys.json' });
# Test error handling in the absence of configuration.
my $object = eval {
- Wallet::Object::Duo::PAM->new ('duo-pam', 'test', $schema);
+ Wallet::Object::Duo->new ('duo-pam', 'test', $schema);
};
-is ($object, undef, 'Wallet::Object::Duo::PAM new with no config failed');
+is ($object, undef, 'Wallet::Object::Duo new with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
$object = eval {
- Wallet::Object::Duo::PAM->create ('duo-pam', 'test', $schema, @trace);
+ Wallet::Object::Duo->create ('duo-pam', 'test', $schema, @trace);
};
-is ($object, undef, 'Wallet::Object::Duo::PAM creation with no config failed');
+is ($object, undef, 'Wallet::Object::Duo creation with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
# Set up the Duo configuration.
@@ -82,9 +82,8 @@ $mock->expect (
response_file => 't/data/duo/integration.json',
}
);
-$object = Wallet::Object::Duo::PAM->create ('duo-pam', 'test', $schema,
- @trace);
-isa_ok ($object, 'Wallet::Object::Duo::PAM');
+$object = Wallet::Object::Duo->create ('duo-pam', 'test', $schema, @trace);
+isa_ok ($object, 'Wallet::Object::Duo');
# Check the metadata about the new wallet object.
$expected = <<"EOO";
@@ -126,7 +125,7 @@ is ($object->flag_clear ('locked', @trace), 1,
'...and clearing locked flag works');
# Create a new object by wallet type and name.
-$object = Wallet::Object::Duo::PAM->new ('duo-pam', 'test', $schema);
+$object = Wallet::Object::Duo->new ('duo-pam', 'test', $schema);
# Test deleting an integration. We can't test this entirely properly because
# currently Net::Duo::Mock::Agent doesn't support stacking multiple expected
@@ -143,8 +142,7 @@ TODO: {
local $TODO = 'Net::Duo::Mock::Agent not yet capable';
is ($object->destroy (@trace), 1, 'Duo object deletion succeeded');
- $object = eval { Wallet::Object::Duo::PAM->new ('duo-pam', 'test',
- $schema) };
+ $object = eval { Wallet::Object::Duo->new ('duo-pam', 'test', $schema) };
is ($object, undef, '...and now object cannot be retrieved');
is ($@, "cannot find duo:test\n", '...with correct error');
}
diff --git a/perl/t/object/duo-radius.t b/perl/t/object/duo-radius.t
index f258518..55cbb9d 100644
--- a/perl/t/object/duo-radius.t
+++ b/perl/t/object/duo-radius.t
@@ -26,7 +26,7 @@ BEGIN {
BEGIN {
use_ok('Wallet::Admin');
use_ok('Wallet::Config');
- use_ok('Wallet::Object::Duo::RadiusProxy');
+ use_ok('Wallet::Object::Duo');
}
use lib 't/lib';
@@ -53,17 +53,16 @@ my $mock = Net::Duo::Mock::Agent->new ({ key_file => 't/data/duo/keys.json' });
# Test error handling in the absence of configuration.
my $object = eval {
- Wallet::Object::Duo::RadiusProxy->new ('duo-raduys', 'test', $schema);
+ Wallet::Object::Duo->new ('duo-radius', 'test', $schema);
};
is ($object, undef,
- 'Wallet::Object::Duo::RadiusProxy new with no config failed');
+ 'Wallet::Object::Duo new with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
$object = eval {
- Wallet::Object::Duo::RadiusProxy->create ('duo-radius', 'test', $schema,
- @trace);
+ Wallet::Object::Duo->create ('duo-radius', 'test', $schema, @trace);
};
is ($object, undef,
- 'Wallet::Object::Duo::RadiusProxy creation with no config failed');
+ 'Wallet::Object::Duo creation with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
# Set up the Duo configuration.
@@ -85,9 +84,8 @@ $mock->expect (
response_file => 't/data/duo/integration-radius.json',
}
);
-$object = Wallet::Object::Duo::RadiusProxy->create ('duo-radius', 'test',
- $schema, @trace);
-isa_ok ($object, 'Wallet::Object::Duo::RadiusProxy');
+$object = Wallet::Object::Duo->create ('duo-radius', 'test', $schema, @trace);
+isa_ok ($object, 'Wallet::Object::Duo');
# Check the metadata about the new wallet object.
$expected = <<"EOO";
@@ -130,8 +128,7 @@ is ($object->flag_clear ('locked', @trace), 1,
'...and clearing locked flag works');
# Create a new object by wallet type and name.
-$object = Wallet::Object::Duo::RadiusProxy->new ('duo-radius', 'test',
- $schema);
+$object = Wallet::Object::Duo->new ('duo-radius', 'test', $schema);
# Test deleting an integration. We can't test this entirely properly because
# currently Net::Duo::Mock::Agent doesn't support stacking multiple expected
@@ -149,7 +146,7 @@ TODO: {
is ($object->destroy (@trace), 1, 'Duo object deletion succeeded');
$object = eval {
- Wallet::Object::Duo::RadiusProxy->new ('duo-radius', 'test', $schema);
+ Wallet::Object::Duo->new ('duo-radius', 'test', $schema);
};
is ($object, undef, '...and now object cannot be retrieved');
is ($@, "cannot find duo:test\n", '...with correct error');
diff --git a/perl/t/object/duo-rdp.t b/perl/t/object/duo-rdp.t
index 9b2d566..25060ac 100644
--- a/perl/t/object/duo-rdp.t
+++ b/perl/t/object/duo-rdp.t
@@ -26,7 +26,7 @@ BEGIN {
BEGIN {
use_ok('Wallet::Admin');
use_ok('Wallet::Config');
- use_ok('Wallet::Object::Duo::RDP');
+ use_ok('Wallet::Object::Duo');
}
use lib 't/lib';
@@ -53,14 +53,14 @@ my $mock = Net::Duo::Mock::Agent->new ({ key_file => 't/data/duo/keys.json' });
# Test error handling in the absence of configuration.
my $object = eval {
- Wallet::Object::Duo::RDP->new ('duo-rdp', 'test', $schema);
+ Wallet::Object::Duo->new ('duo-rdp', 'test', $schema);
};
-is ($object, undef, 'Wallet::Object::Duo::RDP new with no config failed');
+is ($object, undef, 'Wallet::Object::Duo new with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
$object = eval {
- Wallet::Object::Duo::RDP->create ('duo-rdp', 'test', $schema, @trace);
+ Wallet::Object::Duo->create ('duo-rdp', 'test', $schema, @trace);
};
-is ($object, undef, 'Wallet::Object::Duo::RDP creation with no config failed');
+is ($object, undef, 'Wallet::Object::Duo creation with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
# Set up the Duo configuration.
@@ -82,9 +82,8 @@ $mock->expect (
response_file => 't/data/duo/integration-rdp.json',
}
);
-$object = Wallet::Object::Duo::RDP->create ('duo-rdp', 'test', $schema,
- @trace);
-isa_ok ($object, 'Wallet::Object::Duo::RDP');
+$object = Wallet::Object::Duo->create ('duo-rdp', 'test', $schema, @trace);
+isa_ok ($object, 'Wallet::Object::Duo');
# Check the metadata about the new wallet object.
$expected = <<"EOO";
@@ -125,7 +124,7 @@ is ($object->flag_clear ('locked', @trace), 1,
'...and clearing locked flag works');
# Create a new object by wallet type and name.
-$object = Wallet::Object::Duo::RDP->new ('duo-rdp', 'test', $schema);
+$object = Wallet::Object::Duo->new ('duo-rdp', 'test', $schema);
# Test deleting an integration. We can't test this entirely properly because
# currently Net::Duo::Mock::Agent doesn't support stacking multiple expected
@@ -142,8 +141,7 @@ TODO: {
local $TODO = 'Net::Duo::Mock::Agent not yet capable';
is ($object->destroy (@trace), 1, 'Duo object deletion succeeded');
- $object = eval { Wallet::Object::Duo::RDP->new ('duo-rdp', 'test',
- $schema) };
+ $object = eval { Wallet::Object::Duo->new ('duo-rdp', 'test', $schema) };
is ($object, undef, '...and now object cannot be retrieved');
is ($@, "cannot find duo:test\n", '...with correct error');
}
diff --git a/perl/t/object/password.t b/perl/t/object/password.t
new file mode 100644
index 0000000..4fe6b50
--- /dev/null
+++ b/perl/t/object/password.t
@@ -0,0 +1,124 @@
+#!/usr/bin/perl
+#
+# Tests for the password object implementation. Only includes tests that are
+# basic or different from the file object implementation.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2015
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+use strict;
+use warnings;
+
+use POSIX qw(strftime);
+use Test::More tests => 33;
+
+use Wallet::Admin;
+use Wallet::Config;
+use Wallet::Object::Password;
+
+use lib 't/lib';
+use Util;
+
+# Some global defaults to use.
+my $user = 'admin@EXAMPLE.COM';
+my $host = 'localhost';
+my @trace = ($user, $host, time);
+
+# Flush all output immediately.
+$| = 1;
+
+# Use Wallet::Admin to set up the database.
+system ('rm -rf test-files') == 0 or die "cannot remove test-files\n";
+db_setup;
+my $admin = eval { Wallet::Admin->new };
+is ($@, '', 'Database connection succeeded');
+is ($admin->reinitialize ($user), 1, 'Database initialization succeeded');
+my $schema = $admin->schema;
+
+# Use this to accumulate the history traces so that we can check history.
+my $history = '';
+my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]);
+
+$Wallet::Config::PWD_FILE_BUCKET = undef;
+
+# Test error handling in the absence of configuration.
+my $object = eval {
+ Wallet::Object::Password->create ('password', 'test', $schema, @trace)
+ };
+ok (defined ($object), 'Creating a basic password object succeeds');
+ok ($object->isa ('Wallet::Object::Password'), ' and is the right class');
+is ($object->get (@trace), undef, ' and get fails');
+is ($object->error, 'password support not configured',
+ ' with the right error');
+is ($object->store (@trace), undef, ' and store fails');
+is ($object->error, 'password support not configured',
+ ' with the right error');
+is ($object->destroy (@trace), 1, ' but destroy succeeds');
+
+# Set up our configuration.
+mkdir 'test-files' or die "cannot create test-files: $!\n";
+$Wallet::Config::PWD_FILE_BUCKET = 'test-files';
+$Wallet::Config::PWD_LENGTH_MIN = 10;
+$Wallet::Config::PWD_LENGTH_MAX = 10;
+
+# Okay, now we can test. First, the basic object without store.
+$object = eval {
+ Wallet::Object::Password->create ('password', 'test', $schema, @trace)
+ };
+ok (defined ($object), 'Creating a basic password object succeeds');
+ok ($object->isa ('Wallet::Object::Password'), ' and is the right class');
+my $pwd = $object->get (@trace);
+like ($pwd, qr{^.{$Wallet::Config::PWD_LENGTH_MIN}$},
+ ' and get creates a random password string of the right length');
+ok (-d 'test-files/09', ' and the hash bucket was created');
+ok (-f 'test-files/09/test', ' and the file exists');
+is (contents ('test-files/09/test'), $pwd, ' with the right contents');
+my $pwd2 = $object->get (@trace);
+is ($pwd, $pwd2, ' and getting again gives the same string');
+is ($object->destroy (@trace), 1, ' and destroying the object succeeds');
+
+# Now check to see if the password length is adjusted.
+$Wallet::Config::PWD_LENGTH_MIN = 20;
+$Wallet::Config::PWD_LENGTH_MAX = 20;
+$object = eval {
+ Wallet::Object::Password->create ('password', 'test', $schema, @trace)
+ };
+ok (defined ($object), 'Recreating the object succeeds');
+$pwd = $object->get (@trace);
+like ($pwd, qr{^.{$Wallet::Config::PWD_LENGTH_MIN}$},
+ ' and get creates a random password string of a longer length');
+is ($object->destroy (@trace), 1, ' and destroying the object succeeds');
+
+# Now store something and be sure that we get something reasonable.
+$object = eval {
+ Wallet::Object::Password->create ('password', 'test', $schema, @trace)
+ };
+ok (defined ($object), 'Recreating the object succeeds');
+is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds');
+ok (-f 'test-files/09/test', ' and the file exists');
+is (contents ('test-files/09/test'), 'foo', ' with the right contents');
+is ($object->get (@trace), "foo\n", ' and get returns correctly');
+unlink 'test-files/09/test';
+is ($object->get (@trace), undef,
+ ' and get will not autocreate a password if there used to be data');
+is ($object->error, 'cannot get password:test: object has not been stored',
+ ' as if it had not been stored');
+is ($object->store ("bar\n\0baz\n", @trace), 1, ' but storing again works');
+ok (-f 'test-files/09/test', ' and the file exists');
+is (contents ('test-files/09/test'), 'bar', ' with the right contents');
+is ($object->get (@trace), "bar\n\0baz\n", ' and get returns correctly');
+
+# And check to make sure update changes the contents.
+$pwd = $object->update (@trace);
+isnt ($pwd, "bar\n\0baz\n", 'Update changes the contents');
+like ($pwd, qr{^.{$Wallet::Config::PWD_LENGTH_MIN}$},
+ ' to a random password string of the right length');
+
+# Clean up.
+$admin->destroy;
+END {
+ unlink ('wallet-db');
+}
diff --git a/perl/t/policy/stanford.t b/perl/t/policy/stanford.t
index 555086c..d2727c8 100755
--- a/perl/t/policy/stanford.t
+++ b/perl/t/policy/stanford.t
@@ -16,7 +16,7 @@ use 5.008;
use strict;
use warnings;
-use Test::More tests => 101;
+use Test::More tests => 130;
use lib 't/lib';
use Util;
@@ -24,10 +24,16 @@ use Util;
# Load the naming policy module.
BEGIN {
use_ok('Wallet::Admin');
- use_ok('Wallet::Policy::Stanford', qw(default_owner verify_name));
+ use_ok('Wallet::Policy::Stanford',
+ qw(default_owner verify_name is_for_host));
use_ok('Wallet::Server');
}
+# Set up our configuration for netdb, needed for the netdb verifier.
+$Wallet::Config::NETDB_REALM = 'stanford.edu';
+$Wallet::Config::NETDB_REMCTL_CACHE = $ENV{KRB5CCNAME};
+$Wallet::Config::NETDB_REMCTL_HOST = 'netdb-node-roles-rc.stanford.edu';
+
# Various valid keytab names.
my @VALID_KEYTABS = qw(host/example.stanford.edu HTTP/example.stanford.edu
service/example example/cgi class-example01/cgi dept-01example/cgi
@@ -101,160 +107,209 @@ for my $name (@INVALID_FILES) {
isnt(verify_name('file', $name), undef, "Invalid file $name");
}
-# Now we need an actual database. Use Wallet::Admin to set it up.
-db_setup;
-my $setup = eval { Wallet::Admin->new };
-is($@, q{}, 'Database initialization did not die');
-is($setup->reinitialize($ADMIN), 1, 'Database initialization succeeded');
-my $server = eval { Wallet::Server->new(@TRACE) };
-is($@, q{}, 'Server creation did not die');
+# Now test a few cases for checking to see if a file is host-based. We don't
+# test the legacy examples because they're more complicated and less obvious.
+for my $name (@VALID_KEYTABS) {
+ my $hostname = 'example.stanford.edu';
+ if ($name =~ m{\b$hostname\b}) {
+ is(is_for_host('keytab', $name, $hostname), 1,
+ "Keytab $name belongs to $hostname");
+ } else {
+ is(is_for_host('keytab', $name, $hostname), 0,
+ "Keytab $name doesn't belong to $hostname");
+ }
+}
+for my $name (@VALID_FILES) {
+ my $hostname = 'example.stanford.edu';
+ if ($name =~ m{\b$hostname\b}) {
+ is(is_for_host('file', $name, $hostname), 1,
+ "File $name belongs to $hostname");
+ } else {
+ is(is_for_host('file', $name, $hostname), 0,
+ "File $name doesn't belong to $hostname");
+ }
+}
-# Create a host/example.stanford.edu ACL that uses the netdb ACL type.
-is($server->acl_create('host/example.stanford.edu'), 1, 'Created netdb ACL');
-is(
- $server->acl_add('host/example.stanford.edu', 'netdb',
- 'example.stanford.edu'),
- 1,
- '...with netdb ACL line'
-);
-is(
- $server->acl_add('host/example.stanford.edu', 'krb5',
- 'host/example.stanford.edu@stanford.edu'),
- 1,
- '...and krb5 ACL line'
-);
+# Now we need an actual database. Use Wallet::Admin to set it up. These
+# remaining tests require creating NetDB ACLs, so need a Stanford Kerberos
+# principal currently.
+my $klist = `klist 2>&1` || '';
+SKIP: {
+ skip "tests useful only with Stanford Kerberos tickets", 27
+ unless ($klist =~ /^(Default p|\s+P)rincipal: \S+\@stanford\.edu$/m);
-# Likewise for host/foo.example.edu with the netdb-root ACL type.
-is($server->acl_create('host/foo.stanford.edu'), 1, 'Created netdb-root ACL');
-is(
- $server->acl_add('host/foo.stanford.edu', 'netdb-root',
- 'foo.stanford.edu'),
- 1,
- '...with netdb-root ACL line'
-);
-is(
- $server->acl_add('host/foo.stanford.edu', 'krb5',
- 'host/foo.stanford.edu@stanford.edu'),
- 1,
- '...and krb5 ACL line'
-);
+ db_setup;
+ my $setup = eval { Wallet::Admin->new };
+ is($@, q{}, 'Database initialization did not die');
+ is($setup->reinitialize($ADMIN), 1, 'Database initialization succeeded');
+ my $server = eval { Wallet::Server->new(@TRACE) };
+ is($@, q{}, 'Server creation did not die');
-# Create a group/its-idg ACL, which will be used for autocreation of file
-# objects.
-is($server->acl_create('group/its-idg'), 1, 'Created group/its-idg ACL');
-is($server->acl_add('group/its-idg', 'krb5', $ADMIN), 1, '...with member');
+ # Create a host/example.stanford.edu ACL that uses the netdb ACL type.
+ is(
+ $server->acl_create('host/example.stanford.edu'),
+ 1,
+ 'Created netdb ACL'
+ );
+ is($server->error, undef, ' with no error');
+ is(
+ $server->acl_add('host/example.stanford.edu', 'netdb',
+ 'example.stanford.edu'),
+ 1,
+ '...with netdb ACL line'
+ );
+ is($server->error, undef, ' with no error');
+ is(
+ $server->acl_add('host/example.stanford.edu', 'krb5',
+ 'host/example.stanford.edu@stanford.edu'),
+ 1,
+ '...and krb5 ACL line'
+ );
+ is($server->error, undef, ' with no error');
-# Now we can test default ACLs. First, without a root instance.
-local $ENV{REMOTE_USER} = $ADMIN;
-is_deeply(
- [default_owner('keytab', 'host/bar.stanford.edu')],
- [
- 'host/bar.stanford.edu',
- ['netdb', 'bar.stanford.edu'],
- ['krb5', 'host/bar.stanford.edu@stanford.edu']
- ],
- 'Correct default owner for host-based keytab'
-);
-is_deeply(
- [default_owner('keytab', 'HTTP/example.stanford.edu')],
- [
- 'host/example.stanford.edu',
- ['netdb', 'example.stanford.edu'],
- ['krb5', 'host/example.stanford.edu@stanford.edu']
- ],
- '...and when netdb ACL already exists'
-);
-is_deeply(
- [default_owner('keytab', 'webauth/foo.stanford.edu')],
- [
- 'host/foo.stanford.edu',
- ['netdb-root', 'foo.stanford.edu'],
- ['krb5', 'host/foo.stanford.edu@stanford.edu']
- ],
- '...and when netdb-root ACL already exists'
-);
+ # Likewise for host/foo.example.edu with the netdb-root ACL type.
+ is(
+ $server->acl_create('host/foo.stanford.edu'),
+ 1,
+ 'Created netdb-root ACL'
+ );
+ is(
+ $server->acl_add('host/foo.stanford.edu', 'netdb-root',
+ 'foo.stanford.edu'),
+ 1,
+ '...with netdb-root ACL line'
+ );
+ is(
+ $server->acl_add('host/foo.stanford.edu', 'krb5',
+ 'host/foo.stanford.edu@stanford.edu'),
+ 1,
+ '...and krb5 ACL line'
+ );
-# Now with a root instance.
-local $ENV{REMOTE_USER} = 'admin/root@stanford.edu';
-is_deeply(
- [default_owner('keytab', 'host/bar.stanford.edu')],
- [
- 'host/bar.stanford.edu',
- ['netdb-root', 'bar.stanford.edu'],
- ['krb5', 'host/bar.stanford.edu@stanford.edu']
- ],
- 'Correct default owner for host-based keytab for /root'
-);
-is_deeply(
- [default_owner('keytab', 'HTTP/example.stanford.edu')],
- [
- 'host/example.stanford.edu',
- ['netdb-root', 'example.stanford.edu'],
- ['krb5', 'host/example.stanford.edu@stanford.edu']
- ],
- '...and when netdb ACL already exists'
-);
-is_deeply(
- [default_owner('keytab', 'webauth/foo.stanford.edu')],
- [
- 'host/foo.stanford.edu',
- ['netdb-root', 'foo.stanford.edu'],
- ['krb5', 'host/foo.stanford.edu@stanford.edu']
- ],
- '...and when netdb-root ACL already exists'
-);
+ # Create a group/its-idg ACL, which will be used for autocreation of file
+ # objects.
+ is($server->acl_create('group/its-idg'), 1, 'Created group/its-idg ACL');
+ is($server->acl_add('group/its-idg', 'krb5', $ADMIN), 1, '...with member');
-# Check for a type that isn't host-based.
-is(default_owner('keytab', 'service/foo'), undef,
- 'No default owner for service/foo');
+ # Now we can test default ACLs. First, without a root instance.
+ local $ENV{REMOTE_USER} = $ADMIN;
+ is_deeply(
+ [default_owner('keytab', 'host/bar.stanford.edu')],
+ [
+ 'host/bar.stanford.edu',
+ ['netdb', 'bar.stanford.edu'],
+ ['krb5', 'host/bar.stanford.edu@stanford.edu']
+ ],
+ 'Correct default owner for host-based keytab'
+ );
+ is_deeply(
+ [default_owner('keytab', 'HTTP/example.stanford.edu')],
+ [
+ 'host/example.stanford.edu',
+ ['netdb', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb ACL already exists'
+ );
+ is_deeply(
+ [default_owner('keytab', 'webauth/foo.stanford.edu')],
+ [
+ 'host/foo.stanford.edu',
+ ['netdb-root', 'foo.stanford.edu'],
+ ['krb5', 'host/foo.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb-root ACL already exists'
+ );
-# Check for an unknown object type.
-is(default_owner('unknown', 'foo'), undef,
- 'No default owner for unknown type');
+ # Now with a root instance.
+ local $ENV{REMOTE_USER} = 'admin/root@stanford.edu';
+ is_deeply(
+ [default_owner('keytab', 'host/bar.stanford.edu')],
+ [
+ 'host/bar.stanford.edu',
+ ['netdb-root', 'bar.stanford.edu'],
+ ['krb5', 'host/bar.stanford.edu@stanford.edu']
+ ],
+ 'Correct default owner for host-based keytab for /root'
+ );
+ is_deeply(
+ [default_owner('keytab', 'HTTP/example.stanford.edu')],
+ [
+ 'host/example.stanford.edu',
+ ['netdb-root', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb ACL already exists'
+ );
+ is_deeply(
+ [default_owner('keytab', 'webauth/foo.stanford.edu')],
+ [
+ 'host/foo.stanford.edu',
+ ['netdb-root', 'foo.stanford.edu'],
+ ['krb5', 'host/foo.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb-root ACL already exists'
+ );
-# Check for autocreation mappings for host-based file objects.
-is_deeply(
- [default_owner('file', 'ssl-key/example.stanford.edu')],
- [
- 'host/example.stanford.edu',
- ['netdb-root', 'example.stanford.edu'],
- ['krb5', 'host/example.stanford.edu@stanford.edu']
- ],
- 'Default owner for file ssl-key/example.stanford.edu',
-);
-is_deeply(
- [default_owner('file', 'ssl-key/example.stanford.edu/mysql')],
- [
- 'host/example.stanford.edu',
- ['netdb-root', 'example.stanford.edu'],
- ['krb5', 'host/example.stanford.edu@stanford.edu']
- ],
- 'Default owner for file ssl-key/example.stanford.edu/mysql',
-);
+ # Check for a type that isn't host-based.
+ is(
+ default_owner('keytab', 'service/foo'),
+ undef,
+ 'No default owner for service/foo'
+ );
-# Check for a file object that isn't host-based.
-is_deeply(
- [default_owner('file', 'config/its-idg/example/foo')],
- ['group/its-idg', ['krb5', $ADMIN]],
- 'Default owner for file config/its-idg/example/foo',
-);
+ # Check for an unknown object type.
+ is(
+ default_owner('unknown', 'foo'),
+ undef,
+ 'No default owner for unknown type'
+ );
-# Check for legacy autocreation mappings for file objects.
-for my $type (qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key)) {
- my $name = "idg-example-$type";
+ # Check for autocreation mappings for host-based file objects.
is_deeply(
- [default_owner('file', $name)],
+ [default_owner('file', 'ssl-key/example.stanford.edu')],
[
'host/example.stanford.edu',
['netdb-root', 'example.stanford.edu'],
['krb5', 'host/example.stanford.edu@stanford.edu']
],
- "Default owner for file $name",
+ 'Default owner for file ssl-key/example.stanford.edu',
);
+ is_deeply(
+ [default_owner('file', 'ssl-key/example.stanford.edu/mysql')],
+ [
+ 'host/example.stanford.edu',
+ ['netdb-root', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ 'Default owner for file ssl-key/example.stanford.edu/mysql',
+ );
+
+ # Check for a file object that isn't host-based.
+ is_deeply(
+ [default_owner('file', 'config/its-idg/example/foo')],
+ ['group/its-idg', ['krb5', $ADMIN]],
+ 'Default owner for file config/its-idg/example/foo',
+ );
+
+ # Check for legacy autocreation mappings for file objects.
+ for my $type (qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key)) {
+ my $name = "idg-example-$type";
+ is_deeply(
+ [default_owner('file', $name)],
+ [
+ 'host/example.stanford.edu',
+ ['netdb-root', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ "Default owner for file $name",
+ );
+ }
+
+ # Clean up.
+ $setup->destroy;
}
-# Clean up.
-$setup->destroy;
END {
unlink 'wallet-db';
}
diff --git a/perl/t/verifier/ldap-attr.t b/perl/t/verifier/ldap-attr.t
index 3c132e2..cff3b63 100755
--- a/perl/t/verifier/ldap-attr.t
+++ b/perl/t/verifier/ldap-attr.t
@@ -24,16 +24,18 @@ plan skip_all => 'LDAP verifier tests only run for maintainer'
unless $ENV{RRA_MAINTAINER_TESTS};
# Declare a plan.
-plan tests => 10;
+plan tests => 22;
require_ok ('Wallet::ACL::LDAP::Attribute');
+require_ok ('Wallet::ACL::LDAP::Attribute::Root');
-my $host = 'ldap.stanford.edu';
-my $base = 'cn=people,dc=stanford,dc=edu';
-my $filter = 'uid';
-my $user = 'rra@stanford.edu';
-my $attr = 'suPrivilegeGroup';
-my $value = 'stanford:stanford';
+my $host = 'ldap.stanford.edu';
+my $base = 'cn=people,dc=stanford,dc=edu';
+my $filter = 'uid';
+my $user = 'jonrober@stanford.edu';
+my $rootuser = 'jonrober/root@stanford.edu';
+my $attr = 'suPrivilegeGroup';
+my $value = 'stanford:stanford';
# Remove the realm from principal names.
package Wallet::Config;
@@ -68,7 +70,28 @@ SKIP: {
is ($verifier->check ($user, "BOGUS=$value"), undef,
"Checking BOGUS=$value fails with error");
is ($verifier->error,
- 'cannot check LDAP attribute BOGUS for rra: Undefined attribute type',
+ 'cannot check LDAP attribute BOGUS for jonrober: Undefined attribute type',
+ '...with correct error');
+ is ($verifier->check ('user-does-not-exist', "$attr=$value"), 0,
+ "Checking for nonexistent user fails");
+ is ($verifier->error, undef, '...with no error');
+
+ # Then also test the root version.
+ $verifier = eval { Wallet::ACL::LDAP::Attribute::Root->new };
+ isa_ok ($verifier, 'Wallet::ACL::LDAP::Attribute::Root');
+ is ($verifier->check ($user, "$attr=$value"), 0,
+ "Checking as a non /root user fails");
+ is ($verifier->error, undef, '...with no error');
+ is ($verifier->check ($rootuser, "$attr=$value"), 1,
+ "Checking $attr=$value succeeds");
+ is ($verifier->error, undef, '...with no error');
+ is ($verifier->check ($rootuser, "$attr=BOGUS"), 0,
+ "Checking $attr=BOGUS fails");
+ is ($verifier->error, undef, '...with no error');
+ is ($verifier->check ($rootuser, "BOGUS=$value"), undef,
+ "Checking BOGUS=$value fails with error");
+ is ($verifier->error,
+ 'cannot check LDAP attribute BOGUS for jonrober: Undefined attribute type',
'...with correct error');
is ($verifier->check ('user-does-not-exist', "$attr=$value"), 0,
"Checking for nonexistent user fails");
diff --git a/perl/t/verifier/nested.t b/perl/t/verifier/nested.t
new file mode 100755
index 0000000..ec7ce40
--- /dev/null
+++ b/perl/t/verifier/nested.t
@@ -0,0 +1,84 @@
+#!/usr/bin/perl
+#
+# Tests for the wallet ACL nested verifier.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2015
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+use strict;
+use warnings;
+
+use Test::More tests => 22;
+
+use Wallet::ACL::Base;
+use Wallet::ACL::Nested;
+use Wallet::Admin;
+use Wallet::Config;
+
+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 $user3 = 'jack@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;
+
+# Create a few ACLs for later testing.
+my $acl = eval { Wallet::ACL->create ('test', $schema, @trace) };
+ok (defined ($acl), 'ACL creation');
+my $acl_nesting = eval { Wallet::ACL->create ('nesting', $schema, @trace) };
+ok (defined ($acl), ' and another');
+my $acl_deep = eval { Wallet::ACL->create ('deepnesting', $schema, @trace) };
+ok (defined ($acl), ' and another');
+
+# Create an verifier to make sure that works
+my $verifier = Wallet::ACL::Nested->new ('test', $schema);
+ok (defined $verifier, 'Wallet::ACL::Nested creation');
+ok ($verifier->isa ('Wallet::ACL::Nested'), ' and class verification');
+is ($verifier->syntax_check ('notcreated'), 0,
+ ' and it rejects a nested name that is not already an ACL');
+is ($verifier->syntax_check ('test'), 1,
+ ' and accepts one that already exists');
+
+# Add a few entries to one ACL and then see if they validate.
+ok ($acl->add ('krb5', $user1, @trace), 'Added test scheme');
+ok ($acl->add ('krb5', $user2, @trace), ' and another');
+ok ($acl_nesting->add ('nested', 'test', @trace), ' and then nested it');
+ok ($acl_nesting->add ('krb5', $user3, @trace),
+ ' and added a non-nesting user');
+is ($acl_nesting->check ($user1), 1, ' so check of nested succeeds');
+is ($acl_nesting->check ($user3), 1, ' so check of non-nested succeeds');
+is (scalar ($acl_nesting->list), 2,
+ ' and the acl has the right number of items');
+
+# Add a recursive nesting to make sure it doesn't send us into loop.
+ok ($acl_deep->add ('nested', 'test', @trace),
+ 'Adding deep nesting for one nest succeeds');
+ok ($acl_deep->add ('nested', 'nesting', @trace), ' and another');
+ok ($acl_deep->add ('krb5', $user3, @trace),
+ ' and added a non-nesting user');
+is ($acl_deep->check ($user1), 1, ' so check of nested succeeds');
+is ($acl_deep->check ($user3), 1, ' so check of non-nested succeeds');
+
+# Test getting an error in adding an invalid group to an ACL object itself.
+isnt ($acl->add ('nested', 'doesnotexist', @trace), 1,
+ 'Adding bad nested acl fails');
+
+# Clean up.
+$setup->destroy;
+END {
+ unlink 'wallet-db';
+}