aboutsummaryrefslogtreecommitdiff
path: root/perl
diff options
context:
space:
mode:
authorRuss Allbery <eagle@eyrie.org>2016-01-17 19:43:13 -0800
committerRuss Allbery <eagle@eyrie.org>2016-01-17 19:43:13 -0800
commitcf5297c4ec8815ecc7f5139ef05b9867843db2f7 (patch)
treefef6ba149883530c7e7fba771be6ac2e59c4dfe9 /perl
parent7e03241ce323be7447b085a8e7b07b78c770b0dc (diff)
parent4b3f858ef567c0d12511e7fea2a56f08f2729635 (diff)
Merge tag 'upstream/1.3' into debian/master
Upstream version 1.3
Diffstat (limited to 'perl')
-rw-r--r--perl/Build.PL19
-rwxr-xr-xperl/create-ddl3
-rw-r--r--perl/lib/Wallet/ACL.pm126
-rw-r--r--perl/lib/Wallet/ACL/Base.pm28
-rw-r--r--perl/lib/Wallet/ACL/External.pm192
-rw-r--r--perl/lib/Wallet/ACL/Krb5.pm14
-rw-r--r--perl/lib/Wallet/ACL/Krb5/Regex.pm12
-rw-r--r--perl/lib/Wallet/ACL/LDAP/Attribute.pm16
-rw-r--r--perl/lib/Wallet/ACL/LDAP/Attribute/Root.pm123
-rw-r--r--perl/lib/Wallet/ACL/Nested.pm186
-rw-r--r--perl/lib/Wallet/ACL/NetDB.pm14
-rw-r--r--perl/lib/Wallet/ACL/NetDB/Root.pm15
-rw-r--r--perl/lib/Wallet/Admin.pm32
-rw-r--r--perl/lib/Wallet/Config.pm206
-rw-r--r--perl/lib/Wallet/Database.pm16
-rw-r--r--perl/lib/Wallet/Kadmin.pm16
-rw-r--r--perl/lib/Wallet/Kadmin/AD.pm472
-rw-r--r--perl/lib/Wallet/Kadmin/Heimdal.pm18
-rw-r--r--perl/lib/Wallet/Kadmin/MIT.pm23
-rw-r--r--perl/lib/Wallet/Object/Base.pm21
-rw-r--r--perl/lib/Wallet/Object/Duo.pm164
-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/File.pm16
-rw-r--r--perl/lib/Wallet/Object/Keytab.pm75
-rw-r--r--perl/lib/Wallet/Object/Password.pm224
-rw-r--r--perl/lib/Wallet/Object/WAKeyring.pm16
-rw-r--r--perl/lib/Wallet/Policy/Stanford.pm149
-rw-r--r--perl/lib/Wallet/Report.pm243
-rw-r--r--perl/lib/Wallet/Schema.pm14
-rw-r--r--perl/lib/Wallet/Schema/Result/Acl.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/AclEntry.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/AclHistory.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/AclScheme.pm7
-rw-r--r--perl/lib/Wallet/Schema/Result/Duo.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/Enctype.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/Flag.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/KeytabEnctype.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/KeytabSync.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/Object.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/ObjectHistory.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/SyncTarget.pm2
-rw-r--r--perl/lib/Wallet/Schema/Result/Type.pm2
-rw-r--r--perl/lib/Wallet/Server.pm68
-rw-r--r--perl/sql/Wallet-Schema-0.10-MySQL.sql23
-rw-r--r--perl/sql/Wallet-Schema-0.10-PostgreSQL.sql23
-rw-r--r--perl/sql/Wallet-Schema-0.10-SQLite.sql22
-rw-r--r--perl/sql/wallet-1.3-update-duo.sql9
-rwxr-xr-xperl/t/data/acl-command47
-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
-rwxr-xr-xperl/t/object/keytab.t26
-rw-r--r--perl/t/object/password.t125
-rwxr-xr-xperl/t/policy/stanford.t329
-rwxr-xr-xperl/t/verifier/external.t35
-rwxr-xr-xperl/t/verifier/ldap-attr.t39
-rwxr-xr-xperl/t/verifier/nested.t84
65 files changed, 3074 insertions, 1358 deletions
diff --git a/perl/Build.PL b/perl/Build.PL
index 968ae37..c50e569 100644
--- a/perl/Build.PL
+++ b/perl/Build.PL
@@ -3,6 +3,7 @@
# Build script for the wallet distribution.
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -19,7 +20,7 @@ my $build = Module::Build->new(
dist_abstract => 'Secure credential management system',
dist_author => 'Russ Allbery <eagle@eyrie.org>',
dist_name => 'Wallet',
- dist_version => '1.01',
+ dist_version_from => 'lib/Wallet/Server.pm',
license => 'mit',
module_name => 'Wallet::Server',
recursive_test_files => 1,
@@ -36,12 +37,16 @@ my $build = Module::Build->new(
perl => '5.008',
},
recommends => {
- 'Authen::SASL' => 0,
- 'Heimdal::Kadm5' => 0,
- 'Net::Duo' => 0,
- 'Net::LDAP' => 0,
- 'Net::Remctl' => 0,
- WebAuth => 0,
+ 'Authen::SASL' => 0,
+ 'Crypt::GeneratePassword' => 0,
+ 'DateTime::Format::SQLite' => 0,
+ 'DBD::SQLite' => 0,
+ 'Heimdal::Kadm5' => 0,
+ 'IPC::Run' => 0,
+ 'Net::Duo' => 0,
+ 'Net::LDAP' => 0,
+ 'Net::Remctl' => 0,
+ WebAuth => 0,
},
);
diff --git a/perl/create-ddl b/perl/create-ddl
index b2b6f95..51fa8ff 100755
--- a/perl/create-ddl
+++ b/perl/create-ddl
@@ -57,6 +57,9 @@ exit(0);
# Documentation
##############################################################################
+=for stopwords
+DDL create-ddl
+
=head1 NAME
create-ddl - Create DDL files for Wallet
diff --git a/perl/lib/Wallet/ACL.pm b/perl/lib/Wallet/ACL.pm
index a3b0146..ad0eb2c 100644
--- a/perl/lib/Wallet/ACL.pm
+++ b/perl/lib/Wallet/ACL.pm
@@ -1,7 +1,8 @@
-# Wallet::ACL -- Implementation of ACLs in the wallet system.
+# Wallet::ACL -- Implementation of ACLs in the wallet system
#
# Written by Russ Allbery <eagle@eyrie.org>
-# Copyright 2007, 2008, 2010, 2013, 2014
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2008, 2010, 2013, 2014, 2015
# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
@@ -11,19 +12,15 @@
##############################################################################
package Wallet::ACL;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw($VERSION);
use DateTime;
-use DBI;
+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.08';
+our $VERSION = '1.03';
##############################################################################
# Constructors
@@ -197,16 +194,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 +269,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 +305,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 +323,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 +349,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 +376,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 +404,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 +459,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;
@@ -412,20 +476,21 @@ sub history {
{
my %verifier;
sub check_line {
- my ($self, $principal, $scheme, $identifier) = @_;
+ my ($self, $principal, $scheme, $identifier, $type, $name) = @_;
unless ($verifier{$scheme}) {
my $class = $self->scheme_mapping ($scheme);
unless ($class) {
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;
}
}
- my $result = ($verifier{$scheme})->check ($principal, $identifier);
+ my $result = ($verifier{$scheme})->check ($principal, $identifier,
+ $type, $name);
if (not defined $result) {
push (@{ $self->{check_errors} }, ($verifier{$scheme})->error);
return;
@@ -435,13 +500,13 @@ sub history {
}
}
-# Given a principal, check whether it should be granted access according to
-# this ACL. Returns 1 if access was granted, 0 if access was denied, and
-# undef on some error. Errors from ACL verifiers do not cause an error
-# return, but are instead accumulated in the check_errors variable returned by
-# the check_errors() method.
+# Given a principal, object type, and object name, check whether that
+# principal should be granted access according to this ACL. Returns 1 if
+# access was granted, 0 if access was denied, and undef on some error. Errors
+# from ACL verifiers do not cause an error return, but are instead accumulated
+# in the check_errors variable returned by the check_errors() method.
sub check {
- my ($self, $principal) = @_;
+ my ($self, $principal, $type, $name) = @_;
unless ($principal) {
$self->error ('no principal specified');
return;
@@ -452,7 +517,8 @@ sub check {
$self->{check_errors} = [];
for my $entry (@entries) {
my ($scheme, $identifier) = @$entry;
- my $result = $self->check_line ($principal, $scheme, $identifier);
+ my $result = $self->check_line ($principal, $scheme, $identifier,
+ $type, $name);
return 1 if $result;
}
return 0;
@@ -643,6 +709,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..235a9cb 100644
--- a/perl/lib/Wallet/ACL/Base.pm
+++ b/perl/lib/Wallet/ACL/Base.pm
@@ -1,6 +1,7 @@
-# Wallet::ACL::Base -- Parent class for wallet ACL verifiers.
+# Wallet::ACL::Base -- Parent class for wallet ACL verifiers
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2007, 2010, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,16 +12,12 @@
##############################################################################
package Wallet::ACL::Base;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-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';
+our $VERSION = '1.03';
##############################################################################
# Interface
@@ -37,6 +34,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,10 +94,18 @@ 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 check(PRINCIPAL, ACL)
+=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, TYPE, NAME)
This method should always be overridden by child classes. The default
-implementation just declines all access.
+implementation just declines all access. TYPE and NAME are the type and
+name of the object being accessed, which may be used by some ACL schemes
+or may be ignored.
=item error([ERROR ...])
diff --git a/perl/lib/Wallet/ACL/External.pm b/perl/lib/Wallet/ACL/External.pm
new file mode 100644
index 0000000..caed80e
--- /dev/null
+++ b/perl/lib/Wallet/ACL/External.pm
@@ -0,0 +1,192 @@
+# Wallet::ACL::External -- Wallet external ACL verifier
+#
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::External;
+
+use 5.008;
+use strict;
+use warnings;
+
+use POSIX qw(_exit);
+use Wallet::ACL::Base;
+use Wallet::Config;
+
+our @ISA = qw(Wallet::ACL::Base);
+our $VERSION = '1.03';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# Creates a new persistent verifier. This just checks if the configuration
+# is in place.
+sub new {
+ my $type = shift;
+ unless ($Wallet::Config::EXTERNAL_COMMAND) {
+ die "external ACL support not configured\n";
+ }
+ my $self = {};
+ bless ($self, $type);
+ return $self;
+}
+
+# The most trivial ACL verifier. Returns true if the provided principal
+# matches the ACL.
+sub check {
+ my ($self, $principal, $acl, $type, $name) = @_;
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ my @args = ($principal, $type, $name, $acl);
+ my $pid = open (EXTERNAL, '-|');
+ if (not defined $pid) {
+ $self->error ("cannot fork: $!");
+ return;
+ } elsif ($pid == 0) {
+ unless (open (STDERR, '>&STDOUT')) {
+ warn "wallet: cannot dup stdout: $!\n";
+ _exit(1);
+ }
+ unless (exec ($Wallet::Config::EXTERNAL_COMMAND, @args)) {
+ warn "wallet: cannot run $Wallet::Config::EXTERNAL_COMMAND: $!\n";
+ _exit(1);
+ }
+ }
+ local $_;
+ my @output = <EXTERNAL>;
+ close EXTERNAL;
+ if ($? == 0) {
+ return 1;
+ } else {
+ if (@output) {
+ $self->error ($output[0]);
+ return;
+ } else {
+ return 0;
+ }
+ }
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL Allbery verifier remctl
+
+=head1 NAME
+
+Wallet::ACL::External - Wallet ACL verifier using an external command
+
+=head1 SYNOPSIS
+
+ my $verifier = Wallet::ACL::External->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::External runs an external command to determine whether access is
+granted. The command configured via $EXTERNAL_COMMAND in L<Wallet::Config>
+will be run. The first argument to the command will be the principal
+requesting access. The identifier of the ACL will be split on whitespace and
+passed in as the remaining arguments to this command.
+
+No other arguments are passed to the command, but the command will have access
+to all of the remctl environment variables seen by the wallet server (such as
+REMOTE_USER). For a full list of environment variables, see
+L<remctld(8)/ENVIRONMENT>.
+
+The external command should exit with a non-zero status but no output to
+indicate a normal failure to satisfy the ACL. Any output will be treated as
+an error.
+
+=head1 METHODS
+
+=over 4
+
+=item new()
+
+Creates a new ACL verifier. For this verifier, this just confirms that
+the wallet configuration sets an external command.
+
+=item check(PRINCIPAL, ACL, TYPE, NAME)
+
+Returns true if the external command returns success when run with that
+PRINCIPAL, object TYPE and NAME, and ACL. So, for example, the ACL C<external
+mdbset shell> will, when triggered by a request from rra@EXAMPLE.COM for the
+object C<file password>, result in the command:
+
+ $Wallet::Config::EXTERNAL_COMMAND rra@EXAMPLE.COM file password \
+ 'mdbset shell'
+
+=item error()
+
+Returns the error if check() returned undef.
+
+=back
+
+=head1 DIAGNOSTICS
+
+The new() method may fail with one of the following exceptions:
+
+=over 4
+
+=item external ACL support not configured
+
+The required configuration parameters were not set. See L<Wallet::Config>
+for the required configuration parameters and how to set them.
+
+=back
+
+Verifying an external ACL may fail with the following errors (returned by
+the error() method):
+
+=over 4
+
+=item cannot fork: %s
+
+The attempt to fork in order to execute the external ACL verifier
+command failed, probably due to a lack of system resources.
+
+=item no principal specified
+
+The PRINCIPAL parameter to check() was undefined or the empty string.
+
+=back
+
+In addition, if the external command fails and produces some output,
+that will be considered a failure and the first line of its output will
+be returned as the error message. The external command should exit
+with a non-zero status but no error to indicate a normal failure.
+
+=head1 SEE ALSO
+
+remctld(8), Wallet::ACL(3), Wallet::ACL::Base(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 AUTHOR
+
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/ACL/Krb5.pm b/perl/lib/Wallet/ACL/Krb5.pm
index 80d32bd..e0e9a61 100644
--- a/perl/lib/Wallet/ACL/Krb5.pm
+++ b/perl/lib/Wallet/ACL/Krb5.pm
@@ -1,6 +1,7 @@
-# Wallet::ACL::Krb5 -- Wallet Kerberos v5 principal ACL verifier.
+# Wallet::ACL::Krb5 -- Wallet Kerberos v5 principal ACL verifier
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2007, 2010, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,20 +12,15 @@
##############################################################################
package Wallet::ACL::Krb5;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
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.02';
+our @ISA = qw(Wallet::ACL::Base);
+our $VERSION = '1.03';
##############################################################################
# Interface
diff --git a/perl/lib/Wallet/ACL/Krb5/Regex.pm b/perl/lib/Wallet/ACL/Krb5/Regex.pm
index 4934cfc..f3b9a06 100644
--- a/perl/lib/Wallet/ACL/Krb5/Regex.pm
+++ b/perl/lib/Wallet/ACL/Krb5/Regex.pm
@@ -1,6 +1,7 @@
# Wallet::ACL::Krb5::Regex -- Wallet Kerberos v5 principal regex ACL verifier
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2007, 2010, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,20 +12,15 @@
##############################################################################
package Wallet::ACL::Krb5::Regex;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
use Wallet::ACL::Krb5;
-@ISA = qw(Wallet::ACL::Krb5);
-
-# 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';
+our @ISA = qw(Wallet::ACL::Krb5);
+our $VERSION = '1.03';
##############################################################################
# Interface
diff --git a/perl/lib/Wallet/ACL/LDAP/Attribute.pm b/perl/lib/Wallet/ACL/LDAP/Attribute.pm
index c27729e..fcb8447 100644
--- a/perl/lib/Wallet/ACL/LDAP/Attribute.pm
+++ b/perl/lib/Wallet/ACL/LDAP/Attribute.pm
@@ -1,6 +1,7 @@
-# Wallet::ACL::LDAP::Attribute -- Wallet LDAP attribute ACL verifier.
+# Wallet::ACL::LDAP::Attribute -- Wallet LDAP attribute ACL verifier
#
# Written by Russ Allbery
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2012, 2013, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,23 +12,18 @@
##############################################################################
package Wallet::ACL::LDAP::Attribute;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
-use Authen::SASL ();
+use Authen::SASL;
use Net::LDAP qw(LDAP_COMPARE_TRUE);
use Wallet::ACL::Base;
use Wallet::Config;
-@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';
+our @ISA = qw(Wallet::ACL::Base);
+our $VERSION = '1.03';
##############################################################################
# Interface
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..8451394
--- /dev/null
+++ b/perl/lib/Wallet/ACL/LDAP/Attribute/Root.pm
@@ -0,0 +1,123 @@
+# Wallet::ACL::LDAP::Attribute::Root -- Wallet root instance LDAP ACL verifier
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Based on Wallet::ACL::NetDB::Root by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 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;
+
+use 5.008;
+use strict;
+use warnings;
+
+use Wallet::ACL::LDAP::Attribute;
+
+our @ISA = qw(Wallet::ACL::LDAP::Attribute);
+our $VERSION = '1.03';
+
+##############################################################################
+# 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..da42286
--- /dev/null
+++ b/perl/lib/Wallet/ACL/Nested.pm
@@ -0,0 +1,186 @@
+# Wallet::ACL::Nested - ACL class for nesting ACLs
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2016 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::Nested;
+
+use 5.008;
+use strict;
+use warnings;
+
+use Wallet::ACL::Base;
+
+our @ISA = qw(Wallet::ACL::Base);
+our $VERSION = '1.03';
+
+##############################################################################
+# 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, $type, $name) = @_;
+ 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 ($scheme, $identifier) = @{ $entry };
+ my $result = $acl->check_line ($principal, $scheme, $identifier,
+ $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/ACL/NetDB.pm b/perl/lib/Wallet/ACL/NetDB.pm
index ad2164b..a4c7fb0 100644
--- a/perl/lib/Wallet/ACL/NetDB.pm
+++ b/perl/lib/Wallet/ACL/NetDB.pm
@@ -1,6 +1,7 @@
-# Wallet::ACL::NetDB -- Wallet NetDB role ACL verifier.
+# Wallet::ACL::NetDB -- Wallet NetDB role ACL verifier
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2007, 2010, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,21 +12,16 @@
##############################################################################
package Wallet::ACL::NetDB;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
use Wallet::ACL::Base;
use Wallet::Config;
-@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.05';
+our @ISA = qw(Wallet::ACL::Base);
+our $VERSION = '1.03';
##############################################################################
# Interface
diff --git a/perl/lib/Wallet/ACL/NetDB/Root.pm b/perl/lib/Wallet/ACL/NetDB/Root.pm
index 34163e7..bfd13b4 100644
--- a/perl/lib/Wallet/ACL/NetDB/Root.pm
+++ b/perl/lib/Wallet/ACL/NetDB/Root.pm
@@ -1,6 +1,7 @@
-# Wallet::ACL::NetDB::Root -- Wallet NetDB role ACL verifier (root instances).
+# Wallet::ACL::NetDB::Root -- Wallet NetDB role ACL verifier (root instances)
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2007, 2010, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,21 +12,15 @@
##############################################################################
package Wallet::ACL::NetDB::Root;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
use Wallet::ACL::NetDB;
-use Wallet::Config;
-@ISA = qw(Wallet::ACL::NetDB);
-
-# 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';
+our @ISA = qw(Wallet::ACL::NetDB);
+our $VERSION = '1.03';
##############################################################################
# Interface
diff --git a/perl/lib/Wallet/Admin.pm b/perl/lib/Wallet/Admin.pm
index 8120e9c..9b63174 100644
--- a/perl/lib/Wallet/Admin.pm
+++ b/perl/lib/Wallet/Admin.pm
@@ -1,6 +1,7 @@
-# Wallet::Admin -- Wallet system administrative interface.
+# Wallet::Admin -- Wallet system administrative interface
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2008, 2009, 2010, 2011, 2012, 2013, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,19 +12,15 @@
##############################################################################
package Wallet::Admin;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw($VERSION);
use Wallet::ACL;
use Wallet::Schema;
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.08';
+our $VERSION = '1.03';
# The last non-DBIx::Class version of Wallet::Schema. If a database has no
# DBIx::Class versioning, we artificially install this version number before
@@ -115,22 +112,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..b8771c3 100644
--- a/perl/lib/Wallet/Config.pm
+++ b/perl/lib/Wallet/Config.pm
@@ -1,25 +1,22 @@
-# Wallet::Config -- Configuration handling for the wallet server.
+# Wallet::Config -- Configuration handling for the wallet server
#
# Written by Russ Allbery <eagle@eyrie.org>
-# Copyright 2007, 2008, 2010, 2013, 2014
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
+# Copyright 2007, 2008, 2010, 2013, 2014, 2015
# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
package Wallet::Config;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw($PATH $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.05';
+our $VERSION = '1.03';
# Path to the config file to load.
-$PATH = $ENV{WALLET_CONFIG} || '/etc/wallet/wallet.conf';
+our $PATH = $ENV{WALLET_CONFIG} || '/etc/wallet/wallet.conf';
=head1 NAME
@@ -29,7 +26,7 @@ Wallet::Config - Configuration handling for the wallet server
DBI DSN SQLite subdirectories KEYTAB keytab kadmind KDC add-ons kadmin DNS
SRV kadmin keytabs remctl backend lowercased NETDB ACL NetDB unscoped
usernames rekey hostnames Allbery wallet-backend keytab-backend Heimdal
-rekeys WebAuth WEBAUTH keyring LDAP DN GSS-API integrations
+rekeys WebAuth WEBAUTH keyring LDAP DN GSS-API integrations msktutil
=head1 SYNOPSIS
@@ -260,6 +257,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
@@ -275,7 +315,8 @@ modify, inspect, and delete any principals that should be managed by the
wallet. (In MIT Kerberos F<kadm5.acl> parlance, this is C<admci>
privileges.)
-KEYTAB_FILE must be set to use keytab objects.
+KEYTAB_FILE must be set to use keytab objects with any backend other than
+Active Directory.
=cut
@@ -292,16 +333,18 @@ is generally pointless and may interact poorly with the way C<addprinc
-randkey> works when third-party add-ons for password strength checking
are used.)
+This option is ignored when using Active Directory.
+
=cut
our $KEYTAB_FLAGS = '-clearpolicy';
=item KEYTAB_HOST
-Specifies the host on which the kadmin service is running. This setting
-overrides the C<admin_server> setting in the [realms] section of
-F<krb5.conf> and any DNS SRV records and allows the wallet to run on a
-system that doesn't have a Kerberos configuration for the wallet's realm.
+Specifies the host on which the kadmin or Active Directory service is running.
+This setting overrides the C<admin_server> setting in the [realms] section of
+F<krb5.conf> and any DNS SRV records and allows the wallet to run on a system
+that doesn't have a Kerberos configuration for the wallet's realm.
=cut
@@ -313,13 +356,15 @@ The path to the B<kadmin> command-line client. The default value is
C<kadmin>, which will cause the wallet to search for B<kadmin> on its
default PATH.
+This option is ignored when using Active Directory.
+
=cut
our $KEYTAB_KADMIN = 'kadmin';
=item KEYTAB_KRBTYPE
-The Kerberos KDC implementation type, either C<Heimdal> or C<MIT>
+The Kerberos KDC implementation type, chosen from C<AD>, C<Heimdal>, or C<MIT>
(case-insensitive). KEYTAB_KRBTYPE must be set to use keytab objects.
=cut
@@ -331,9 +376,9 @@ our $KEYTAB_KRBTYPE;
The principal whose key is stored in KEYTAB_FILE. The wallet will
authenticate as this principal to the kadmin service.
-KEYTAB_PRINCIPAL must be set to use keytab objects, at least until
-B<kadmin> is smart enough to use the first principal found in the keytab
-it's using for authentication.
+KEYTAB_PRINCIPAL must be set to use keytab objects unless Active Directory is
+the backend, at least until B<kadmin> is smart enough to use the first
+principal found in the keytab it's using for authentication.
=cut
@@ -347,7 +392,7 @@ installation and the keytab object names are stored without realm.
KEYTAB_REALM is added when talking to the KDC via B<kadmin>.
KEYTAB_REALM must be set to use keytab objects. C<ktadd> doesn't always
-default to the local realm.
+default to the local realm and the Active Directory integration requires it.
=cut
@@ -370,6 +415,69 @@ our $KEYTAB_TMP;
=back
+The following parameters are specific to generating keytabs from Active
+Directory (KEYTAB_KRBTYPE is set to C<AD>).
+
+=over 4
+
+=item AD_CACHE
+
+Specifies the ticket cache to use when manipulating Active Directory objects.
+The ticket cache must be for a principal able to bind to Active Directory and
+run B<msktutil>.
+
+AD_CACHE must be set to use Active Directory support.
+
+=cut
+
+our $AD_CACHE;
+
+=item AD_COMPUTER_DN
+
+The LDAP base DN for computer objects inside Active Directory. All keytabs of
+the form host/<hostname> will be mapped to objects with a C<samAccountName> of
+the <hostname> portion under this DN.
+
+AD_COMPUTER_DN must be set if using Active Directory as the keytab backend.
+
+=cut
+
+our $AD_COMPUTER_DN;
+
+=item AD_DEBUG
+
+If set to true, asks for some additional debugging information, such as the
+B<msktutil> command, to be logged to syslog. These debugging messages will be
+logged to the C<local3> facility.
+
+=cut
+
+our $AD_DEBUG = 0;
+
+=item AD_MSKTUTIL
+
+The path to the B<msktutil> command-line client. The default value is
+C<msktutil>, which will cause the wallet to search for B<msktutil> on its
+default PATH.
+
+=cut
+
+our $AD_MSKTUTIL = 'msktutil';
+
+=item AD_USER_DN
+
+The LDAP base DN for user objects inside Active Directory. All keytabs of the
+form service/<user> will be mapped to objects with a C<servicePrincipalName>
+matching the wallet object name under this DN.
+
+AD_USER_DN must be set if using Active Directory as the keytab backend.
+
+=cut
+
+our $AD_USER_DN;
+
+=back
+
=head2 Retrieving Existing Keytabs
Heimdal provides the choice, over the network protocol, of either
@@ -497,6 +605,36 @@ our $WAKEYRING_PURGE_INTERVAL = 60 * 60 * 24 * 90;
=back
+=head1 EXTERNAL ACL CONFIGURATION
+
+This configuration variable is only needed if you intend to use the
+C<external> ACL type (the Wallet::ACL::External class). This ACL type
+runs an external command to determine if access is granted.
+
+=over 4
+
+=item EXTERNAL_COMMAND
+
+Path to the command to run to determine whether access is granted. The first
+argument to the command will be the principal requesting access. The second
+and third arguments will be the type and name of the object that principal is
+requesting access to. The final argument will be the identifier of the ACL.
+
+No other arguments are passed to the command, but the command will have
+access to all of the remctl environment variables seen by the wallet
+server (such as REMOTE_USER). For a full list of environment variables,
+see L<remctld(8)/ENVIRONMENT>.
+
+The external command should exit with a non-zero status but no output to
+indicate a normal failure to satisfy the ACL. Any output will be treated
+as an error.
+
+=cut
+
+our $EXTERNAL_COMMAND;
+
+=back
+
=head1 LDAP ACL CONFIGURATION
These configuration variables are only needed if you intend to use the
@@ -749,6 +887,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/Database.pm b/perl/lib/Wallet/Database.pm
index 3a4e130..23b059f 100644
--- a/perl/lib/Wallet/Database.pm
+++ b/perl/lib/Wallet/Database.pm
@@ -1,4 +1,4 @@
-# Wallet::Database -- Wallet system database connection management.
+# Wallet::Database -- Wallet system database connection management
#
# This module is a thin wrapper around DBIx::Class to handle determination
# of the database configuration settings automatically on connect. The
@@ -6,6 +6,7 @@
# like DBIx::Class objects in the rest of the code.
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2008, 2009, 2010, 2012, 2013, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -16,21 +17,16 @@
##############################################################################
package Wallet::Database;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
-use Wallet::Schema;
use Wallet::Config;
+use Wallet::Schema;
-@ISA = qw(Wallet::Schema);
-
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.04';
+our @ISA = qw(Wallet::Schema);
+our $VERSION = '1.03';
##############################################################################
# Core overrides
diff --git a/perl/lib/Wallet/Kadmin.pm b/perl/lib/Wallet/Kadmin.pm
index 65a5700..8851c7e 100644
--- a/perl/lib/Wallet/Kadmin.pm
+++ b/perl/lib/Wallet/Kadmin.pm
@@ -1,6 +1,7 @@
-# Wallet::Kadmin -- Kerberos administration API for wallet keytab backend.
+# Wallet::Kadmin -- Kerberos administration API for wallet keytab backend
#
# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2009, 2010, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,18 +12,14 @@
##############################################################################
package Wallet::Kadmin;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw($VERSION);
-use Wallet::Config ();
+use Wallet::Config;
-# 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.03';
+our $VERSION = '1.03';
##############################################################################
# Utility functions for child classes
@@ -69,6 +66,9 @@ sub new {
} elsif (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'heimdal') {
require Wallet::Kadmin::Heimdal;
$kadmin = Wallet::Kadmin::Heimdal->new;
+ } elsif (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'ad') {
+ require Wallet::Kadmin::AD;
+ $kadmin = Wallet::Kadmin::AD->new;
} else {
my $type = $Wallet::Config::KEYTAB_KRBTYPE;
die "unknown KEYTAB_KRBTYPE setting: $type\n";
diff --git a/perl/lib/Wallet/Kadmin/AD.pm b/perl/lib/Wallet/Kadmin/AD.pm
new file mode 100644
index 0000000..5b71d41
--- /dev/null
+++ b/perl/lib/Wallet/Kadmin/AD.pm
@@ -0,0 +1,472 @@
+# Wallet::Kadmin::AD -- Wallet Kerberos administration API for AD
+#
+# Written by Bill MacAllister <bill@ca-zephyr.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
+# Copyright 2015 Dropbox, Inc.
+# Copyright 2007, 2008, 2009, 2010, 2014
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Kadmin::AD;
+
+use 5.008;
+use strict;
+use warnings;
+
+use Authen::SASL;
+use Net::LDAP;
+use IPC::Run qw(run timeout);
+use Sys::Syslog qw(:standard :macros);
+use Wallet::Config;
+use Wallet::Kadmin;
+
+our @ISA = qw(Wallet::Kadmin);
+our $VERSION = '1.03';
+
+##############################################################################
+# kadmin Interaction
+##############################################################################
+
+# Send debugging output to syslog.
+
+sub ad_debug {
+ my ($self, $l, $m) = @_;
+ if (!$self->{SYSLOG}) {
+ openlog('wallet-server', 'ndelay,nofatal', 'local3');
+ $self->{SYSLOG} = 1;
+ }
+ syslog($l, $m);
+ return;
+}
+
+# Make sure that principals are well-formed and don't contain
+# characters that will cause us problems when talking to kadmin.
+# Takes a principal and returns true if it's okay, false otherwise.
+# Note that we do not permit realm information here.
+sub valid_principal {
+ my ($self, $principal) = @_;
+ my $valid = 0;
+ if ($principal =~ m,^(host|service)(/[\w_.-]+)?\z,) {
+ my $k_type = $1;
+ my $k_id = $2;
+ if ($k_type eq 'host') {
+ $valid = 1 if $k_id =~ m/[.]/xms;
+ } elsif ($k_type eq 'service') {
+ $valid = 1 if length($k_id) < 19;
+ }
+ }
+ return $valid;
+}
+
+# Connect to the Active Directory server using LDAP. The connection is
+# used to retrieve information about existing keytabs since msktutil
+# does not have this functionality.
+sub ldap_connect {
+ my ($self) = @_;
+
+ if (!-e $Wallet::Config::AD_CACHE) {
+ die 'Missing kerberos ticket cache ' . $Wallet::Config::AD_CACHE;
+ }
+
+ my $ldap;
+ eval {
+ local $ENV{KRB5CCNAME} = $Wallet::Config::AD_CACHE;
+ my $sasl = Authen::SASL->new(mechanism => 'GSSAPI');
+ $ldap = Net::LDAP->new($Wallet::Config::KEYTAB_HOST, onerror => 'die');
+ my $mesg = eval { $ldap->bind(undef, sasl => $sasl) };
+ };
+ if ($@) {
+ my $error = $@;
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ die "LDAP bind to AD failed: $error\n";
+ }
+
+ return $ldap;
+}
+
+# Construct a base filter for searching Active Directory.
+
+sub ldap_base_filter {
+ my ($self, $principal) = @_;
+ my $base;
+ my $filter;
+ if ($principal =~ m,^host/(\S+),xms) {
+ my $fqdn = $1;
+ my $host = $fqdn;
+ $host =~ s/[.].*//xms;
+ $base = $Wallet::Config::AD_COMPUTER_DN;
+ $filter = "(samAccountName=${host}\$)";
+ } elsif ($principal =~ m,^service/(\S+),xms) {
+ my $id = $1;
+ $base = $Wallet::Config::AD_USER_DN;
+ $filter = "(servicePrincipalName=service/${id})";
+ }
+ return ($base, $filter);
+}
+
+# TODO: Get a keytab from the keytab cache.
+sub get_ad_keytab {
+ my ($self, $principal) = @_;
+ return;
+}
+
+# Run a msktutil command and capture the output. Returns the output,
+# either as a list of lines or, in scalar context, as one string.
+# Depending on the exit status of msktutil or on the eval trap to know
+# when the msktutil command fails. The error string returned from the
+# call to run frequently contains information about a success rather
+# that error output.
+sub msktutil {
+ my ($self, $args_ref) = @_;
+ unless (defined($Wallet::Config::KEYTAB_HOST)
+ and defined($Wallet::Config::KEYTAB_REALM))
+ {
+ die "keytab object implementation not configured\n";
+ }
+ unless (defined($Wallet::Config::AD_CACHE)
+ and defined($Wallet::Config::AD_COMPUTER_DN)
+ and defined($Wallet::Config::AD_USER_DN))
+ {
+ die "Active Directory support not configured\n";
+ }
+ my @args = @{$args_ref};
+ my @cmd = ($Wallet::Config::AD_MSKTUTIL);
+ push @cmd, @args;
+ if ($Wallet::Config::AD_DEBUG) {
+ $self->ad_debug('debug', join(' ', @cmd));
+ }
+
+ my $in;
+ my $out;
+ my $err;
+ my $err_msg;
+ my $err_no;
+ eval {
+ local $ENV{KRB5CCNAME} = $Wallet::Config::AD_CACHE;
+ run \@cmd, \$in, \$out, \$err, timeout(120);
+ if ($?) {
+ $err_no = $?;
+ }
+ };
+ if ($@) {
+ $err_msg .= "ERROR ($err_no): $@\n";
+ }
+ if ($err_no || $err_msg) {
+ if ($err) {
+ $err_msg .= "ERROR: $err\n";
+ $err_msg .= 'Problem command: ' . join(' ', @cmd) . "\n";
+ }
+ die $err_msg;
+ } else {
+ if ($err) {
+ $out .= "\n" . $err;
+ }
+ }
+ if ($Wallet::Config::AD_DEBUG) {
+ $self->ad_debug('debug', $out);
+ }
+ return $out;
+}
+
+# Either create or update a keytab for the principal. Return the
+# name of the keytab file created.
+sub ad_create_update {
+ my ($self, $principal, $action) = @_;
+ my $keytab = $Wallet::Config::KEYTAB_TMP . "/keytab.$$";
+ if (-e $keytab) {
+ unlink $keytab or die "Problem deleting $keytab\n";
+ }
+ my @cmd = ('--' . $action);
+ push @cmd, '--server', $Wallet::Config::AD_SERVER;
+ push @cmd, '--enctypes', '0x4';
+ push @cmd, '--enctypes', '0x8';
+ push @cmd, '--enctypes', '0x10';
+ push @cmd, '--keytab', $keytab;
+ push @cmd, '--realm', $Wallet::Config::KEYTAB_REALM;
+
+ if ($principal =~ m,^host/(\S+),xms) {
+ my $fqdn = $1;
+ my $host = $fqdn;
+ $host =~ s/[.].*//xms;
+ push @cmd, '--dont-expire-password';
+ push @cmd, '--computer-name', $host;
+ push @cmd, '--upn', "host/$fqdn";
+ push @cmd, '--hostname', $fqdn;
+ } elsif ($principal =~ m,^service/(\S+),xms) {
+ my $service_id = $1;
+ push @cmd, '--use-service-account';
+ push @cmd, '--service', "service/$service_id";
+ push @cmd, '--account-name', "srv-${service_id}";
+ push @cmd, '--no-pac';
+ }
+ my $out = $self->msktutil(\@cmd);
+ if ($out =~ /Error:\s+\S+\s+failed/xms) {
+ $self->ad_delete($principal);
+ my $m = "ERROR: problem creating keytab:\n" . $out;
+ $m .= 'INFO: the keytab used to by wallet probably has'
+ . " insufficient access to AD\n";
+ die $m;
+ }
+
+ return $keytab;
+}
+
+##############################################################################
+# Public interfaces
+##############################################################################
+
+# Set a callback to be called for forked kadmin processes.
+sub fork_callback {
+ my ($self, $callback) = @_;
+ $self->{fork_callback} = $callback;
+}
+
+# Check whether a given principal already exists. Returns true if so,
+# false otherwise. The best way to do this with AD is to perform an
+# ldap query.
+sub exists {
+ my ($self, $principal) = @_;
+ return unless $self->valid_principal($principal);
+
+ my $ldap = $self->ldap_connect();
+ my ($base, $filter) = $self->ldap_base_filter($principal);
+ my @attrs = ('objectClass', 'msds-KeyVersionNumber');
+
+ my $result;
+ eval {
+ $result = $ldap->search(
+ base => $base,
+ scope => 'subtree',
+ filter => $filter,
+ attrs => \@attrs
+ );
+ };
+
+ if ($@) {
+ my $error = $@;
+ die "LDAP search error: $error\n";
+ }
+ if ($result->code) {
+ my $m;
+ $m .= "INFO base:$base filter:$filter scope:subtree\n";
+ $m .= 'ERROR:' . $result->error . "\n";
+ die $m;
+ }
+ if ($result->count > 1) {
+ my $m = "ERROR: too many AD entries for this keytab\n";
+ for my $entry ($result->entries) {
+ $m .= 'INFO: dn found ' . $entry->dn . "\n";
+ }
+ die $m;
+ }
+ if ($result->count) {
+ for my $entry ($result->entries) {
+ return $entry->get_value('msds-KeyVersionNumber');
+ }
+ } else {
+ return 0;
+ }
+ return;
+}
+
+# Call msktutil to Create a principal in Kerberos. Sets the error and
+# returns undef on failure, and returns 1 on either success or if the
+# principal already exists. Note, this creates a keytab that is never
+# used because it is not returned to the user.
+sub create {
+ my ($self, $principal) = @_;
+ unless ($self->valid_principal($principal)) {
+ die "ERROR: invalid principal name $principal\n";
+ return;
+ }
+ if ($self->exists($principal)) {
+ if ($Wallet::Config::AD_DEBUG) {
+ $self->ad_debug('debug', "$principal exists");
+ }
+ return 1;
+ }
+ my $file = $self->ad_create_update($principal, 'create');
+ if (-e $file) {
+ unlink $file or die "Problem deleting $file\n";
+ }
+ return 1;
+}
+
+# TODO: Return a keytab. Need to create a local keytab cache when
+# a keytab is marked unchanging and return that.
+sub keytab {
+ my ($self, $principal) = @_;
+ unless ($self->valid_principal($principal)) {
+ die "ERROR: invalid principal name $principal\n";
+ return;
+ }
+ my $file = 'call to route to get the file name of local keytab file';
+ if (!-e $file) {
+ die "ERROR: keytab file $file does not exist.\n";
+ }
+ return $self->read_keytab($file);
+}
+
+# Update a keytab for a principal. This action changes the AD
+# password for the principal and increments the kvno. The enctypes
+# passed in are ignored.
+sub keytab_rekey {
+ my ($self, $principal, @enctypes) = @_;
+ unless ($self->valid_principal($principal)) {
+ die "ERROR: invalid principal name: $principal\n";
+ return;
+ }
+ if (!$self->exists($principal)) {
+ die "ERROR: $principal does not exist\n";
+ }
+ unless ($self->valid_principal($principal)) {
+ die "ERROR: invalid principal name $principal\n";
+ return;
+ }
+ my $file = $self->ad_create_update($principal, 'update');
+ return $self->read_keytab($file);
+}
+
+# Delete a principal from Kerberos. Return true if successful, false
+# otherwise. If the deletion fails, sets the error. If the principal
+# doesn't exist, return success; we're bringing reality in line with
+# our expectations. For AD this means just delete the object using
+# LDAP.
+sub destroy {
+ my ($self, $principal) = @_;
+ unless ($self->valid_principal($principal)) {
+ $self->error("invalid principal name: $principal");
+ }
+ my $exists = $self->exists($principal);
+ if (!defined $exists) {
+ return;
+ } elsif (not $exists) {
+ return 1;
+ }
+
+ return $self->ad_delete($principal);
+}
+
+# Delete an entry from AD using LDAP.
+
+sub ad_delete {
+ my ($self, $principal) = @_;
+
+ my $k_type;
+ my $k_id;
+ my $dn;
+ if ($principal =~ m,^(host|service)/(\S+),xms) {
+ $k_type = $1;
+ $k_id = $2;
+ if ($k_type eq 'host') {
+ my $host = $k_id;
+ $host =~ s/[.].*//;
+ $dn = "cn=${host}," . $Wallet::Config::AD_COMPUTER_DN;
+ } elsif ($k_type eq 'service') {
+ $dn = "cn=srv-${k_id}," . $Wallet::Config::AD_USER_DN;
+ }
+ }
+
+ my $ldap = $self->ldap_connect();
+ my $msgid = $ldap->delete($dn);
+ if ($msgid->code) {
+ my $m;
+ $m .= "ERROR: Problem deleting $dn\n";
+ $m .= $msgid->error;
+ die $m;
+ }
+ return 1;
+}
+
+# Create a new AD kadmin object. Very empty for the moment, but later it
+# will probably fill out if we go to using a module rather than calling
+# kadmin directly.
+sub new {
+ my ($class) = @_;
+ unless (defined($Wallet::Config::KEYTAB_TMP)) {
+ die "KEYTAB_TMP configuration variable not set\n";
+ }
+ my $self = {};
+ $self->{SYSLOG} = undef;
+ bless($self, $class);
+ return $self;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+rekeying rekeys remctl backend keytabs keytab kadmin KDC API Allbery
+unlinked MacAllister msktutil
+
+=head1 NAME
+
+Wallet::Kadmin::AD - Wallet Kerberos administration API for Active Directory
+
+=head1 SYNOPSIS
+
+ my $kadmin = Wallet::Kadmin::AD->new;
+ $kadmin->create ('host/foo.example.com');
+ my $data = $kadmin->keytab_rekey ('host/foo.example.com');
+ $data = $kadmin->keytab ('host/foo.example.com');
+ my $exists = $kadmin->exists ('host/oldshell.example.com');
+ $kadmin->destroy ('host/oldshell.example.com') if $exists;
+
+=head1 DESCRIPTION
+
+Wallet::Kadmin::AD implements the Wallet::Kadmin API for Active
+Directory Kerberos, providing an interface to create and delete
+principals and create keytabs. It provides the API documented in
+L<Wallet::Kadmin> for an Active Directory Kerberos KDC.
+
+AD Kerberos does not provide any method via msktutil to retrieve a
+keytab for a principal without rekeying it, so the keytab() method (as
+opposed to keytab_rekey(), which rekeys the principal) is implemented
+using a local keytab cache.
+
+To use this class, several configuration parameters must be set. See
+L<Wallet::Config/"KEYTAB OBJECT CONFIGURATION"> for details.
+
+=head1 FILES
+
+=over 4
+
+=item KEYTAB_TMP/keytab.<pid>
+
+The keytab is created in this file and then read into memory. KEYTAB_TMP
+is set in the wallet configuration, and <pid> is the process ID of the
+current process. The file is unlinked after being read.
+
+=back
+
+=head1 LIMITATIONS
+
+Currently, this implementation calls an external B<msktutil> program rather
+than using a native Perl module and therefore requires B<msktutil> be
+installed and parses its output.
+
+=head1 SEE ALSO
+
+msktutil, Wallet::Config(3), Wallet::Kadmin(3),
+Wallet::Object::Keytab(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
+
+Bill MacAllister <whm@dropbox.com>
+and Russ Allbery <eagle@eyrie.org>
+and Jon Robertson <jonrober@stanford.edu>.
+
+=cut
diff --git a/perl/lib/Wallet/Kadmin/Heimdal.pm b/perl/lib/Wallet/Kadmin/Heimdal.pm
index 1208801..22bdd59 100644
--- a/perl/lib/Wallet/Kadmin/Heimdal.pm
+++ b/perl/lib/Wallet/Kadmin/Heimdal.pm
@@ -1,6 +1,7 @@
-# Wallet::Kadmin::Heimdal -- Wallet Kerberos administration API for Heimdal.
+# Wallet::Kadmin::Heimdal -- Wallet Kerberos administration API for Heimdal
#
# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2009, 2010, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,22 +12,17 @@
##############################################################################
package Wallet::Kadmin::Heimdal;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
use Heimdal::Kadm5 qw(KRB5_KDB_DISALLOW_ALL_TIX);
-use Wallet::Config ();
-use Wallet::Kadmin ();
+use Wallet::Config;
+use Wallet::Kadmin;
-@ISA = qw(Wallet::Kadmin);
-
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.04';
+our @ISA = qw(Wallet::Kadmin);
+our $VERSION = '1.03';
##############################################################################
# Utility functions
diff --git a/perl/lib/Wallet/Kadmin/MIT.pm b/perl/lib/Wallet/Kadmin/MIT.pm
index ac45265..9f0f50f 100644
--- a/perl/lib/Wallet/Kadmin/MIT.pm
+++ b/perl/lib/Wallet/Kadmin/MIT.pm
@@ -1,7 +1,8 @@
-# Wallet::Kadmin::MIT -- Wallet Kerberos administration API for MIT.
+# Wallet::Kadmin::MIT -- Wallet Kerberos administration API for MIT
#
# Written by Russ Allbery <eagle@eyrie.org>
# Pulled into a module by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2007, 2008, 2009, 2010, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -12,21 +13,17 @@
##############################################################################
package Wallet::Kadmin::MIT;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
-use Wallet::Config ();
-use Wallet::Kadmin ();
+use POSIX qw(_exit);
+use Wallet::Config;
+use Wallet::Kadmin;
-@ISA = qw(Wallet::Kadmin);
-
-# 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.03';
+our @ISA = qw(Wallet::Kadmin);
+our $VERSION = '1.03';
##############################################################################
# kadmin Interaction
@@ -65,11 +62,11 @@ sub kadmin {
$self->{fork_callback} () if $self->{fork_callback};
unless (open (STDERR, '>&STDOUT')) {
warn "wallet: cannot dup stdout: $!\n";
- exit 1;
+ _exit(1);
}
unless (exec ($Wallet::Config::KEYTAB_KADMIN, @args)) {
warn "wallet: cannot run $Wallet::Config::KEYTAB_KADMIN: $!\n";
- exit 1;
+ _exit(1);
}
}
local $_;
diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm
index bdd61fb..221031f 100644
--- a/perl/lib/Wallet/Object/Base.pm
+++ b/perl/lib/Wallet/Object/Base.pm
@@ -1,6 +1,7 @@
-# Wallet::Object::Base -- Parent class for any object stored in the wallet.
+# Wallet::Object::Base -- Parent class for any object stored in the wallet
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2007, 2008, 2010, 2011, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,22 +12,17 @@
##############################################################################
package Wallet::Object::Base;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw($VERSION);
use DateTime;
use Date::Parse qw(str2time);
-use DBI;
use Text::Wrap qw(wrap);
use Wallet::ACL;
-# 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';
+our $VERSION = '1.03';
##############################################################################
# Constructors
@@ -609,6 +605,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..1aca979 100644
--- a/perl/lib/Wallet/Object/Duo.pm
+++ b/perl/lib/Wallet/Object/Duo.pm
@@ -1,7 +1,8 @@
# Wallet::Object::Duo -- Base Duo object implementation for the wallet
#
# Written by Russ Allbery <eagle@eyrie.org>
-# Copyright 2014
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
+# Copyright 2014, 2015
# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
@@ -11,25 +12,111 @@
##############################################################################
package Wallet::Object::Duo;
-require 5.006;
+use 5.008;
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::Config;
use Wallet::Object::Base;
-@ISA = qw(Wallet::Object::Base);
+our @ISA = qw(Wallet::Object::Base);
+our $VERSION = '1.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;
+};
-# 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';
+##############################################################################
+# 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
@@ -66,8 +153,20 @@ sub new {
my $key_file = $Wallet::Config::DUO_KEY_FILE;
my $agent = $Wallet::Config::DUO_AGENT;
+ # Check that we can load all of the required modules.
+ eval {
+ require Net::Duo;
+ require Net::Duo::Admin;
+ require Net::Duo::Admin::Integration;
+ };
+ if ($@) {
+ my $error = $@;
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ die "Duo object support not available: $error\n";
+ }
+
# Construct the Net::Duo::Admin object.
- require Net::Duo::Admin;
my $duo = Net::Duo::Admin->new (
{
key_file => $key_file,
@@ -86,7 +185,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,8 +194,26 @@ 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";
+ }
+
+ # Check that we can load all of the required modules.
+ eval {
+ require Net::Duo;
+ require Net::Duo::Admin;
+ require Net::Duo::Admin::Integration;
+ };
+ if ($@) {
+ my $error = $@;
+ chomp $error;
+ 1 while ($error =~ s/ at \S+ line \d+\.?\z//);
+ die "Duo object support not available: $error\n";
+ }
+
# Construct the Net::Duo::Admin object.
- require Net::Duo::Admin;
my $duo = Net::Duo::Admin->new (
{
key_file => $key_file,
@@ -105,8 +222,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 +317,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 74ff43c..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 6f90ba1..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 2e975fc..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 faa0c2f..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/File.pm b/perl/lib/Wallet/Object/File.pm
index 226e32c..9452ff4 100644
--- a/perl/lib/Wallet/Object/File.pm
+++ b/perl/lib/Wallet/Object/File.pm
@@ -1,6 +1,7 @@
-# Wallet::Object::File -- File object implementation for the wallet.
+# Wallet::Object::File -- File object implementation for the wallet
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2008, 2010, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,23 +12,18 @@
##############################################################################
package Wallet::Object::File;
-require 5.006;
+use 5.006;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
use Digest::MD5 qw(md5_hex);
use File::Copy qw(move);
-use Wallet::Config ();
+use Wallet::Config;
use Wallet::Object::Base;
-@ISA = qw(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.03';
+our @ISA = qw(Wallet::Object::Base);
+our $VERSION = '1.03';
##############################################################################
# File naming
diff --git a/perl/lib/Wallet/Object/Keytab.pm b/perl/lib/Wallet/Object/Keytab.pm
index 975179b..f276b3f 100644
--- a/perl/lib/Wallet/Object/Keytab.pm
+++ b/perl/lib/Wallet/Object/Keytab.pm
@@ -1,6 +1,7 @@
-# Wallet::Object::Keytab -- Keytab object implementation for the wallet.
+# Wallet::Object::Keytab -- Keytab object implementation for the wallet
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2007, 2008, 2009, 2010, 2013, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,22 +12,48 @@
##############################################################################
package Wallet::Object::Keytab;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
-use Wallet::Config ();
-use Wallet::Object::Base;
+use Wallet::Config;
use Wallet::Kadmin;
+use Wallet::Object::Base;
-@ISA = qw(Wallet::Object::Base);
+our @ISA = qw(Wallet::Object::Base);
+our $VERSION = '1.03';
-# 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.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 +341,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..1db53f3
--- /dev/null
+++ b/perl/lib/Wallet/Object/Password.pm
@@ -0,0 +1,224 @@
+# Wallet::Object::Password -- Password object implementation for the wallet
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2016 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::Object::Password;
+
+use 5.008;
+use strict;
+use warnings;
+
+use Crypt::GeneratePassword qw(chars);
+use Digest::MD5 qw(md5_hex);
+use Wallet::Config;
+use Wallet::Object::File;
+
+our @ISA = qw(Wallet::Object::File);
+our $VERSION = '1.03';
+
+##############################################################################
+# 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/Object/WAKeyring.pm b/perl/lib/Wallet/Object/WAKeyring.pm
index 3e80300..3c99785 100644
--- a/perl/lib/Wallet/Object/WAKeyring.pm
+++ b/perl/lib/Wallet/Object/WAKeyring.pm
@@ -1,6 +1,7 @@
-# Wallet::Object::WAKeyring -- WebAuth keyring object implementation.
+# Wallet::Object::WAKeyring -- WebAuth keyring object implementation
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2012, 2013, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,24 +12,19 @@
##############################################################################
package Wallet::Object::WAKeyring;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(@ISA $VERSION);
use Digest::MD5 qw(md5_hex);
use Fcntl qw(LOCK_EX);
-use Wallet::Config ();
+use Wallet::Config;
use Wallet::Object::Base;
use WebAuth 3.06 qw(WA_KEY_AES WA_AES_128);
-@ISA = qw(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.01';
+our @ISA = qw(Wallet::Object::Base);
+our $VERSION = '1.03';
##############################################################################
# File naming
diff --git a/perl/lib/Wallet/Policy/Stanford.pm b/perl/lib/Wallet/Policy/Stanford.pm
index a392476..efb9d28 100644
--- a/perl/lib/Wallet/Policy/Stanford.pm
+++ b/perl/lib/Wallet/Policy/Stanford.pm
@@ -1,7 +1,8 @@
-# Wallet::Policy::Stanford -- Stanford's wallet naming and ownership policy.
+# Wallet::Policy::Stanford -- Stanford's wallet naming and ownership policy
#
# Written by Russ Allbery <eagle@eyrie.org>
-# Copyright 2013
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
+# Copyright 2013, 2014, 2015
# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
@@ -25,8 +26,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.03';
+ @EXPORT_OK = qw(default_owner verify_name is_for_host);
}
##############################################################################
@@ -66,8 +67,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 +77,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 +169,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 +217,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 +241,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 +284,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 +405,8 @@ sub verify_name {
return "missing component in $name";
}
return;
+
+
} else {
# Legacy naming scheme.
my %groups = map { $_ => 1 } @GROUPS_LEGACY;
@@ -380,6 +424,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..3d59bf8 100644
--- a/perl/lib/Wallet/Report.pm
+++ b/perl/lib/Wallet/Report.pm
@@ -1,6 +1,7 @@
-# Wallet::Report -- Wallet system reporting interface.
+# Wallet::Report -- Wallet system reporting interface
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2008, 2009, 2010, 2013, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,19 +12,15 @@
##############################################################################
package Wallet::Report;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw($VERSION);
use Wallet::ACL;
use Wallet::Schema;
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.04';
+our $VERSION = '1.03';
##############################################################################
# Constructor, destructor, and accessors
@@ -175,6 +172,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 +201,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 +213,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 +239,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 +380,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 +406,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 +463,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 +576,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 +628,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 +809,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 +833,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..6b3de39 100644
--- a/perl/lib/Wallet/Schema.pm
+++ b/perl/lib/Wallet/Schema.pm
@@ -1,6 +1,7 @@
-# Database schema and connector for the wallet system.
+# Wallet::Schema -- Database schema and connector for the wallet system
#
# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2012, 2013, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -8,6 +9,7 @@
package Wallet::Schema;
+use 5.008;
use strict;
use warnings;
@@ -15,9 +17,9 @@ use Wallet::Config;
use base 'DBIx::Class::Schema';
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
+# Unlike all of the other wallet modules, this module's version is tied to the
+# version of the schema in the database. It should only be changed on schema
+# changes, at least until better handling of upgrades is available.
our $VERSION = '0.10';
__PACKAGE__->load_namespaces;
@@ -114,6 +116,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/Acl.pm b/perl/lib/Wallet/Schema/Result/Acl.pm
index 226738a..59a628a 100644
--- a/perl/lib/Wallet/Schema/Result/Acl.pm
+++ b/perl/lib/Wallet/Schema/Result/Acl.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
=for stopwords
ACL
diff --git a/perl/lib/Wallet/Schema/Result/AclEntry.pm b/perl/lib/Wallet/Schema/Result/AclEntry.pm
index a33a98c..ea531bd 100644
--- a/perl/lib/Wallet/Schema/Result/AclEntry.pm
+++ b/perl/lib/Wallet/Schema/Result/AclEntry.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
=for stopwords
ACL
diff --git a/perl/lib/Wallet/Schema/Result/AclHistory.pm b/perl/lib/Wallet/Schema/Result/AclHistory.pm
index 82e18a9..dc6bed7 100644
--- a/perl/lib/Wallet/Schema/Result/AclHistory.pm
+++ b/perl/lib/Wallet/Schema/Result/AclHistory.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
__PACKAGE__->load_components("InflateColumn::DateTime");
=for stopwords
diff --git a/perl/lib/Wallet/Schema/Result/AclScheme.pm b/perl/lib/Wallet/Schema/Result/AclScheme.pm
index 91a58b2..004e5d2 100644
--- a/perl/lib/Wallet/Schema/Result/AclScheme.pm
+++ b/perl/lib/Wallet/Schema/Result/AclScheme.pm
@@ -12,6 +12,9 @@ use strict;
use warnings;
use base 'DBIx::Class::Core';
+
+our $VERSION = '1.03';
+
__PACKAGE__->load_components (qw//);
=for stopwords
@@ -36,6 +39,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/Schema/Result/Duo.pm b/perl/lib/Wallet/Schema/Result/Duo.pm
index 6ad61e9..b5328bb 100644
--- a/perl/lib/Wallet/Schema/Result/Duo.pm
+++ b/perl/lib/Wallet/Schema/Result/Duo.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
=for stopwords
keytab enctype
diff --git a/perl/lib/Wallet/Schema/Result/Enctype.pm b/perl/lib/Wallet/Schema/Result/Enctype.pm
index 5733669..f1f42a9 100644
--- a/perl/lib/Wallet/Schema/Result/Enctype.pm
+++ b/perl/lib/Wallet/Schema/Result/Enctype.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
=for stopwords
Kerberos
diff --git a/perl/lib/Wallet/Schema/Result/Flag.pm b/perl/lib/Wallet/Schema/Result/Flag.pm
index e223ff8..84e3ee3 100644
--- a/perl/lib/Wallet/Schema/Result/Flag.pm
+++ b/perl/lib/Wallet/Schema/Result/Flag.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
=head1 NAME
Wallet::Schema::Result::Flag - Wallet schema for object flags
diff --git a/perl/lib/Wallet/Schema/Result/KeytabEnctype.pm b/perl/lib/Wallet/Schema/Result/KeytabEnctype.pm
index daea724..2a16af8 100644
--- a/perl/lib/Wallet/Schema/Result/KeytabEnctype.pm
+++ b/perl/lib/Wallet/Schema/Result/KeytabEnctype.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
=for stopwords
keytab enctype
diff --git a/perl/lib/Wallet/Schema/Result/KeytabSync.pm b/perl/lib/Wallet/Schema/Result/KeytabSync.pm
index ca84277..bd57310 100644
--- a/perl/lib/Wallet/Schema/Result/KeytabSync.pm
+++ b/perl/lib/Wallet/Schema/Result/KeytabSync.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
=for stopwords
keytab
diff --git a/perl/lib/Wallet/Schema/Result/Object.pm b/perl/lib/Wallet/Schema/Result/Object.pm
index fd64e1b..fdec3b8 100644
--- a/perl/lib/Wallet/Schema/Result/Object.pm
+++ b/perl/lib/Wallet/Schema/Result/Object.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
__PACKAGE__->load_components("InflateColumn::DateTime");
=head1 NAME
diff --git a/perl/lib/Wallet/Schema/Result/ObjectHistory.pm b/perl/lib/Wallet/Schema/Result/ObjectHistory.pm
index 5e9c8bd..2fe687e 100644
--- a/perl/lib/Wallet/Schema/Result/ObjectHistory.pm
+++ b/perl/lib/Wallet/Schema/Result/ObjectHistory.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
__PACKAGE__->load_components("InflateColumn::DateTime");
=head1 NAME
diff --git a/perl/lib/Wallet/Schema/Result/SyncTarget.pm b/perl/lib/Wallet/Schema/Result/SyncTarget.pm
index 4300a54..ab8ea47 100644
--- a/perl/lib/Wallet/Schema/Result/SyncTarget.pm
+++ b/perl/lib/Wallet/Schema/Result/SyncTarget.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
=head1 NAME
Wallet::Schema::Result::SyncTarget - Wallet schema for synchronization targets
diff --git a/perl/lib/Wallet/Schema/Result/Type.pm b/perl/lib/Wallet/Schema/Result/Type.pm
index 748a8a8..abc7017 100644
--- a/perl/lib/Wallet/Schema/Result/Type.pm
+++ b/perl/lib/Wallet/Schema/Result/Type.pm
@@ -13,6 +13,8 @@ use warnings;
use base 'DBIx::Class::Core';
+our $VERSION = '1.03';
+
=for stopwords
APIs
diff --git a/perl/lib/Wallet/Server.pm b/perl/lib/Wallet/Server.pm
index f6ea342..552ba9d 100644
--- a/perl/lib/Wallet/Server.pm
+++ b/perl/lib/Wallet/Server.pm
@@ -1,6 +1,7 @@
-# Wallet::Server -- Wallet system server implementation.
+# Wallet::Server -- Wallet system server implementation
#
# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
# Copyright 2007, 2008, 2010, 2011, 2013, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
@@ -11,20 +12,16 @@
##############################################################################
package Wallet::Server;
-require 5.006;
+use 5.008;
use strict;
use warnings;
-use vars qw(%MAPPING $VERSION);
use Wallet::ACL;
use Wallet::Config;
use Wallet::Schema;
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.11';
+our $VERSION = '1.03';
##############################################################################
# Utility methods
@@ -154,8 +151,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 +513,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 +746,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 +984,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-Schema-0.10-MySQL.sql b/perl/sql/Wallet-Schema-0.10-MySQL.sql
index c0b7fcc..ba73062 100644
--- a/perl/sql/Wallet-Schema-0.10-MySQL.sql
+++ b/perl/sql/Wallet-Schema-0.10-MySQL.sql
@@ -2,6 +2,29 @@
-- Created by SQL::Translator::Producer::MySQL
-- Created on Thu Oct 9 20:54:55 2014
--
+-- Copyright 2014
+-- The Board of Trustees of the Leland Stanford Junior University
+--
+-- Permission is hereby granted, free of charge, to any person obtaining a
+-- copy of this software and associated documentation files (the
+-- "Software"), to deal in the Software without restriction, including
+-- without limitation the rights to use, copy, modify, merge, publish,
+-- distribute, sublicense, and/or sell copies of the Software, and to
+-- permit persons to whom the Software is furnished to do so, subject to
+-- the following conditions:
+--
+-- The above copyright notice and this permission notice shall be included
+-- in all copies or substantial portions of the Software.
+--
+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+--
+
SET foreign_key_checks=0;
DROP TABLE IF EXISTS `acl_history`;
diff --git a/perl/sql/Wallet-Schema-0.10-PostgreSQL.sql b/perl/sql/Wallet-Schema-0.10-PostgreSQL.sql
index 3bcb0ae..d1658dd 100644
--- a/perl/sql/Wallet-Schema-0.10-PostgreSQL.sql
+++ b/perl/sql/Wallet-Schema-0.10-PostgreSQL.sql
@@ -2,6 +2,29 @@
-- Created by SQL::Translator::Producer::PostgreSQL
-- Created on Thu Oct 9 20:54:56 2014
--
+-- Copyright 2014
+-- The Board of Trustees of the Leland Stanford Junior University
+--
+-- Permission is hereby granted, free of charge, to any person obtaining a
+-- copy of this software and associated documentation files (the
+-- "Software"), to deal in the Software without restriction, including
+-- without limitation the rights to use, copy, modify, merge, publish,
+-- distribute, sublicense, and/or sell copies of the Software, and to
+-- permit persons to whom the Software is furnished to do so, subject to
+-- the following conditions:
+--
+-- The above copyright notice and this permission notice shall be included
+-- in all copies or substantial portions of the Software.
+--
+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+--
+
--
-- Table: acl_history.
--
diff --git a/perl/sql/Wallet-Schema-0.10-SQLite.sql b/perl/sql/Wallet-Schema-0.10-SQLite.sql
index 94a185c..c13bc29 100644
--- a/perl/sql/Wallet-Schema-0.10-SQLite.sql
+++ b/perl/sql/Wallet-Schema-0.10-SQLite.sql
@@ -1,6 +1,28 @@
--
-- Created by SQL::Translator::Producer::SQLite
-- Created on Thu Oct 9 20:51:25 2014
+--
+-- Copyright 2014
+-- The Board of Trustees of the Leland Stanford Junior University
+--
+-- Permission is hereby granted, free of charge, to any person obtaining a
+-- copy of this software and associated documentation files (the
+-- "Software"), to deal in the Software without restriction, including
+-- without limitation the rights to use, copy, modify, merge, publish,
+-- distribute, sublicense, and/or sell copies of the Software, and to
+-- permit persons to whom the Software is furnished to do so, subject to
+-- the following conditions:
+--
+-- The above copyright notice and this permission notice shall be included
+-- in all copies or substantial portions of the Software.
+--
+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
--
BEGIN TRANSACTION;
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/data/acl-command b/perl/t/data/acl-command
new file mode 100755
index 0000000..b7c3066
--- /dev/null
+++ b/perl/t/data/acl-command
@@ -0,0 +1,47 @@
+#!/bin/sh
+#
+# An external ACL implementation. Checks that the first argument is
+# eagle@eyrie.org, the second argument is "test", and then returns success,
+# failure, or reports an error based on whether the second argument is
+# success, failure, or error.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
+#
+# See LICENSE for licensing terms.
+
+set -e
+
+# Check the initial principal argument.
+if [ "$1" != 'eagle@eyrie.org' ]; then
+ echo 'incorrect principal' >&2
+ exit 1
+fi
+
+# Check that the second and third arguments are file test (the test object).
+if [ "$2" != 'file' ]; then
+ echo 'incorrect second argument' >&2
+ exit 1
+fi
+if [ "$3" != 'test' ]; then
+ echo 'incorrect third argument' >&2
+ exit 1
+fi
+
+# Process the fourth argument.
+case $4 in
+ 'test success')
+ exit 0
+ ;;
+ 'test failure')
+ exit 1
+ ;;
+ 'test error')
+ echo 'some error' >&2
+ exit 1
+ ;;
+ *)
+ echo 'unknown fourth argument' >&2
+ exit 1
+ ;;
+esac
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/keytab.t b/perl/t/object/keytab.t
index 69db438..111b7d0 100755
--- a/perl/t/object/keytab.t
+++ b/perl/t/object/keytab.t
@@ -12,7 +12,7 @@ use strict;
use warnings;
use POSIX qw(strftime);
-use Test::More tests => 141;
+use Test::More tests => 142;
BEGIN { $Wallet::Config::KEYTAB_TMP = '.' }
@@ -25,15 +25,28 @@ use Wallet::Object::Keytab;
use lib 't/lib';
use Util;
-# Mapping of klist -ke encryption type names to the strings that Kerberos uses
-# internally. It's very annoying to have to maintain this, and it probably
-# breaks with Heimdal.
+# Mapping of klist -ke output from old MIT Kerberos implementations to to the
+# strings that Kerberos uses internally. It's very annoying to have to
+# maintain this, and it probably breaks with Heimdal.
+#
+# Newer versions of MIT Kerberos just print out the canonical enctype names
+# and don't need this logic, but the current test requires that they still
+# have entries. That's why the second set where the key and value are the
+# same.
my %enctype =
('triple des cbc mode with hmac/sha1' => 'des3-cbc-sha1',
'des cbc mode with crc-32' => 'des-cbc-crc',
'des cbc mode with rsa-md5' => 'des-cbc-md5',
+ 'aes-128 cts mode with 96-bit sha-1 hmac' => 'aes128-cts-hmac-sha1-96',
'aes-256 cts mode with 96-bit sha-1 hmac' => 'aes256-cts-hmac-sha1-96',
- 'arcfour with hmac/md5' => 'rc4-hmac');
+ 'arcfour with hmac/md5' => 'rc4-hmac',
+
+ 'des3-cbc-sha1' => 'des3-cbc-sha1',
+ 'des-cbc-crc' => 'des-cbc-crc',
+ 'des-cbc-md5' => 'des-cbc-md5',
+ 'aes128-cts-hmac-sha1-96' => 'aes128-cts-hmac-sha1-96',
+ 'aes256-cts-hmac-sha1-96' => 'aes256-cts-hmac-sha1-96',
+ 'rc4-hmac' => 'rc4-hmac');
# Some global defaults to use.
my $user = 'admin@EXAMPLE.COM';
@@ -159,7 +172,7 @@ my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]);
# Basic keytab creation and manipulation tests.
SKIP: {
- skip 'no keytab configuration', 52 unless -f 't/data/test.keytab';
+ skip 'no keytab configuration', 53 unless -f 't/data/test.keytab';
# Set up our configuration.
$Wallet::Config::KEYTAB_FILE = 't/data/test.keytab';
@@ -296,6 +309,7 @@ EOO
@trace)
};
ok (defined ($object), 'Creating good principal succeeds');
+ is ($@, '', ' with no error');
ok (created ('wallet/one'), ' and the principal was created');
SKIP: {
skip 'no kadmin program test for Heimdal', 2
diff --git a/perl/t/object/password.t b/perl/t/object/password.t
new file mode 100644
index 0000000..306d82b
--- /dev/null
+++ b/perl/t/object/password.t
@@ -0,0 +1,125 @@
+#!/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 {
+ system ('rm -r test-files') == 0 or die "cannot remove test-files\n";
+ 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/external.t b/perl/t/verifier/external.t
new file mode 100755
index 0000000..d1438de
--- /dev/null
+++ b/perl/t/verifier/external.t
@@ -0,0 +1,35 @@
+#!/usr/bin/perl
+#
+# Tests for the external wallet ACL verifier.
+#
+# Written by Russ Allbery <eagle@eyrie.org>
+# Copyright 2016 Russ Allbery <eagle@eyrie.org>
+#
+# See LICENSE for licensing terms.
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+
+use Wallet::ACL::External;
+use Wallet::Config;
+
+# Configure the external ACL verifier.
+$Wallet::Config::EXTERNAL_COMMAND = 't/data/acl-command';
+
+# Check a few verifications.
+my $verifier = Wallet::ACL::External->new;
+ok (defined $verifier, 'Wallet::ACL::External creation');
+ok ($verifier->isa ('Wallet::ACL::External'), ' and class verification');
+is ($verifier->check ('eagle@eyrie.org', 'test success', 'file', 'test'),
+ 1, 'Success');
+is ($verifier->check ('eagle@eyrie.org', 'test failure', 'file', 'test'),
+ 0, 'Failure');
+is ($verifier->error, undef, 'No error set');
+is ($verifier->check ('eagle@eyrie.org', 'test error', 'file', 'test'),
+ undef, 'Error');
+is ($verifier->error, 'some error', ' and right error');
+is ($verifier->check (undef, 'eagle@eyrie.org', 'file', 'test'), undef,
+ 'Undefined principal');
+is ($verifier->error, 'no principal specified', ' and right error');
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';
+}