summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBill MacAllister <whm@dropbox.com>2015-12-18 21:54:52 +0000
committerBill MacAllister <whm@dropbox.com>2015-12-18 21:54:52 +0000
commitf61bff40b0c76b01b89f8b977eb27fdef9409c2a (patch)
tree9812f0b1c38e001d6ddd8d7343adc40fa800e338
parent0eb853eb2ef7e7063c0219ce2cbd1e239d5579b7 (diff)
parent4a777845b06b62a6deb1df5e69cc9b21226c3c2f (diff)
Merge branch 'master' into ad-keytabs
Conflicts: NEWS
-rw-r--r--NEWS42
-rw-r--r--client/wallet.pod23
-rwxr-xr-xcontrib/commerzbank/wallet-history475
-rwxr-xr-xcontrib/wallet-contacts72
-rwxr-xr-xcontrib/wallet-summary2
-rw-r--r--docs/objects-and-schemes24
-rw-r--r--docs/stanford-naming97
-rw-r--r--perl/lib/Wallet/ACL.pm96
-rw-r--r--perl/lib/Wallet/ACL/Base.pm13
-rw-r--r--perl/lib/Wallet/ACL/LDAP/Attribute/Root.pm128
-rw-r--r--perl/lib/Wallet/ACL/Nested.pm189
-rw-r--r--perl/lib/Wallet/Admin.pm21
-rw-r--r--perl/lib/Wallet/Config.pm71
-rw-r--r--perl/lib/Wallet/Object/Base.pm9
-rw-r--r--perl/lib/Wallet/Object/Duo.pm121
-rw-r--r--perl/lib/Wallet/Object/Duo/LDAPProxy.pm202
-rw-r--r--perl/lib/Wallet/Object/Duo/PAM.pm205
-rw-r--r--perl/lib/Wallet/Object/Duo/RDP.pm204
-rw-r--r--perl/lib/Wallet/Object/Duo/RadiusProxy.pm204
-rw-r--r--perl/lib/Wallet/Object/Keytab.pm59
-rw-r--r--perl/lib/Wallet/Object/Password.pm228
-rw-r--r--perl/lib/Wallet/Policy/Stanford.pm144
-rw-r--r--perl/lib/Wallet/Report.pm232
-rw-r--r--perl/lib/Wallet/Schema.pm4
-rw-r--r--perl/lib/Wallet/Schema/Result/AclScheme.pm4
-rw-r--r--perl/lib/Wallet/Server.pm57
-rw-r--r--perl/sql/wallet-1.3-update-duo.sql9
-rwxr-xr-xperl/t/general/acl.t155
-rwxr-xr-xperl/t/general/report.t51
-rwxr-xr-xperl/t/general/server.t10
-rwxr-xr-xperl/t/object/base.t5
-rw-r--r--perl/t/object/duo-ldap.t21
-rw-r--r--perl/t/object/duo-pam.t20
-rw-r--r--perl/t/object/duo-radius.t21
-rw-r--r--perl/t/object/duo-rdp.t20
-rw-r--r--perl/t/object/password.t124
-rwxr-xr-xperl/t/policy/stanford.t329
-rwxr-xr-xperl/t/verifier/ldap-attr.t39
-rwxr-xr-xperl/t/verifier/nested.t84
-rwxr-xr-xserver/wallet-backend38
-rwxr-xr-xserver/wallet-report33
41 files changed, 2688 insertions, 1197 deletions
diff --git a/NEWS b/NEWS
index 0e268a9..9ec7c1a 100644
--- a/NEWS
+++ b/NEWS
@@ -1,12 +1,40 @@
User-Visible wallet Changes
-wallet 1.3 (2015-11-27)
-
- This version implements Active Directory as the store for keytabs.
- The interface to Active Directory uses a combination of direct
- LDAP queries and the msktutil utility. This version does not
- support the wallet unchanging flag. Unchanging requires that a
- keytab be retrieved without changing the password/kvno which is
+wallet 1.3 (unreleased)
+
+ A new object type, password (Wallet::Object::Password), is now
+ supported. This is a subclass of the file object that will randomly
+ generate content for the object if you do a get before storing any
+ content inside it.
+
+ Add a new command to wallet-backend, update. This will update the
+ contents of an object before running a get on it, and is only valid
+ for objects that can automatically get new content, such as keytab and
+ password objects. A keytab will get a new kvno regardless of the
+ unchanging flag if called with update. In a future release get will
+ be changed to never update a keytab, and the unchanging flag will be
+ ignored. Please start moving to use get or update as the situation
+ warrants.
+
+ Add an acl replace command, to change all objects owned by one ACL to
+ be owned by another.
+
+ All ACL operations now refer to the ACL by name rather than ID.
+
+ Add a report for unstored objects to wallet-report, and cleaned up the
+ help for the existing unused report that implied it showed unstored as
+ well as unused.
+
+ Took contributions from Commerzbank AG to improve wallet history. Add
+ a command to dump all object history for searching on to
+ wallet-report, and add a new script for more detailed object history
+ operations to the contrib directory.
+
+ Initial support for using Active Directory as the KDC for keytab
+ creation. The interface to Active Directory uses a combination of
+ direct LDAP queries and the msktutil utility. This version does
+ not support the wallet unchanging flag. Unchanging requires that
+ a keytab be retrieved without changing the password/kvno which is
not supported by msktutil.
wallet 1.2 (2014-12-08)
diff --git a/client/wallet.pod b/client/wallet.pod
index 4b58bbf..672f0e4 100644
--- a/client/wallet.pod
+++ b/client/wallet.pod
@@ -227,6 +227,16 @@ renamed. <id> may be either the current name or the numeric ID. <name>
must not be all-numeric. To rename an ACL, the current user must be
authorized by the C<ADMIN> ACL.
+=item acl replace <id> <new-id>
+
+Find any objects owned by <id>, and then change their ownership to
+<new_id> instead. <new-id> should already exist, and may already have
+some objects owned by it. <id> is not deleted afterwards, though in
+most cases that is probably your next step. The C<ADMIN> ACL may not be
+replaced from. <id> and <new-id> may be either the current name or the
+numeric ID. To replace an ACL, the current user must be authorized by
+the C<ADMIN> ACL.
+
=item acl show <id>
Display the name, numeric ID, and entries of the ACL <id>.
@@ -375,6 +385,19 @@ If an object with type <type> and name <name> does not already exist when
this command is issued (as checked with the check interface), B<wallet>
will attempt to automatically create it (using autocreate).
+=item update <type> <name>
+
+Prints to standard output the data associated with the object identified
+by <type> and <name>, or stores it in a file if the B<-f> option was
+given. This will generate new data in the object, and only works for
+objects that support generating new data automatically, such as keytabs or
+passwords. Types that do not support generating new data will fail and
+direct you to use get instead.
+
+If an object with type <type> and name <name> does not already exist when
+this command is issued (as checked with the check interface), B<wallet>
+will attempt to automatically create it (using autocreate).
+
=back
=head1 ATTRIBUTES
diff --git a/contrib/commerzbank/wallet-history b/contrib/commerzbank/wallet-history
new file mode 100755
index 0000000..9826057
--- /dev/null
+++ b/contrib/commerzbank/wallet-history
@@ -0,0 +1,475 @@
+#!/usr/bin/perl -w
+#
+# -*- perl -*-
+#
+#--------------------------------------------------------------------------------------------------------------
+# Program : wallet-history
+# Function : Tool for listing and/or modifying Wallet's object history
+# Author : Commerzbank AG
+# History : 20.01.2014 - V0.1 - First version - maxcrc
+# : 21.01.2014 - V0.2 - Fixed some minor bugs and code formatting - Gerhard Stahl
+# Added some remarks for nessesary fixes
+# : 29.01.2014 - V0.2 - Fixed issue related to variable comparision of undef values - maxcrc
+# Reformatted code to use functions like debug, usage - maxcrc
+# : 06.02.2014 - V0.3 - Added support for ACL history in addition to object history - maxcrc
+# : 07.02.2014 - V0.4 - A lot of improvements, run with --help to see - maxcrc
+# --acl and --obj argument names removed, please use --acls and --objs
+# --from and --to argument names replaced with --start and --end
+# Added new filtering args --from, --action, --acl, --by, --type and --name
+# Added new --version action type
+# Added new --columns action type
+# : 08.02.2014 - V0.5 - Added support for ACL names via new ah_name column - maxcrc
+#
+#--------------------------------------------------------------------------------------------------------------
+#
+# Usage:
+#
+# type ./wallet-history with no arguments to get the full help text (or with --help).
+#
+# In general, use a command of the form:
+#
+# perl wallet-history.pl ... (t.b.d.)...
+#
+#--------------------------------------------------------------------------------------------------------------
+# Version.
+
+my $VERSION = "0.5";
+
+=head1 Needed Modules
+
+Here is the list of modules we need:
+
+=cut
+
+use strict;
+use Getopt::Long;
+use Wallet::Schema;
+use DateTime;
+use DateTime::Format::Strptime;
+#use DBIx::ResultSet;
+use DBI;
+#use DateTime ();
+#use Scalar::Util;
+
+my $debug_on = 0;
+
+=head1 Subroutines
+
+=head2 Utility subroutines
+
+=head3 usage - display a usage message
+
+=cut
+
+sub usage() {
+ print "wallet-history is tool for listing and/or modifying Wallet's history\n";
+ print "usage:\n";
+ print "wallet-history [mandatory action] [optional query type] [optional filtering arguments]\n";
+ print " where mandatory action is one of:\n";
+ print " --help - display this help information\n";
+ print " --version - display app version\n";
+ print " --columns - display column names (use with --objs or --acls)\n";
+ print " --list - list ACL or object history with/without from/to date filters\n";
+ print " --clear - clear ACL or object history with/without from/to date filters\n";
+ print " optional query type is one of:\n";
+ print " --acls - query is for ACL history (default is --objs)\n";
+ print " --objs - query is for object history (this is default)\n";
+ print " optional filtering data entries by (any [name] can be regular expression):\n";
+ print " --start [date/time] - starting date\n";
+ print " --end [date/time] - ending date\n";
+ print " --from [name] - computer name\n";
+ print " --action [name] - action\n";
+ print " --acl [name] - acl (with --acls only)\n";
+ print " --by [name] - by address (with --acls only)\n";
+ print " --type [name] - type (with --objs only)\n";
+ print " --name [name] - host name with --objs, acl name with --acls\n";
+}
+
+
+=head3 usage - prints debug messages
+
+=cut
+
+sub debug {
+ my $msg = @_;
+ return unless ( $debug_on == 1);
+ print $msg . "\n";
+}
+
+
+my $parser = DateTime::Format::Strptime->new(
+ pattern => '%Y-%m-%dT%H:%M:%S',
+ on_error => 'croak',
+ );
+
+my $opt_result = undef;
+my $an_action_help = undef;
+my $an_action_version = undef;
+my $an_action_columns = undef;
+my $an_action_list = undef;
+my $an_action_clear = undef;
+my $is_action_acls = 0;
+my $is_action_objs = 1;
+my $str_date_from = undef;
+my $str_date_to = undef;
+my $str_filter_computer_name = undef;
+my $str_filter_action = undef;
+my $str_filter_acl = undef;
+my $str_filter_by = undef;
+my $str_filter_type = undef;
+my $str_filter_name = undef;
+ $opt_result = GetOptions (
+ "help" => \$an_action_help
+ , "version" => \$an_action_version
+ , "columns" => \$an_action_columns
+ , "list" => \$an_action_list
+ , "clear" => \$an_action_clear
+ , "acls" => \$is_action_acls
+ , "objs" => \$is_action_objs
+ , "start=s" => \$str_date_from
+ , "end=s" => \$str_date_to
+ , "from=s" => \$str_filter_computer_name
+ , "action=s" => \$str_filter_action
+ , "acl=s" => \$str_filter_acl
+ , "by=s" => \$str_filter_by
+ , "type=s" => \$str_filter_type
+ , "name=s" => \$str_filter_name
+ );
+
+ if( ( defined $an_action_help ) or ( defined $an_action_version ) ) {
+ if( defined $an_action_version ) {
+ print "wallet-history version is $VERSION\n";
+ }
+ if( defined $an_action_help ) {
+ usage;
+ }
+ exit 0; # FIN #
+ }
+
+my $str_resultset_name = undef;
+ if( $is_action_acls ) {
+ $is_action_objs = 0;
+ $str_resultset_name = 'AclHistory';
+ } else {
+ $is_action_objs = 1;
+ $str_resultset_name = 'ObjectHistory';
+ }
+
+ if( defined $an_action_columns ) {
+ if( $is_action_acls ) {
+ print "\"ah_on\" \"ah_acl\" \"ah_by\" \"ah_action\" \"ah_from\"\n";
+ } else { if( $is_action_objs ) {
+ print "\"oh_on\" \"oh_by\" \"oh_type\" \"oh_name\" \"oh_action\" \"oh_from\"\n";
+ } else {
+ die "Critical internal error - unknown dataset type\n";
+ } }
+ exit 0; # FIN #
+ }
+
+
+my $date_from = undef;
+ if ( defined $str_date_from ) {
+ $date_from = $parser->parse_datetime( $str_date_from );
+ debug "Using minimal(from) date $date_from\n";
+ }
+my $date_to = undef;
+ if ( defined $str_date_to ) {
+ $date_to = $parser->parse_datetime( $str_date_to );
+ debug "Using maximal(to) date $date_to\n";
+ }
+
+ if ( $an_action_list || $an_action_clear ) {
+ my $schema = Wallet::Schema->connect;
+ my @data_entries;
+ eval {
+ my @data_entries_rs = $schema->resultset( $str_resultset_name )->search(); # ( $search_ref, $options_ref );
+ for my $entry_rs (@data_entries_rs) {
+ if( $is_action_acls ) {
+ # begin - working with ACLs history
+ my $is_filter_passed = 1;
+ my $str_date_on = "" . $entry_rs->ah_on;
+ my $date_on = $parser->parse_datetime( $str_date_on );
+ debug "date on as string ", $str_date_on, "\n";
+ debug "date on as date ", $date_on, "\n";
+ if ( ( defined $date_from ) || ( defined $date_to ) ) {
+ if ( ( defined $date_from ) && ( $date_from > $date_on ) ) {
+ $is_filter_passed = 0;
+ }
+ if ( ( defined $date_to ) && ( $date_to < $date_on ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if ( ( defined $date_from ) || ( defined $date_to ) )
+ if( $is_filter_passed != 0 && ( defined $str_filter_computer_name ) ) {
+ my $str_text_to_test = "" . $entry_rs->ah_from;
+ if( not ( $str_text_to_test =~ /$str_filter_computer_name/ ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if( $is_filter_passed != 0 && ( defined $str_filter_computer_name ) )
+ if( $is_filter_passed != 0 && ( defined $str_filter_action ) ) {
+ my $str_text_to_test = "" . $entry_rs->ah_action;
+ if( not ( $str_text_to_test =~ /$str_filter_action/ ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if( $is_filter_passed != 0 && ( defined $str_filter_action ) )
+ if( $is_filter_passed != 0 && ( defined $str_filter_acl ) ) {
+ my $str_text_to_test = "" . $entry_rs->ah_acl;
+ if( not ( $str_text_to_test =~ /$str_filter_acl/ ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if( $is_filter_passed != 0 && ( defined $str_filter_acl ) )
+ if( $is_filter_passed != 0 && ( defined $str_filter_by ) ) {
+ my $str_text_to_test = "" . $entry_rs->ah_by;
+ if( not ( $str_text_to_test =~ /$str_filter_by/ ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if( $is_filter_passed != 0 && ( defined $str_filter_by ) )
+ if( $is_filter_passed != 0 && ( defined $str_filter_name ) ) {
+ my $str_text_to_test = "" . $entry_rs->ah_name;
+ if( not ( $str_text_to_test =~ /$str_filter_name/ ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if( $is_filter_passed != 0 && ( defined $str_filter_name ) )
+ if( $is_filter_passed != 0 ) {
+ push (@data_entries, [$entry_rs->ah_on, $entry_rs->ah_acl, $entry_rs->ah_by, $entry_rs->ah_action, $entry_rs->ah_from, $entry_rs->ah_name ]);
+ debug "Found: \"", $entry_rs->ah_on, "\" \"", $entry_rs->ah_acl, "\" \"", $entry_rs->ah_by, "\" \"", $entry_rs->ah_action, "\" \"", $entry_rs->ah_from, "\" \"", $entry_rs->ah_name, "\n";
+ } # if( $is_filter_passed != 0 )
+ debug "walked throgh dates \"", ref($date_from), "-", $date_from, "\" \"", ref($date_on), "-", $date_on, "\" \"", ref($date_to), "-", $date_to, "\" result is ", $is_filter_passed, "\n";
+ # end - working with ACLs history
+ } else { if( $is_action_objs ) {
+ # begin - working with objects history
+ my $is_filter_passed = 1;
+ my $str_date_on = "" . $entry_rs->oh_on;
+ my $date_on = $parser->parse_datetime( $str_date_on );
+ debug "date on as string ", $str_date_on, "\n";
+ debug "date on as date ", $date_on, "\n";
+ if ( ( defined $date_from ) || ( defined $date_to ) ) {
+ if ( ( defined $date_from ) && ( $date_from > $date_on ) ) {
+ $is_filter_passed = 0;
+ }
+ if ( ( defined $date_to ) && ( $date_to < $date_on ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if ( ( defined $date_from ) || ( defined $date_to ) )
+ if( $is_filter_passed != 0 && ( defined $str_filter_computer_name ) ) {
+ my $str_text_to_test = "" . $entry_rs->oh_from;
+ if( not ( $str_text_to_test =~ /$str_filter_computer_name/ ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if( $is_filter_passed != 0 && ( defined $str_filter_computer_name ) )
+ if( $is_filter_passed != 0 && ( defined $str_filter_action ) ) {
+ my $str_text_to_test = "" . $entry_rs->oh_action;
+ if( not ( $str_text_to_test =~ /$str_filter_action/ ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if( $is_filter_passed != 0 && ( defined $str_filter_action ) )
+ if( $is_filter_passed != 0 && ( defined $str_filter_type ) ) {
+ my $str_text_to_test = "" . $entry_rs->oh_type;
+ if( not ( $str_text_to_test =~ /$str_filter_type/ ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if( $is_filter_passed != 0 && ( defined $str_filter_type ) )
+ if( $is_filter_passed != 0 && ( defined $str_filter_name ) ) {
+ my $str_text_to_test = "" . $entry_rs->oh_name;
+ if( not ( $str_text_to_test =~ /$str_filter_name/ ) ) {
+ $is_filter_passed = 0;
+ }
+ } # if( $is_filter_passed != 0 && ( defined $str_filter_name ) )
+ if( $is_filter_passed != 0 ) {
+ push (@data_entries, [$entry_rs->oh_on, $entry_rs->oh_by, $entry_rs->oh_type, $entry_rs->oh_name, $entry_rs->oh_action, $entry_rs->oh_from ]);
+ debug "Found: \"", $entry_rs->oh_on, "\" \"", $entry_rs->oh_by, "\" \"", $entry_rs->oh_type, "\" \"", $entry_rs->oh_name, "\" \"", $entry_rs->oh_action, "\" \"", $entry_rs->oh_from, "\"", "\n";
+ } # if( $is_filter_passed != 0 )
+ debug "walked throgh dates \"", ref($date_from), "-", $date_from, "\" \"", ref($date_on), "-", $date_on, "\" \"", ref($date_to), "-", $date_to, "\" result is ", $is_filter_passed, "\n";
+ # end - working with objects history
+ } else {
+ die "Critical internal error - unknown dataset type\n";
+ } }
+ } # for my $entry_rs (@data_entries_rs)
+ }; # eval
+ if ($@) {
+ print "cannot list data entries: $@";
+ exit -1;
+ }
+
+ if( $is_action_acls ) {
+ # begin - working with ACLs history
+ for my $group (@data_entries) {
+ if ( $an_action_clear ) {
+ my $is_deleted_ok = 0;
+ print "\"", join ("\" \"", @$group), "\" ... ";
+ my $sql_delete_error = undef;
+ eval {
+ my $str_ah_on = "" . $group->[0];
+ my $str_ah_acl = "" . $group->[1];
+ my $str_ah_by = "" . $group->[2];
+ my $str_ah_action = "" . $group->[3];
+ my $str_ah_from = "" . $group->[4];
+ my $str_ah_name = "" . $group->[5];
+
+ my $string = $str_ah_on; # '01234567890';
+ my $find = 'T'; # '0';
+ my $replace = ' '; # 'a';
+ my $pos = index($string, $find);
+ while ( $pos > -1 ) {
+ substr( $string, $pos, length( $find ), $replace );
+ $pos = index( $string, $find, $pos + length( $replace ));
+ }
+ $str_ah_on = $string;
+
+ debug "Searching \"$str_ah_on\" \"$str_ah_acl\" \"$str_ah_by\" \"$str_ah_action\" \"$str_ah_from\" \"$str_ah_name\" ... \n";
+
+ #my @data_entries_rs =
+ # $schema->resultset('AclHistory')->search( [
+ # { ah_on => $str_ah_on }
+ # , { ah_acl => $str_ah_acl }
+ # , { ah_by => $str_ah_by }
+ # , { ah_action => $str_ah_action }
+ # , { ah_from => $str_ah_from }
+ # , { ah_name => $str_ah_name }
+ # ] ); # -> delete;
+
+ #my @data_entries_rs =
+ # $schema->resultset('AclHistory')->search( [
+ # { ah_on => { '=' , $str_ah_on } }
+ # , { ah_acl => { '=' , $str_ah_acl } }
+ # , { ah_by => { '=' , $str_ah_by } }
+ # , { ah_action => { '=' , $str_ah_action } }
+ # , { ah_from => { '=' , $str_ah_from } }
+ # , { ah_name => { '=' , $str_ah_name } }
+ # ] ); # -> delete;
+
+ my $str_sql_del = "DELETE FROM acl_history WHERE ah_on = TO_DATE(\'" . $str_ah_on . "\', 'YYYY-MM-DD HH24:MI:SS') AND ah_acl = \'" . $str_ah_acl . "\' AND ah_by = \'" . $str_ah_by . "\' AND ah_action = \'" . $str_ah_action . "\' AND ah_from = \'" . $str_ah_from . "\' AND ah_name = \'" . $str_ah_name . "\'";
+
+ #$schema->storage->debug(1);
+ my @ret = $schema->storage->dbh_do(
+ sub {
+ my ($storage, $dbh, @args) = @_;
+ debug "Attempting to ", $str_sql_del, "\n";
+ debug "dbh is ", $dbh, "\n";
+ my $sth = $dbh->prepare( $str_sql_del );
+ #$sth->{PrintError} = 1;
+ #$sth->{RaiseError} = 1;
+ debug "sth is ", $sth, "\n";
+ my $ret = $sth->execute(); # or die "Can't execute SQL statement: $DBI::errstr\n";
+ debug "ret is ", $ret, "\n";
+ debug "error string is", $sth->errstr(), "\n";
+ if ( $ret == 0 ) {
+ $sql_delete_error = "Internal error";
+ } else {
+ $is_deleted_ok = 1;
+ }
+ },
+ $str_sql_del
+ );
+
+ #$is_deleted_ok = 1;
+
+ #for my $entry_rs (@data_entries_rs) {
+ # print "Will delete: \"", $entry_rs->ah_on, "\" \"", $entry_rs->ah_acl, "\" \"", $entry_rs->ah_by, "\" \"", $entry_rs->ah_action, "\" \"", $entry_rs->ah_from, "\"", "\n";
+ #} # for my $entry_rs (@data_entries_rs)
+
+ }; # eval
+ if ( $is_deleted_ok ) {
+ print "Deleted\n";
+ } else {
+ print "Error ", $sql_delete_error, "\n";
+ }
+ } else { # else from if ( $an_action_clear )
+ print "\"", join ("\" \"", @$group), "\"\n";
+ } # else from if ( $an_action_clear )
+ } # for my $group (@data_entries)
+ # end - working with ACLs history
+ } else { if( $is_action_objs ) {
+ # begin - working with objects history
+ for my $group (@data_entries) {
+ if ( $an_action_clear ) {
+ my $is_deleted_ok = 0;
+ print "\"", join ("\" \"", @$group), "\" ... ";
+ my $sql_delete_error = undef;
+ eval {
+ my $str_oh_on = "" . $group->[0];
+ my $str_oh_by = "" . $group->[1];
+ my $str_oh_type = "" . $group->[2];
+ my $str_oh_name = "" . $group->[3];
+ my $str_oh_action = "" . $group->[4];
+ my $str_oh_from = "" . $group->[5];
+
+ my $string = $str_oh_on; # '01234567890';
+ my $find = 'T'; # '0';
+ my $replace = ' '; # 'a';
+ my $pos = index($string, $find);
+ while ( $pos > -1 ) {
+ substr( $string, $pos, length( $find ), $replace );
+ $pos = index( $string, $find, $pos + length( $replace ));
+ }
+ $str_oh_on = $string;
+
+ debug "Searching \"$str_oh_on\" \"$str_oh_by\" \"$str_oh_type\" \"$str_oh_name\" \"$str_oh_action\" \"$str_oh_from\" ... \n";
+
+ #my @data_entries_rs =
+ # $schema->resultset('ObjectHistory')->search( [
+ # { oh_on => $str_oh_on }
+ # , { oh_type => $str_oh_type }
+ # , { oh_name => $str_oh_name }
+ # , { oh_action => $str_oh_action }
+ # , { oh_from => $str_oh_from }
+ # ] ); # -> delete;
+
+ #my @data_entries_rs =
+ # $schema->resultset('ObjectHistory')->search( [
+ # { oh_on => { '=' , $str_oh_on } }
+ # , { oh_type => { '=' , $str_oh_type } }
+ # , { oh_name => { '=' , $str_oh_name } }
+ # , { oh_action => { '=' , $str_oh_action } }
+ # , { oh_from => { '=' , $str_oh_from } }
+ # ] ); # -> delete;
+
+ my $str_sql_del = "DELETE FROM object_history WHERE oh_on = TO_DATE(\'" . $str_oh_on . "\', 'YYYY-MM-DD HH24:MI:SS') AND oh_type = \'" . $str_oh_type . "\' AND oh_name = \'" . $str_oh_name . "\' AND oh_action = \'" . $str_oh_action . "\' AND oh_from = \'" . $str_oh_from . "\'";
+
+ #$schema->storage->debug(1);
+ my @ret = $schema->storage->dbh_do(
+ sub {
+ my ($storage, $dbh, @args) = @_;
+ debug "Attempting to ", $str_sql_del, "\n";
+ debug "dbh is ", $dbh, "\n";
+ my $sth = $dbh->prepare( $str_sql_del );
+ #$sth->{PrintError} = 1;
+ #$sth->{RaiseError} = 1;
+ debug "sth is ", $sth, "\n";
+ my $ret = $sth->execute(); # or die "Can't execute SQL statement: $DBI::errstr\n";
+ debug "ret is ", $ret, "\n";
+ debug "error string is", $sth->errstr(), "\n";
+ if ( $ret == 0 ) {
+ $sql_delete_error = "Internal error";
+ } else {
+ $is_deleted_ok = 1;
+ }
+ },
+ $str_sql_del
+ );
+
+ #$is_deleted_ok = 1;
+
+ #for my $entry_rs (@data_entries_rs) {
+ # print "Will delete: \"", $entry_rs->oh_on, "\" \"", $entry_rs->oh_type, "\" \"", $entry_rs->oh_name, "\" \"", $entry_rs->oh_action, "\" \"", $entry_rs->oh_from, "\"", "\n";
+ #} # for my $entry_rs (@data_entries_rs)
+
+ }; # eval
+ if ( $is_deleted_ok ) {
+ print "Deleted\n";
+ } else {
+ print "Error ", $sql_delete_error, "\n";
+ }
+ } else { # else from if ( $an_action_clear )
+ print "\"", join ("\" \"", @$group), "\"\n";
+ } # else from if ( $an_action_clear )
+ } # for my $group (@data_entries)
+ # end - working with objects history
+ } else {
+ die "Critical internal error - unknown dataset type\n";
+ } }
+
+ exit 0; # FIN #
+ } # if ( $an_action_list || $an_action_clear )
+
+ usage;
+ exit 0; # FIN #
diff --git a/contrib/wallet-contacts b/contrib/wallet-contacts
index 2799db3..ce16ab1 100755
--- a/contrib/wallet-contacts
+++ b/contrib/wallet-contacts
@@ -3,7 +3,7 @@
# wallet-contacts -- Report contact addresses for matching wallet objects.
#
# Written by Russ Allbery <eagle@eyrie.org>
-# Copyright 2009
+# Copyright 2009, 2015
# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
@@ -12,17 +12,33 @@
# Modules and declarations
##############################################################################
-require 5.006;
-
+use 5.010;
+use autodie;
use strict;
+use warnings;
use Getopt::Long qw(GetOptions);
-use Wallet::Admin ();
+use Perl6::Slurp;
+use Wallet::Report ();
# Used to cache lookups of e-mail addresses by identifiers.
our %EMAIL;
##############################################################################
+# Mail sending
+##############################################################################
+
+# Given a message, mail it through sendmail.
+sub mail {
+ my ($message) = @_;
+
+ open (MAIL, '| /usr/sbin/sendmail -t -oi -oem')
+ or die "$0: cannot fork sendmail: $!\n";
+ print MAIL $message;
+ close (MAIL);
+}
+
+##############################################################################
# whois lookups
##############################################################################
@@ -79,9 +95,12 @@ sub whois_lookup {
##############################################################################
# Read in command-line options.
-my ($help);
+my ($help, $mail, $dryrun);
Getopt::Long::config ('no_ignore_case', 'bundling');
-GetOptions ('help|h' => \$help) or exit 1;
+GetOptions ('help|h' => \$help,
+ 'mail=s' => \$mail,
+ 'dryrun' => \$dryrun,
+ ) or exit 1;
if ($help) {
print "Feeding myself to perldoc, please wait....\n";
exec ('perldoc', '-t', $0);
@@ -95,10 +114,10 @@ if (@ARGV > 2 or not defined $name) {
$0 =~ s%.*/%%;
# Gather the list of ACL lines.
-my $admin = Wallet::Admin->new;
-my @lines = $admin->report_owners ($type, $name);
-if (!@lines and $admin->error) {
- die $admin->error, "\n";
+my $report = Wallet::Report->new;
+my @lines = $report->owners ($type, $name);
+if (!@lines and $report->error) {
+ die $report->error, "\n";
}
# Now, for each line, turn it into an e-mail address. krb5 ACLs go as-is if
@@ -127,10 +146,28 @@ for (@lines) {
}
# We now have a list of e-mail addresses. De-duplicate and then print them
-# out.
+# out or mail to them.
my %seen;
@email = grep { !$seen{$_}++ } sort @email;
-print join ("\n", @email, '');
+if ($mail) {
+ if (!-e $mail) {
+ die "mail file $mail does not exist!\n";
+ }
+
+ # Load the message and set the To header.
+ my $message = slurp($mail);
+ my $mailto = join (', ', @email);
+ $message =~ s{^To:.*$}{To: $mailto}m;
+
+ if ($dryrun) {
+ print $message;
+ } else {
+ mail ($message);
+ }
+
+} else {
+ print join ("\n", @email, '');
+}
##############################################################################
# Documentation
@@ -181,6 +218,17 @@ e-mail address for an administrator or user, it will warn but continue.
Print out this documentation (which is done simply by feeding the script
to C<perldoc -t>).
+=item B<-mail>=<fname>
+
+Takes a given email message file, replaces the contents of the To: line
+with the contacts found, and sends out that mail. This can be used for
+simple notifications that have no template requirements.
+
+=item B<-dryrun>
+
+If --mail has been set, only print to the screen rather than actually
+sending mail. Does nothing if --mail is not set.
+
=back
=head1 CAVEATS
diff --git a/contrib/wallet-summary b/contrib/wallet-summary
index 5cbf6e0..ba224d0 100755
--- a/contrib/wallet-summary
+++ b/contrib/wallet-summary
@@ -146,7 +146,7 @@ if ($mail) {
}
# Run the report.
-my @principals = read_dump ();
+my @principals = list_keytabs ();
report_principals (@principals);
# If -m was given, take the saved report and mail it as well.
diff --git a/docs/objects-and-schemes b/docs/objects-and-schemes
index 97e6289..763a24b 100644
--- a/docs/objects-and-schemes
+++ b/docs/objects-and-schemes
@@ -10,17 +10,21 @@ Introduction
Object Types
- duo
+ duo-ldap
+ duo-pam
+ duo-radius
+ duo-rdp
Stores the configuration for a Duo Security integration. Duo is a
cloud provider of multifactor authentication services. A Duo
integration consists of some local configuration and a secret key that
permits verification of a second factor using the Duo cloud service.
- Currently, only UNIX integrations are supported. In the future, this
- object type will likely be split into several object types
- corresponding to the supported types of Duo integrations.
+ Each of these types is the same except for the output, which is
+ specialized towards giving information in the format suited for a
+ specific application.
- Implemented via Wallet::Object::Duo.
+ Implemented via Wallet::Object::Duo::PAM, Wallet::Object::Duo::RDP,
+ Wallet::Object::Duo::LDAPProxy, Wallet::Object::Duo::RadiusProxy.
file
@@ -33,6 +37,16 @@ Object Types
Implemented via Wallet::Object::File.
+ password
+
+ Stores a file with single password in it and allows retrieval of that
+ file. This is built on the file object and is almost entirely
+ identical in function. It adds the ability to automatically generate
+ randomized content if you get the object before it's been stored,
+ letting you get autogenerated passwords.
+
+ Implemented via Wallet::Object::Password.
+
keytab
Stores a keytab representing private keys for a given Kerberos
diff --git a/docs/stanford-naming b/docs/stanford-naming
index c86c820..cb05a23 100644
--- a/docs/stanford-naming
+++ b/docs/stanford-naming
@@ -90,27 +90,6 @@ Object Naming
(OLD: <group>-<server>-htpasswd-<app>)
- password-ipmi/<server>
-
- Stores the password for remote IPMI/iLO/ILOM access to the
- system.
-
- (OLD: <group>-<server>-password-ipmi)
-
- password-root/<server>
-
- Stores the root password for a given server.
-
- (OLD: <group>-<server>-password-root)
-
- password-tivoli/<server>
-
- Stores the Tivoli TSM backup password for a given server. See
- also tivoli-key/<server>, but depending on what one wants to do
- with the password, this may be a better representation.
-
- (OLD: <group>-<server>-password-tivoli)
-
ssh-<type>/<server>
Stores the SSH private key for <server>. For shared private keys
@@ -197,20 +176,6 @@ Object Naming
(OLD: <group>-<service>-gpg-key)
- password/<group>/<service>/<name>
-
- A password for some account, service, keystore, or something
- similar that is not covered by one of the more specific naming
- conventions, such as a password used to connect to a remote ssh
- service. <service> is the service that uses this password and
- <name> is the thing the password is used for (such as the remote
- account name). This may be a file containing only the password,
- or a configuration file of some type that includes a field name
- and the password. (However, use the db type described above for
- database passwords.)
-
- (OLD: <group>-<server>-password-<account>)
-
properties/<group>/<service>[/<name>]
The properties file for a Java application that contains some
@@ -262,6 +227,68 @@ Object Naming
<group>-<server>-pam-<app>
<group>-<service>-puppetconf
<group>-<service>-shibboleth
+ <group>-<server>-password-ipmi
+ <group>-<server>-password-root
+ <group>-<server>-password-tivoli
+ <group>-<server>-password-<account>
+
+ Replaced by password objects:
+
+ password-ipmi/<server>
+ password-root/<server>
+ password-tivoli/<server>
+
+ password/<group>/<service>/<name> should be replaced by the password
+ service/<group>/<service>/<name> object if a single password, or by
+ the file object db/* or config/* format if the object contains more
+ than just the bare password.
+
+ Password
+
+ Passwords are a recent type and so most password data is actually
+ in file objects. However, we'd like to move things there both for
+ the added features of password objects to self-set, and because it
+ helps clean up the file namespace a little more.
+
+ Host-based:
+
+ ipmi/<server>
+
+ Stores the password for remote IPMI/iLO/ILOM access to the
+ system.
+
+ tivoli/<server>
+
+ Stores the Tivoli TSM backup password for a given server. See
+ also tivoli-key/<server> in the file section, but depending on
+ what one wants to do with the password, this may be a better
+ representation.
+
+ root/<server>
+
+ Stores the root password for a given server.
+
+ system/<server>/<account>
+
+ Stores the password for a non-root system account, such as a user
+ required for file uploads.
+
+ app/<server>/<application>
+
+ Stores an application password bound to a certain server.
+
+ Service-based:
+
+ service/<group>/<service>/<name>
+
+ A password for some account, service, keystore, or something
+ similar that is not covered by one of the more specific naming
+ conventions, such as a password used to connect to a remote ssh
+ service. <service> is the service that uses this password and
+ <name> is the thing the password is used for (such as the remote
+ account name). This should only be for something including the
+ password and nothing else. See the file password/ object name
+ for something that includes more data.
ACL Naming
diff --git a/perl/lib/Wallet/ACL.pm b/perl/lib/Wallet/ACL.pm
index a3b0146..862b88f 100644
--- a/perl/lib/Wallet/ACL.pm
+++ b/perl/lib/Wallet/ACL.pm
@@ -1,7 +1,7 @@
# Wallet::ACL -- Implementation of ACLs in the wallet system.
#
# Written by Russ Allbery <eagle@eyrie.org>
-# Copyright 2007, 2008, 2010, 2013, 2014
+# Copyright 2007, 2008, 2010, 2013, 2014, 2015
# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
@@ -17,13 +17,14 @@ use strict;
use warnings;
use vars qw($VERSION);
+use Wallet::Object::Base;
use DateTime;
use DBI;
# This version should be increased on any code change to this module. Always
# use two digits for the minor version with a leading zero if necessary so
# that it will sort properly.
-$VERSION = '0.08';
+$VERSION = '0.09';
##############################################################################
# Constructors
@@ -197,16 +198,55 @@ sub rename {
$acls->ac_name ($name);
$acls->update;
$self->log_acl ('rename', undef, undef, $user, $host, $time);
+
+ # Find any references to this being used as a nested verifier and
+ # update the name. This really breaks out of the normal flow, but
+ # it's hard to do otherwise.
+ %search = (ae_scheme => 'nested',
+ ae_identifier => $self->{name},
+ );
+ my @entries = $self->{schema}->resultset('AclEntry')->search(\%search);
+ for my $entry (@entries) {
+ $entry->ae_identifier ($name);
+ $entry->update;
+ }
+
$guard->commit;
};
if ($@) {
- $self->error ("cannot rename ACL $self->{id} to $name: $@");
+ $self->error ("cannot rename ACL $self->{name} to $name: $@");
return;
}
$self->{name} = $name;
return 1;
}
+# Moves everything owned by one ACL to instead be owned by another. You'll
+# normally want to use rename, but this exists for cases where the replacing
+# ACL already exists and has things assigned to it. Returns true on success,
+# false on failure.
+sub replace {
+ my ($self, $replace_id, $user, $host, $time) = @_;
+ $time ||= time;
+
+ my %search = (ob_owner => $self->{id});
+ my @objects = $self->{schema}->resultset('Object')->search (\%search);
+ if (@objects) {
+ for my $object (@objects) {
+ my $type = $object->ob_type;
+ my $name = $object->ob_name;
+ my $object = eval {
+ Wallet::Object::Base->new($type, $name, $self->{schema});
+ };
+ $object->owner ($replace_id, $user, $host, $time);
+ }
+ } else {
+ $self->error ("no objects found for ACL $self->{name}");
+ return;
+ }
+ return 1;
+}
+
# Destroy the ACL, deleting it out of the database. Returns true on success,
# false on failure.
#
@@ -233,8 +273,20 @@ sub destroy {
die "ACL in use by ".$entry->ob_type.":".$entry->ob_name;
}
+ # Also make certain the ACL isn't being nested in another.
+ my %search = (ae_scheme => 'nested',
+ ae_identifier => $self->{name});
+ my %options = (join => 'acls',
+ prefetch => 'acls');
+ @entries = $self->{schema}->resultset('AclEntry')->search(\%search,
+ \%options);
+ if (@entries) {
+ my ($entry) = @entries;
+ die "ACL is nested in ACL ".$entry->acls->ac_name;
+ }
+
# Delete any entries (there may or may not be any).
- my %search = (ae_id => $self->{id});
+ %search = (ae_id => $self->{id});
@entries = $self->{schema}->resultset('AclEntry')->search(\%search);
for my $entry (@entries) {
$entry->delete;
@@ -257,7 +309,7 @@ sub destroy {
$guard->commit;
};
if ($@) {
- $self->error ("cannot destroy ACL $self->{id}: $@");
+ $self->error ("cannot destroy ACL $self->{name}: $@");
return;
}
return 1;
@@ -275,6 +327,22 @@ sub add {
$self->error ("unknown ACL scheme $scheme");
return;
}
+
+ # Check to make sure that this entry has a valid name for the scheme.
+ my $class = $self->scheme_mapping ($scheme);
+ my $object = eval {
+ $class->new ($identifier, $self->{schema});
+ };
+ if ($@) {
+ $self->error ("cannot create ACL verifier: $@");
+ return;
+ }
+ unless ($object && $object->syntax_check ($identifier)) {
+ $self->error ("invalid ACL identifier $identifier for $scheme");
+ return;
+ };
+
+ # Actually create the scheme.
eval {
my $guard = $self->{schema}->txn_scope_guard;
my %record = (ae_id => $self->{id},
@@ -285,7 +353,7 @@ sub add {
$guard->commit;
};
if ($@) {
- $self->error ("cannot add $scheme:$identifier to $self->{id}: $@");
+ $self->error ("cannot add $scheme:$identifier to $self->{name}: $@");
return;
}
return 1;
@@ -312,7 +380,7 @@ sub remove {
};
if ($@) {
my $entry = "$scheme:$identifier";
- $self->error ("cannot remove $entry from $self->{id}: $@");
+ $self->error ("cannot remove $entry from $self->{name}: $@");
return;
}
return 1;
@@ -340,7 +408,7 @@ sub list {
$guard->commit;
};
if ($@) {
- $self->error ("cannot retrieve ACL $self->{id}: $@");
+ $self->error ("cannot retrieve ACL $self->{name}: $@");
return;
} else {
return @entries;
@@ -395,7 +463,7 @@ sub history {
$guard->commit;
};
if ($@) {
- $self->error ("cannot read history for $self->{id}: $@");
+ $self->error ("cannot read history for $self->{name}: $@");
return;
}
return $output;
@@ -419,7 +487,7 @@ sub history {
push (@{ $self->{check_errors} }, "unknown scheme $scheme");
return;
}
- $verifier{$scheme} = $class->new;
+ $verifier{$scheme} = $class->new ($identifier, $self->{schema});
unless (defined $verifier{$scheme}) {
push (@{ $self->{check_errors} }, "cannot verify $scheme");
return;
@@ -643,6 +711,14 @@ On failure, the caller should call error() to get the error message.
Note that rename() operations are not logged in the ACL history.
+=item replace(ID)
+
+Replace this ACL with another. This goes through each object owned by
+the ACL and changes its ownership to the new ACL, leaving this ACL owning
+nothing (and probably then needing to be deleted). Returns true on
+success and false on failure. On failure, the caller should call error()
+to get the error message.
+
=item show()
Returns a human-readable description of this ACL, including its
diff --git a/perl/lib/Wallet/ACL/Base.pm b/perl/lib/Wallet/ACL/Base.pm
index a2b07cc..19ca612 100644
--- a/perl/lib/Wallet/ACL/Base.pm
+++ b/perl/lib/Wallet/ACL/Base.pm
@@ -20,7 +20,7 @@ use vars qw($VERSION);
# This version should be increased on any code change to this module. Always
# use two digits for the minor version with a leading zero if necessary so
# that it will sort properly.
-$VERSION = '0.02';
+$VERSION = '0.03';
##############################################################################
# Interface
@@ -37,6 +37,11 @@ sub new {
return $self;
}
+# The default name check method allows any name.
+sub syntax_check {
+ return 1;
+}
+
# The default check method denies all access.
sub check {
return 0;
@@ -92,6 +97,12 @@ inherit from it. It is not used directly.
Creates a new ACL verifier. The generic function provided here just
creates and blesses an object.
+=item syntax_check(PRINCIPAL, ACL)
+
+This method should be overridden by any child classes that want to
+implement validating the name of an ACL before creation. The default
+implementation allows any name for an ACL.
+
=item check(PRINCIPAL, ACL)
This method should always be overridden by child classes. The default
diff --git a/perl/lib/Wallet/ACL/LDAP/Attribute/Root.pm b/perl/lib/Wallet/ACL/LDAP/Attribute/Root.pm
new file mode 100644
index 0000000..eb30931
--- /dev/null
+++ b/perl/lib/Wallet/ACL/LDAP/Attribute/Root.pm
@@ -0,0 +1,128 @@
+# Wallet::ACL::LDAP::Attribute::Root -- Wallet LDAP ACL verifier (root instances).
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# From Wallet::ACL::NetDB::Root by Russ Allbery <eagle@eyrie.org>
+# Copyright 2015
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::LDAP::Attribute::Root;
+require 5.006;
+
+use strict;
+use warnings;
+use vars qw(@ISA $VERSION);
+
+use Wallet::ACL::LDAP::Attribute;
+use Wallet::Config;
+
+@ISA = qw(Wallet::ACL::LDAP::Attribute);
+
+# This version should be increased on any code change to this module. Always
+# use two digits for the minor version with a leading zero if necessary so
+# that it will sort properly.
+$VERSION = '0.01';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# Override the check method of Wallet::ACL::LDAP::Attribute to require that
+# the principal be a root instance and to strip /root out of the principal
+# name before checking roles.
+sub check {
+ my ($self, $principal, $acl) = @_;
+ undef $self->{error};
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ unless ($principal =~ s%^([^/\@]+)/root(\@|\z)%$1$2%) {
+ return 0;
+ }
+ return $self->SUPER::check ($principal, $acl);
+}
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL Allbery LDAP verifier
+
+=head1 NAME
+
+Wallet::ACL::LDAP::Attribute::Root - Wallet ACL verifier for LDAP attributes (root instances)
+
+=head1 SYNOPSIS
+
+ my $verifier = Wallet::ACL::LDAP::Attribute::Root->new;
+ my $status = $verifier->check ($principal, "$attr=$value");
+ if (not defined $status) {
+ die "Something failed: ", $verifier->error, "\n";
+ } elsif ($status) {
+ print "Access granted\n";
+ } else {
+ print "Access denied\n";
+ }
+
+=head1 DESCRIPTION
+
+Wallet::ACL::LDAP::Attribute::Root works identically to
+Wallet::ACL::LDAP::Attribute except that it requires the principal to
+be a root instance (in other words, to be in the form
+<principal>/root@<realm>) and strips the C</root> portion from the
+principal before checking against the LDAP attribute and value. As
+with the base LDAP Attribute ACL verifier, the value of such a
+C<ldap-attr-root> ACL is an attribute followed by an equal sign and a
+value, and the ACL grants access to a given principal if and only if
+the LDAP entry for that principal (with C</root> stripped) has that
+attribute set to that value.
+
+To use this object, the same configuration parameters must be set as for
+Wallet::ACL::LDAP::Attribute. See Wallet::Config(3) for details on
+those configuration parameters and information about how to set wallet
+configuration.
+
+=head1 METHODS
+
+=over 4
+
+=item check(PRINCIPAL, ACL)
+
+Returns true if PRINCIPAL is granted access according to ACL, false if
+not, and undef on an error (see L<"DIAGNOSTICS"> below). ACL must be an
+attribute name and a value, separated by an equal sign (with no
+whitespace). PRINCIPAL will be granted access if it has an instance of
+C<root> and if (with C</root> stripped off) its LDAP entry contains
+that attribute with that value
+
+=back
+
+=head1 DIAGNOSTICS
+
+Same as for Wallet::ACL::LDAP::Attribute.
+
+=head1 CAVEATS
+
+The instance to strip is not currently configurable.
+
+=head1 SEE ALSO
+
+Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3),
+Wallet::ACL::LDAP::Attribute(3), Wallet::Config(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHORS
+
+Jon Robertson <jonrober@stanford.edu>
+Russ Allbery <eagle@eyrie.org>
+
+=cut
diff --git a/perl/lib/Wallet/ACL/Nested.pm b/perl/lib/Wallet/ACL/Nested.pm
new file mode 100644
index 0000000..07833f8
--- /dev/null
+++ b/perl/lib/Wallet/ACL/Nested.pm
@@ -0,0 +1,189 @@
+# Wallet::ACL::Nested - ACL class for nesting ACLs
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2015
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::ACL::Nested;
+require 5.006;
+
+use strict;
+use warnings;
+use vars qw($VERSION @ISA);
+
+use Wallet::ACL::Base;
+
+@ISA = qw(Wallet::ACL::Base);
+
+# This version should be increased on any code change to this module. Always
+# use two digits for the minor version with a leading zero if necessary so
+# that it will sort properly.
+$VERSION = '0.01';
+
+##############################################################################
+# Interface
+##############################################################################
+
+# Creates a new persistant verifier, taking a database handle to use for
+# syntax check validation.
+sub new {
+ my $type = shift;
+ my ($name, $schema) = @_;
+ my $self = {
+ schema => $schema,
+ expanded => {},
+ };
+ bless ($self, $type);
+ return $self;
+}
+
+# Name checking requires checking that there's an existing ACL already by
+# this name. Try to create the ACL object and use that to determine.
+sub syntax_check {
+ my ($self, $group) = @_;
+
+ my $acl;
+ eval { $acl = Wallet::ACL->new ($group, $self->{schema}) };
+ return 0 if $@;
+ return 0 unless $acl;
+ return 1;
+}
+
+# For checking a nested ACL, we need to expand each entry and then check
+# that entry. We also want to keep track of things already checked in order
+# to avoid any loops.
+sub check {
+ my ($self, $principal, $group) = @_;
+ unless ($principal) {
+ $self->error ('no principal specified');
+ return;
+ }
+ unless ($group) {
+ $self->error ('malformed nested ACL');
+ return;
+ }
+
+ # Make an ACL object just so that we can use it to drop back into the
+ # normal ACL validation after we have expanded the nesting.
+ my $acl;
+ eval { $acl = Wallet::ACL->new ($group, $self->{schema}) };
+
+ # Get the list of all nested acl entries within this entry, and use it
+ # to go through each entry and decide if the given acl has access.
+ my @members = $self->get_membership ($group);
+ for my $entry (@members) {
+ my ($type, $name) = @{ $entry };
+ my $result = $acl->check_line ($principal, $type, $name);
+ return 1 if $result;
+ }
+ return 0;
+}
+
+# Get the membership of a group recursively. The final result will be a list
+# of arrayrefs like that from Wallet::ACL->list, but expanded for full
+# membership.
+sub get_membership {
+ my ($self, $group) = @_;
+
+ # Get the list of members for this nested acl. Consider any missing acls
+ # as empty.
+ my $schema = $self->{schema};
+ my @members;
+ eval {
+ my $acl = Wallet::ACL->new ($group, $schema);
+ @members = $acl->list;
+ };
+
+ # Now go through and expand any other nested groups into their own
+ # memberships.
+ my @expanded;
+ for my $entry (@members) {
+ my ($type, $name) = @{ $entry };
+ if ($type eq 'nested') {
+
+ # Keep track of things we've already expanded and don't look them
+ # up again.
+ next if exists $self->{expanded}{$name};
+ $self->{expanded}{$name} = 1;
+ push (@expanded, $self->get_membership ($name));
+
+ } else {
+ push (@expanded, $entry);
+ }
+ }
+
+ return @expanded;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=for stopwords
+ACL Allbery verifier verifiers
+
+=head1 NAME
+
+Wallet::ACL::Nested - Wallet ACL verifier to check another ACL
+
+=head1 SYNOPSIS
+
+ my $verifier = Wallet::ACL::Nested->new;
+ my $status = $verifier->check ($principal, $acl);
+ if (not defined $status) {
+ die "Something failed: ", $verifier->error, "\n";
+ } elsif ($status) {
+ print "Access granted\n";
+ } else {
+ print "Access denied\n";
+ }
+
+=head1 DESCRIPTION
+
+Wallet::ACL::Nested checks whether the principal is permitted by another
+named ACL and, if so, returns success. It is used to nest one ACL inside
+another.
+
+=head1 METHODS
+
+=over 4
+
+=item new()
+
+Creates a new ACL verifier.
+
+=item check(PRINCIPAL, ACL)
+
+Returns true if PRINCIPAL is granted access according to the nested ACL,
+specified by name. Returns false if it is not, and undef on error.
+
+=item error([ERROR ...])
+
+Returns the error of the last failing operation or undef if no operations
+have failed. Callers should call this function to get the error message
+after an undef return from any other instance method. The returned errors
+will generally come from the nested child ACL.
+
+=back
+
+=head1 SEE ALSO
+
+Wallet::ACL(3), wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Jon Robertson <jonrober@stanford.edu>
+
+=cut
diff --git a/perl/lib/Wallet/Admin.pm b/perl/lib/Wallet/Admin.pm
index 8120e9c..b4246ba 100644
--- a/perl/lib/Wallet/Admin.pm
+++ b/perl/lib/Wallet/Admin.pm
@@ -115,22 +115,25 @@ sub default_data {
# acl_schemes default rows.
my ($r1) = $self->{schema}->resultset('AclScheme')->populate ([
[ qw/as_name as_class/ ],
- [ 'krb5', 'Wallet::ACL::Krb5' ],
- [ 'krb5-regex', 'Wallet::ACL::Krb5::Regex' ],
- [ 'ldap-attr', 'Wallet::ACL::LDAP::Attribute' ],
- [ 'netdb', 'Wallet::ACL::NetDB' ],
- [ 'netdb-root', 'Wallet::ACL::NetDB::Root' ],
+ [ 'krb5', 'Wallet::ACL::Krb5' ],
+ [ 'krb5-regex', 'Wallet::ACL::Krb5::Regex' ],
+ [ 'ldap-attr', 'Wallet::ACL::LDAP::Attribute' ],
+ [ 'ldap-attr-root', 'Wallet::ACL::LDAP::Attribute::Root' ],
+ [ 'nested', 'Wallet::ACL::Nested' ],
+ [ 'netdb', 'Wallet::ACL::NetDB' ],
+ [ 'netdb-root', 'Wallet::ACL::NetDB::Root' ],
]);
warn "default AclScheme not installed" unless defined $r1;
# types default rows.
my @record = ([ qw/ty_name ty_class/ ],
[ 'duo', 'Wallet::Object::Duo' ],
- [ 'duo-ldap', 'Wallet::Object::Duo::LDAPProxy' ],
- [ 'duo-pam', 'Wallet::Object::Duo::PAM' ],
- [ 'duo-radius', 'Wallet::Object::Duo::RadiusProxy' ],
- [ 'duo-rdp', 'Wallet::Object::Duo::RDP' ],
+ [ 'duo-ldap', 'Wallet::Object::Duo' ],
+ [ 'duo-pam', 'Wallet::Object::Duo' ],
+ [ 'duo-radius', 'Wallet::Object::Duo' ],
+ [ 'duo-rdp', 'Wallet::Object::Duo' ],
[ 'file', 'Wallet::Object::File' ],
+ [ 'password', 'Wallet::Object::Password' ],
[ 'keytab', 'Wallet::Object::Keytab' ],
[ 'wa-keyring', 'Wallet::Object::WAKeyring' ]);
($r1) = $self->{schema}->resultset('Type')->populate (\@record);
diff --git a/perl/lib/Wallet/Config.pm b/perl/lib/Wallet/Config.pm
index 2eb57f9..b3e1931 100644
--- a/perl/lib/Wallet/Config.pm
+++ b/perl/lib/Wallet/Config.pm
@@ -260,6 +260,49 @@ our $FILE_MAX_SIZE;
=back
+=head1 PASSWORD OBJECT CONFIGURATION
+
+These configuration variables only need to be set if you intend to use the
+C<password> object type (the Wallet::Object::Password class). You will also
+need to set the FILE_MAX_SIZE value from the file object configuration, as
+that is inherited.
+
+=over 4
+
+=item PWD_FILE_BUCKET
+
+The directory into which to store password objects. Password objects will
+be stored in subdirectories of this directory. See
+L<Wallet::Object::Password> for the full details of the naming scheme. This
+directory must be writable by the wallet server and the wallet server must
+be able to create subdirectories of it.
+
+PWD_FILE_BUCKET must be set to use file objects.
+
+=cut
+
+our $PWD_FILE_BUCKET;
+
+=item PWD_LENGTH_MIN
+
+The minimum length for any auto-generated password objects created when get
+is run before data is stored.
+
+=cut
+
+our $PWD_LENGTH_MIN = 20;
+
+=item PWD_LENGTH_MAX
+
+The maximum length for any auto-generated password objects created when get
+is run before data is stored.
+
+=cut
+
+our $PWD_LENGTH_MAX = 21;
+
+=back
+
=head1 KEYTAB OBJECT CONFIGURATION
These configuration variables only need to be set if you intend to use the
@@ -749,6 +792,34 @@ keytab objects for particular principals have fully-qualified hostnames:
Objects that aren't of type C<keytab> or which aren't for a host-based key
have no naming requirements enforced by this example.
+=head1 OBJECT HOST-BASED NAMES
+
+The above demonstrates having a host-based naming convention, where we
+expect one part of an object name to be the name of the host that this
+object is for. The most obvious examples are those keytab objects
+above, where we want certain keytab names to be in the form of
+<service>/<hostname>. It's then also useful to provide a Perl function
+named is_for_host which then can be used to tell if a given object is a
+host-based keytab for a specific host. This function is then called by
+the objects_hostname in Wallet::Report to give a list of all host-based
+objects for a given hostname. It should return true if the given object
+is a host-based object for the hostname, otherwise false.
+
+An example that matches the same policy as the last verify_name example
+would be:
+
+ sub is_for_host {
+ my ($type, $name, $hostname) = @_;
+ my %host_based = map { $_ => 1 }
+ qw(HTTP cifs host imap ldap nfs pop sieve smtp webauth);
+ return 0 unless $type eq 'keytab';
+ return 0 unless $name =~ m%/%;
+ my ($service, $instance) = split ('/', $name, 2);
+ return 0 unless $host_based{$service};
+ return 1 if $hostname eq $instance;
+ return 0;
+ }
+
=head1 ACL NAMING ENFORCEMENT
Similar to object names, by default wallet permits administrators to
diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm
index bdd61fb..97e6127 100644
--- a/perl/lib/Wallet/Object/Base.pm
+++ b/perl/lib/Wallet/Object/Base.pm
@@ -609,6 +609,15 @@ sub history {
# The get methods must always be overridden by the subclass.
sub get { die "Do not instantiate Wallet::Object::Base directly\n"; }
+# The update method should only work if a subclass supports it as something
+# different from get. That makes it explicit about whether the subclass has
+# a meaningful update.
+sub update {
+ my ($self) = @_;
+ $self->error ("update is not supported for this type, use get instead");
+ return;
+}
+
# Provide a default store implementation that returns an immutable object
# error so that auto-generated types don't have to provide their own.
sub store {
diff --git a/perl/lib/Wallet/Object/Duo.pm b/perl/lib/Wallet/Object/Duo.pm
index d08294b..d0901de 100644
--- a/perl/lib/Wallet/Object/Duo.pm
+++ b/perl/lib/Wallet/Object/Duo.pm
@@ -29,7 +29,100 @@ use Wallet::Object::Base;
# This version should be increased on any code change to this module. Always
# use two digits for the minor version with a leading zero if necessary so
# that it will sort properly.
-$VERSION = '0.02';
+$VERSION = '0.03';
+
+# Mappings from our types into what Duo calls the integration types.
+our %DUO_TYPES = (
+ 'duo' => {
+ integration => 'unix',
+ output => \&_output_generic,
+ },
+ 'duo-ldap' => {
+ integration => 'ldapproxy',
+ output => \&_output_ldap,
+ },
+ 'duo-pam' => {
+ integration => 'unix',
+ output => \&_output_pam,
+ },
+ 'duo-radius' => {
+ integration => 'radius',
+ output => \&_output_radius,
+ },
+ );
+
+# Extra types to add. These are all just named as the Duo integration name
+# with duo- before it and go to the generic output. Put them here to prevent
+# pages of settings. These are also not all actually set as types in the
+# types table to prevent overpopulation. You should manually create the
+# entries in that table for any Duo integrations you want to add.
+our @EXTRA_TYPES = ('accountsapi', 'adfs', 'adminapi', 'array', 'barracuda',
+ 'cisco', 'citrixcag', 'citrixns', 'confluence', 'drupal',
+ 'f5bigip', 'f5firepass', 'fortinet', 'jira', 'juniper',
+ 'juniperuac', 'lastpass', 'okta', 'onelogin', 'openvpn',
+ 'openvpnas', 'owa', 'paloalto', 'rdgateway', 'rdp',
+ 'rdweb', 'rest', 'rras', 'shibboleth', 'sonicwallsra',
+ 'splunk', 'tmg', 'uag', 'verify', 'vmwareview', 'websdk',
+ 'wordpress');
+for my $type (@EXTRA_TYPES) {
+ my $wallet_type = 'duo-'.$type;
+ $DUO_TYPES{$wallet_type}{integration} = $type;
+ $DUO_TYPES{$wallet_type}{output} = \&_output_generic;
+};
+
+##############################################################################
+# Get output methods
+##############################################################################
+
+# Output for any miscellaneous Duo integration, usually those that use a GUI
+# to set information and so don't need a custom configuration file.
+sub _output_generic {
+ my ($key, $secret, $hostname) = @_;
+
+ my $output;
+ $output .= "Integration key: $key\n";
+ $output .= "Secret key: $secret\n";
+ $output .= "Host: $hostname\n";
+
+ return $output;
+}
+
+# Output for the Duo unix integration, which hooks into the PAM stack.
+sub _output_pam {
+ my ($key, $secret, $hostname) = @_;
+
+ my $output = "[duo]\n";
+ $output .= "ikey = $key\n";
+ $output .= "skey = $secret\n";
+ $output .= "host = $hostname\n";
+
+ return $output;
+}
+
+# Output for the radius proxy, which can be plugged into the proxy config.
+sub _output_radius {
+ my ($key, $secret, $hostname) = @_;
+
+ my $output = "[radius_server_challenge]\n";
+ $output .= "ikey = $key\n";
+ $output .= "skey = $secret\n";
+ $output .= "api_host = $hostname\n";
+ $output .= "client = radius_client\n";
+
+ return $output;
+}
+
+# Output for the LDAP proxy, which can be plugged into the proxy config.
+sub _output_ldap {
+ my ($key, $secret, $hostname) = @_;
+
+ my $output = "[ldap_server_challenge]\n";
+ $output .= "ikey = $key\n";
+ $output .= "skey = $secret\n";
+ $output .= "api_host = $hostname\n";
+
+ return $output;
+}
##############################################################################
# Core methods
@@ -86,7 +179,7 @@ sub new {
# great here since we don't have a way to communicate the error back to the
# caller.
sub create {
- my ($class, $type, $name, $schema, $creator, $host, $time, $duo_type) = @_;
+ my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
# We have to have a Duo integration key file set.
if (not $Wallet::Config::DUO_KEY_FILE) {
@@ -95,6 +188,12 @@ sub create {
my $key_file = $Wallet::Config::DUO_KEY_FILE;
my $agent = $Wallet::Config::DUO_AGENT;
+ # Make sure this is actually a type we know about, since this handler
+ # can handle many types.
+ if (!exists $DUO_TYPES{$type}) {
+ die "$type is not a valid duo integration\n";
+ }
+
# Construct the Net::Duo::Admin object.
require Net::Duo::Admin;
my $duo = Net::Duo::Admin->new (
@@ -106,7 +205,7 @@ sub create {
# Create the object in Duo.
require Net::Duo::Admin::Integration;
- $duo_type ||= $Wallet::Config::DUO_TYPE;
+ my $duo_type = $DUO_TYPES{$type}{integration};
my %data = (
name => "$name ($duo_type)",
notes => 'Managed by wallet',
@@ -201,11 +300,17 @@ sub get {
my $json = JSON->new->utf8 (1)->relaxed (1);
my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
- # Construct the returned file.
- my $output;
- $output .= "Integration key: $key\n";
- $output .= 'Secret key: ' . $integration->secret_key . "\n";
- $output .= "Host: $config->{api_hostname}\n";
+ # Construct the returned file. Assume the generic handler in case there
+ # is no valid handler, though that shouldn't happen.
+ my $output_sub;
+ my $type = $self->{type};
+ if (exists $DUO_TYPES{$type}{output}) {
+ $output_sub = $DUO_TYPES{$type}{output};
+ } else {
+ $output_sub = \&_output_generic;
+ }
+ my $output = $output_sub->($key, $integration->secret_key,
+ $config->{api_hostname});
# Log the action and return.
$self->log_action ('get', $user, $host, $time);
diff --git a/perl/lib/Wallet/Object/Duo/LDAPProxy.pm b/perl/lib/Wallet/Object/Duo/LDAPProxy.pm
deleted file mode 100644
index 23894ac..0000000
--- a/perl/lib/Wallet/Object/Duo/LDAPProxy.pm
+++ /dev/null
@@ -1,202 +0,0 @@
-# Wallet::Object::Duo::LDAPProxy -- Duo auth proxy integration for LDAP
-#
-# Written by Jon Robertson <jonrober@stanford.edu>
-# Copyright 2014
-# The Board of Trustees of the Leland Stanford Junior University
-#
-# See LICENSE for licensing terms.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Wallet::Object::Duo::LDAPProxy;
-require 5.006;
-
-use strict;
-use warnings;
-use vars qw(@ISA $VERSION);
-
-use JSON;
-use Net::Duo::Admin;
-use Net::Duo::Admin::Integration;
-use Perl6::Slurp qw(slurp);
-use Wallet::Config ();
-use Wallet::Object::Duo;
-
-@ISA = qw(Wallet::Object::Duo);
-
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.01';
-
-##############################################################################
-# Core methods
-##############################################################################
-
-# Override create to provide the specific Duo integration type that will be
-# used in the remote Duo record.
-sub create {
- my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
-
- $time ||= time;
- my $self = $class->SUPER::create ($type, $name, $schema, $creator, $host,
- $time, 'ldapproxy');
- return $self;
-}
-
-# Override get to output the data in a specific format used for Duo LDAP
-# integration
-sub get {
- my ($self, $user, $host, $time) = @_;
- $time ||= time;
-
- # Check that the object isn't locked.
- my $id = $self->{type} . ':' . $self->{name};
- if ($self->flag_check ('locked')) {
- $self->error ("cannot get $id: object is locked");
- return;
- }
-
- # Retrieve the integration from Duo.
- my $key;
- eval {
- my %search = (du_name => $self->{name});
- my $row = $self->{schema}->resultset ('Duo')->find (\%search);
- $key = $row->get_column ('du_key');
- };
- if ($@) {
- $self->error ($@);
- return;
- }
- my $integration = Net::Duo::Admin::Integration->new ($self->{duo}, $key);
-
- # We also need the admin server name, which we can get from the Duo object
- # configuration with a bit of JSON decoding.
- my $json = JSON->new->utf8 (1)->relaxed (1);
- my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
-
- # Construct the returned file.
- my $output = "[ldap_server_challenge]\n";
- $output .= "ikey = $key\n";
- $output .= 'skey = ' . $integration->secret_key . "\n";
- $output .= "api_host = $config->{api_hostname}\n";
-
- # Log the action and return.
- $self->log_action ('get', $user, $host, $time);
- return $output;
-}
-
-1;
-__END__
-
-##############################################################################
-# Documentation
-##############################################################################
-
-=for stopwords
-Allbery Duo integration DBH keytab LDAP auth
-
-=head1 NAME
-
-Wallet::Object::Duo::LDAPProxy - Duo auth proxy integration for LDAP
-
-=head1 SYNOPSIS
-
- my @name = qw(duo-ldap host.example.com);
- my @trace = ($user, $host, time);
- my $object = Wallet::Object::Duo::LDAPProxy->create (@name, $schema, @trace);
- my $config = $object->get (@trace);
- $object->destroy (@trace);
-
-=head1 DESCRIPTION
-
-Wallet::Object::Duo::LDAPProxy is a representation of Duo
-integrations with the wallet, specifically to output Duo integrations
-in a format that can easily be pulled into configuring the Duo
-Authentication Proxy for LDAP. It implements the wallet object API
-and provides the necessary glue to create a Duo integration, return a
-configuration file containing the key and API information for that
-integration, and delete the integration from Duo when the wallet object
-is destroyed.
-
-The integration information is always returned in the configuration file
-format expected by the Authentication Proxy for Duo in configuring it
-for LDAP.
-
-This object can be retrieved repeatedly without changing the secret key,
-matching Duo's native behavior with integrations. To change the keys of
-the integration, delete it and recreate it.
-
-To use this object, at least one configuration parameter must be set. See
-L<Wallet::Config> for details on supported configuration parameters and
-information about how to set wallet configuration.
-
-=head1 METHODS
-
-This object mostly inherits from Wallet::Object::Duo. See the
-documentation for that class for all generic methods. Below are only
-those methods that are overridden or behave specially for this
-implementation.
-
-=over 4
-
-=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
-
-This will override the Wallet::Object::Duo class with the information
-needed to create a specific integration type in Duo. It creates a new
-object with the given TYPE and NAME (TYPE is normally C<duo-ldap> and
-must be for the rest of the wallet system to use the right class, but
-this module doesn't check for ease of subclassing), using DBH as the
-handle to the wallet metadata database. PRINCIPAL, HOSTNAME, and
-DATETIME are stored as history information. PRINCIPAL should be the
-user who is creating the object. If DATETIME isn't given, the current
-time is used.
-
-When a new Duo integration object is created, a new integration will be
-created in the configured Duo account and the integration key will be
-stored in the wallet object. If the integration already exists, create()
-will fail.
-
-If create() fails, it throws an exception.
-
-=item get(PRINCIPAL, HOSTNAME [, DATETIME])
-
-Retrieves the configuration information for the Duo integration and
-returns that information in the format expected by the configuration file
-for the Duo UNIX integration. Returns undef on failure. The caller
-should call error() to get the error message if get() returns undef.
-
-The returned configuration look look like:
-
- [ldap_server_challenge]
- ikey = <integration-key>
- skey = <secret-key>
- api_host = <api-hostname>
-
-The C<host> parameter will be taken from the configuration file pointed
-to by the DUO_KEY_FILE configuration variable.
-
-PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
-PRINCIPAL should be the user who is downloading the keytab. If DATETIME
-isn't given, the current time is used.
-
-=back
-
-=head1 LIMITATIONS
-
-Only one Duo account is supported for a given wallet implementation.
-
-=head1 SEE ALSO
-
-Net::Duo(3), Wallet::Config(3), Wallet::Object::Duo(3), wallet-backend(8)
-
-This module is part of the wallet system. The current version is
-available from L<http://www.eyrie.org/~eagle/software/wallet/>.
-
-=head1 AUTHORS
-
-Jon Robertson <jonrober@stanford.edu>
-
-=cut
diff --git a/perl/lib/Wallet/Object/Duo/PAM.pm b/perl/lib/Wallet/Object/Duo/PAM.pm
deleted file mode 100644
index d9d17f8..0000000
--- a/perl/lib/Wallet/Object/Duo/PAM.pm
+++ /dev/null
@@ -1,205 +0,0 @@
-# Wallet::Object::Duo::PAM -- Duo PAM int. object implementation for wallet
-#
-# Written by Russ Allbery <eagle@eyrie.org>
-# Jon Robertson <jonrober@stanford.edu>
-# Copyright 2014
-# The Board of Trustees of the Leland Stanford Junior University
-#
-# See LICENSE for licensing terms.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Wallet::Object::Duo::PAM;
-require 5.006;
-
-use strict;
-use warnings;
-use vars qw(@ISA $VERSION);
-
-use JSON;
-use Net::Duo::Admin;
-use Net::Duo::Admin::Integration;
-use Perl6::Slurp qw(slurp);
-use Wallet::Config ();
-use Wallet::Object::Duo;
-
-@ISA = qw(Wallet::Object::Duo);
-
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.01';
-
-##############################################################################
-# Core methods
-##############################################################################
-
-# Override create to provide the specific Duo integration type that will be
-# used in the remote Duo record.
-sub create {
- my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
-
- $time ||= time;
- my $self = $class->SUPER::create ($type, $name, $schema, $creator, $host,
- $time, 'unix');
- return $self;
-}
-
-# Override get to output the data in a specific format used by Duo's PAM
-# module.
-sub get {
- my ($self, $user, $host, $time) = @_;
- $time ||= time;
-
- # Check that the object isn't locked.
- my $id = $self->{type} . ':' . $self->{name};
- if ($self->flag_check ('locked')) {
- $self->error ("cannot get $id: object is locked");
- return;
- }
-
- # Retrieve the integration from Duo.
- my $key;
- eval {
- my %search = (du_name => $self->{name});
- my $row = $self->{schema}->resultset ('Duo')->find (\%search);
- $key = $row->get_column ('du_key');
- };
- if ($@) {
- $self->error ($@);
- return;
- }
- my $integration = Net::Duo::Admin::Integration->new ($self->{duo}, $key);
-
- # We also need the admin server name, which we can get from the Duo object
- # configuration with a bit of JSON decoding.
- my $json = JSON->new->utf8 (1)->relaxed (1);
- my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
-
- # Construct the returned file.
- my $output = "[duo]\n";
- $output .= "ikey = $key\n";
- $output .= 'skey = ' . $integration->secret_key . "\n";
- $output .= "host = $config->{api_hostname}\n";
-
- # Log the action and return.
- $self->log_action ('get', $user, $host, $time);
- return $output;
-}
-
-1;
-__END__
-
-##############################################################################
-# Documentation
-##############################################################################
-
-=for stopwords
-Allbery Duo integration DBH keytab
-
-=head1 NAME
-
-Wallet::Object::Duo::PAM - Duo PAM int. object implementation for wallet
-
-=head1 SYNOPSIS
-
- my @name = qw(duo-pam host.example.com);
- my @trace = ($user, $host, time);
- my $object = Wallet::Object::Duo::PAM->create (@name, $schema, @trace);
- my $config = $object->get (@trace);
- $object->destroy (@trace);
-
-=head1 DESCRIPTION
-
-Wallet::Object::Duo::PAM is a representation of Duo integrations with
-the wallet, specifically to output Duo integrations in a format that
-can easily be pulled into configuring the Duo PAM interface. It
-implements the wallet object API and provides the necessary glue to
-create a Duo integration, return a configuration file containing the key
-and API information for that integration, and delete the integration from
-Duo when the wallet object is destroyed.
-
-The integration information is always returned in the configuration file
-format expected by the Duo UNIX integration. The results of retrieving
-this object will be text, suitable for putting in the UNIX integration
-configuration file, containing the integration key, secret key, and admin
-hostname for that integration.
-
-This object can be retrieved repeatedly without changing the secret key,
-matching Duo's native behavior with integrations. To change the keys of
-the integration, delete it and recreate it.
-
-To use this object, at least one configuration parameter must be set. See
-L<Wallet::Config> for details on supported configuration parameters and
-information about how to set wallet configuration.
-
-=head1 METHODS
-
-This object mostly inherits from Wallet::Object::Duo. See the
-documentation for that class for all generic methods. Below are only
-those methods that are overridden or behave specially for this
-implementation.
-
-=over 4
-
-=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
-
-This will override the Wallet::Object::Duo class with the information
-needed to create a specific integration type in Duo. It creates a new
-object with the given TYPE and NAME (TYPE is normally C<duo-pam> and must
-be for the rest of the wallet system to use the right class, but this
-module doesn't check for ease of subclassing), using DBH as the handle
-to the wallet metadata database. PRINCIPAL, HOSTNAME, and DATETIME are
-stored as history information. PRINCIPAL should be the user who is
-creating the object. If DATETIME isn't given, the current time is
-used.
-
-When a new Duo integration object is created, a new integration will be
-created in the configured Duo account and the integration key will be
-stored in the wallet object. If the integration already exists, create()
-will fail.
-
-If create() fails, it throws an exception.
-
-=item get(PRINCIPAL, HOSTNAME [, DATETIME])
-
-Retrieves the configuration information for the Duo integration and
-returns that information in the format expected by the configuration file
-for the Duo UNIX integration. Returns undef on failure. The caller
-should call error() to get the error message if get() returns undef.
-
-The returned configuration look look like:
-
- [duo]
- ikey = <integration-key>
- skey = <secret-key>
- host = <api-hostname>
-
-The C<host> parameter will be taken from the configuration file pointed
-to by the DUO_KEY_FILE configuration variable.
-
-PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
-PRINCIPAL should be the user who is downloading the keytab. If DATETIME
-isn't given, the current time is used.
-
-=back
-
-=head1 LIMITATIONS
-
-Only one Duo account is supported for a given wallet implementation.
-
-=head1 SEE ALSO
-
-Net::Duo(3), Wallet::Config(3), Wallet::Object::Duo(3), wallet-backend(8)
-
-This module is part of the wallet system. The current version is
-available from L<http://www.eyrie.org/~eagle/software/wallet/>.
-
-=head1 AUTHORS
-
-Russ Allbery <eagle@eyrie.org>
-Jon Robertson <eagle@eyrie.org>
-
-=cut
diff --git a/perl/lib/Wallet/Object/Duo/RDP.pm b/perl/lib/Wallet/Object/Duo/RDP.pm
deleted file mode 100644
index c74661c..0000000
--- a/perl/lib/Wallet/Object/Duo/RDP.pm
+++ /dev/null
@@ -1,204 +0,0 @@
-# Wallet::Object::Duo::RDP -- Duo RDP int. object implementation for wallet
-#
-# Written by Russ Allbery <eagle@eyrie.org>
-# Jon Robertson <jonrober@stanford.edu>
-# Copyright 2014
-# The Board of Trustees of the Leland Stanford Junior University
-#
-# See LICENSE for licensing terms.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Wallet::Object::Duo::RDP;
-require 5.006;
-
-use strict;
-use warnings;
-use vars qw(@ISA $VERSION);
-
-use JSON;
-use Net::Duo::Admin;
-use Net::Duo::Admin::Integration;
-use Perl6::Slurp qw(slurp);
-use Wallet::Config ();
-use Wallet::Object::Duo;
-
-@ISA = qw(Wallet::Object::Duo);
-
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.01';
-
-##############################################################################
-# Core methods
-##############################################################################
-
-# Override create to provide the specific Duo integration type that will be
-# used in the remote Duo record.
-sub create {
- my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
-
- $time ||= time;
- my $self = $class->SUPER::create ($type, $name, $schema, $creator, $host,
- $time, 'rdp');
- return $self;
-}
-
-# Override get to output the data in a specific format used by Duo's RDP
-# module.
-sub get {
- my ($self, $user, $host, $time) = @_;
- $time ||= time;
-
- # Check that the object isn't locked.
- my $id = $self->{type} . ':' . $self->{name};
- if ($self->flag_check ('locked')) {
- $self->error ("cannot get $id: object is locked");
- return;
- }
-
- # Retrieve the integration from Duo.
- my $key;
- eval {
- my %search = (du_name => $self->{name});
- my $row = $self->{schema}->resultset ('Duo')->find (\%search);
- $key = $row->get_column ('du_key');
- };
- if ($@) {
- $self->error ($@);
- return;
- }
- my $integration = Net::Duo::Admin::Integration->new ($self->{duo}, $key);
-
- # We also need the admin server name, which we can get from the Duo object
- # configuration with a bit of JSON decoding.
- my $json = JSON->new->utf8 (1)->relaxed (1);
- my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
-
- # Construct the returned file.
- my $output;
- $output .= "Integration key: $key\n";
- $output .= 'Secret key: ' . $integration->secret_key . "\n";
- $output .= "Host: $config->{api_hostname}\n";
-
- # Log the action and return.
- $self->log_action ('get', $user, $host, $time);
- return $output;
-}
-
-1;
-__END__
-
-##############################################################################
-# Documentation
-##############################################################################
-
-=for stopwords
-Allbery Duo integration DBH keytab RDP
-
-=head1 NAME
-
-Wallet::Object::Duo::RDP - Duo RDP int. object implementation for wallet
-
-=head1 SYNOPSIS
-
- my @name = qw(duo-rdp host.example.com);
- my @trace = ($user, $host, time);
- my $object = Wallet::Object::Duo::RDP->create (@name, $schema, @trace);
- my $config = $object->get (@trace);
- $object->destroy (@trace);
-
-=head1 DESCRIPTION
-
-Wallet::Object::Duo::RDP is a representation of Duo integrations with
-the wallet, specifically to output Duo integrations to set up an RDP
-integration. This can be used to set up remote logins, or all Windows
-logins period if so selected in Duo's software. It implements the
-wallet object API and provides the necessary glue to create a Duo
-integration, return a configuration file containing the key and API
-information for that integration, and delete the integration from Duo
-when the wallet object is destroyed.
-
-Because the Duo RDP software is configured by a GUI, the information
-returned for a get operation is a simple set that's readable but not
-useful for directly plugging into a config file. The values would need
-to be cut and pasted into the GUI.
-
-This object can be retrieved repeatedly without changing the secret key,
-matching Duo's native behavior with integrations. To change the keys of
-the integration, delete it and recreate it.
-
-To use this object, at least one configuration parameter must be set. See
-L<Wallet::Config> for details on supported configuration parameters and
-information about how to set wallet configuration.
-
-=head1 METHODS
-
-This object mostly inherits from Wallet::Object::Duo. See the
-documentation for that class for all generic methods. Below are only
-those methods that are overridden or behave specially for this
-implementation.
-
-=over 4
-
-=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
-
-This will override the Wallet::Object::Duo class with the information
-needed to create a specific integration type in Duo. It creates a new
-object with the given TYPE and NAME (TYPE is normally C<duo-pam> and must
-be for the rest of the wallet system to use the right class, but this
-module doesn't check for ease of subclassing), using DBH as the handle
-to the wallet metadata database. PRINCIPAL, HOSTNAME, and DATETIME are
-stored as history information. PRINCIPAL should be the user who is
-creating the object. If DATETIME isn't given, the current time is
-used.
-
-When a new Duo integration object is created, a new integration will be
-created in the configured Duo account and the integration key will be
-stored in the wallet object. If the integration already exists, create()
-will fail.
-
-If create() fails, it throws an exception.
-
-=item get(PRINCIPAL, HOSTNAME [, DATETIME])
-
-Retrieves the configuration information for the Duo integration and
-returns that information in the format expected by the configuration file
-for the Duo UNIX integration. Returns undef on failure. The caller
-should call error() to get the error message if get() returns undef.
-
-The returned configuration look look like:
-
- Integration key: <integration-key>
- Secret key: <secret-key>
- Host: <api-hostname>
-
-The C<host> parameter will be taken from the configuration file pointed
-to by the DUO_KEY_FILE configuration variable.
-
-PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
-PRINCIPAL should be the user who is downloading the keytab. If DATETIME
-isn't given, the current time is used.
-
-=back
-
-=head1 LIMITATIONS
-
-Only one Duo account is supported for a given wallet implementation.
-
-=head1 SEE ALSO
-
-Net::Duo(3), Wallet::Config(3), Wallet::Object::Duo(3), wallet-backend(8)
-
-This module is part of the wallet system. The current version is
-available from L<http://www.eyrie.org/~eagle/software/wallet/>.
-
-=head1 AUTHORS
-
-Russ Allbery <eagle@eyrie.org>
-Jon Robertson <eagle@eyrie.org>
-
-=cut
diff --git a/perl/lib/Wallet/Object/Duo/RadiusProxy.pm b/perl/lib/Wallet/Object/Duo/RadiusProxy.pm
deleted file mode 100644
index a1f6e24..0000000
--- a/perl/lib/Wallet/Object/Duo/RadiusProxy.pm
+++ /dev/null
@@ -1,204 +0,0 @@
-# Wallet::Object::Duo::RadiusProxy -- Duo auth proxy integration for radius
-#
-# Written by Jon Robertson <jonrober@stanford.edu>
-# Copyright 2014
-# The Board of Trustees of the Leland Stanford Junior University
-#
-# See LICENSE for licensing terms.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Wallet::Object::Duo::RadiusProxy;
-require 5.006;
-
-use strict;
-use warnings;
-use vars qw(@ISA $VERSION);
-
-use JSON;
-use Net::Duo::Admin;
-use Net::Duo::Admin::Integration;
-use Perl6::Slurp qw(slurp);
-use Wallet::Config ();
-use Wallet::Object::Duo;
-
-@ISA = qw(Wallet::Object::Duo);
-
-# This version should be increased on any code change to this module. Always
-# use two digits for the minor version with a leading zero if necessary so
-# that it will sort properly.
-$VERSION = '0.01';
-
-##############################################################################
-# Core methods
-##############################################################################
-
-# Override create to provide the specific Duo integration type that will be
-# used in the remote Duo record.
-sub create {
- my ($class, $type, $name, $schema, $creator, $host, $time) = @_;
-
- $time ||= time;
- my $self = $class->SUPER::create ($type, $name, $schema, $creator, $host,
- $time, 'radius');
- return $self;
-}
-
-# Override get to output the data in a specific format used for Duo radius
-# integration
-sub get {
- my ($self, $user, $host, $time) = @_;
- $time ||= time;
-
- # Check that the object isn't locked.
- my $id = $self->{type} . ':' . $self->{name};
- if ($self->flag_check ('locked')) {
- $self->error ("cannot get $id: object is locked");
- return;
- }
-
- # Retrieve the integration from Duo.
- my $key;
- eval {
- my %search = (du_name => $self->{name});
- my $row = $self->{schema}->resultset ('Duo')->find (\%search);
- $key = $row->get_column ('du_key');
- };
- if ($@) {
- $self->error ($@);
- return;
- }
- my $integration = Net::Duo::Admin::Integration->new ($self->{duo}, $key);
-
- # We also need the admin server name, which we can get from the Duo object
- # configuration with a bit of JSON decoding.
- my $json = JSON->new->utf8 (1)->relaxed (1);
- my $config = $json->decode (scalar slurp $Wallet::Config::DUO_KEY_FILE);
-
- # Construct the returned file.
- my $output = "[radius_server_challenge]\n";
- $output .= "ikey = $key\n";
- $output .= 'skey = ' . $integration->secret_key . "\n";
- $output .= "api_host = $config->{api_hostname}\n";
- $output .= "client = radius_client\n";
-
- # Log the action and return.
- $self->log_action ('get', $user, $host, $time);
- return $output;
-}
-
-1;
-__END__
-
-##############################################################################
-# Documentation
-##############################################################################
-
-=for stopwords
-Allbery Duo integration DBH keytab auth
-
-=head1 NAME
-
-Wallet::Object::Duo::RadiusProxy - Duo auth proxy integration for RADIUS
-
-=head1 SYNOPSIS
-
- my @name = qw(duo-radius host.example.com);
- my @trace = ($user, $host, time);
- my $object = Wallet::Object::Duo::RadiusProxy->create (@name, $schema, @trace);
- my $config = $object->get (@trace);
- $object->destroy (@trace);
-
-=head1 DESCRIPTION
-
-Wallet::Object::Duo::RadiusProxy is a representation of Duo
-integrations with the wallet, specifically to output Duo integrations
-in a format that can easily be pulled into configuring the Duo
-Authentication Proxy for Radius. It implements the wallet object API
-and provides the necessary glue to create a Duo integration, return a
-configuration file containing the key and API information for that
-integration, and delete the integration from Duo when the wallet object
-is destroyed.
-
-The integration information is always returned in the configuration file
-format expected by the Authentication Proxy for Duo in configuring it
-for Radius.
-
-This object can be retrieved repeatedly without changing the secret key,
-matching Duo's native behavior with integrations. To change the keys of
-the integration, delete it and recreate it.
-
-To use this object, at least one configuration parameter must be set. See
-L<Wallet::Config> for details on supported configuration parameters and
-information about how to set wallet configuration.
-
-=head1 METHODS
-
-This object mostly inherits from Wallet::Object::Duo. See the
-documentation for that class for all generic methods. Below are only
-those methods that are overridden or behave specially for this
-implementation.
-
-=over 4
-
-=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME])
-
-This will override the Wallet::Object::Duo class with the information
-needed to create a specific integration type in Duo. It creates a new
-object with the given TYPE and NAME (TYPE is normally C<duo-radius> and
-must be for the rest of the wallet system to use the right class, but
-this module doesn't check for ease of subclassing), using DBH as the
-handle to the wallet metadata database. PRINCIPAL, HOSTNAME, and
-DATETIME are stored as history information. PRINCIPAL should be the
-user who is creating the object. If DATETIME isn't given, the current
-time is used.
-
-When a new Duo integration object is created, a new integration will be
-created in the configured Duo account and the integration key will be
-stored in the wallet object. If the integration already exists, create()
-will fail.
-
-If create() fails, it throws an exception.
-
-=item get(PRINCIPAL, HOSTNAME [, DATETIME])
-
-Retrieves the configuration information for the Duo integration and
-returns that information in the format expected by the configuration file
-for the Duo UNIX integration. Returns undef on failure. The caller
-should call error() to get the error message if get() returns undef.
-
-The returned configuration look look like:
-
- [radius_server_challenge]
- ikey = <integration-key>
- skey = <secret-key>
- api_host = <api-hostname>
- client = radius_client
-
-The C<host> parameter will be taken from the configuration file pointed
-to by the DUO_KEY_FILE configuration variable.
-
-PRINCIPAL, HOSTNAME, and DATETIME are stored as history information.
-PRINCIPAL should be the user who is downloading the keytab. If DATETIME
-isn't given, the current time is used.
-
-=back
-
-=head1 LIMITATIONS
-
-Only one Duo account is supported for a given wallet implementation.
-
-=head1 SEE ALSO
-
-Net::Duo(3), Wallet::Config(3), Wallet::Object::Duo(3), wallet-backend(8)
-
-This module is part of the wallet system. The current version is
-available from L<http://www.eyrie.org/~eagle/software/wallet/>.
-
-=head1 AUTHORS
-
-Jon Robertson <jonrober@stanford.edu>
-
-=cut
diff --git a/perl/lib/Wallet/Object/Keytab.pm b/perl/lib/Wallet/Object/Keytab.pm
index 975179b..c625766 100644
--- a/perl/lib/Wallet/Object/Keytab.pm
+++ b/perl/lib/Wallet/Object/Keytab.pm
@@ -29,6 +29,37 @@ use Wallet::Kadmin;
$VERSION = '0.09';
##############################################################################
+# Shared methods
+##############################################################################
+
+# Generate a keytab into a temporary file and then return that as the return
+# value. Used by both get and update, as the only difference is how we
+# handle the unchanging flag.
+sub retrieve {
+ my ($self, $operation, $user, $host, $time) = @_;
+ $time ||= time;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot get $id: object is locked");
+ return;
+ }
+ my $kadmin = $self->{kadmin};
+ my $result;
+ if ($operation eq 'get' && $self->flag_check ('unchanging')) {
+ $result = $kadmin->keytab ($self->{name});
+ } else {
+ my @enctypes = $self->attr ('enctypes');
+ $result = $kadmin->keytab_rekey ($self->{name}, @enctypes);
+ }
+ if (defined $result) {
+ $self->log_action ($operation, $user, $host, $time);
+ } else {
+ $self->error ($kadmin->error);
+ }
+ return $result;
+}
+
+##############################################################################
# Enctype restriction
##############################################################################
@@ -314,25 +345,15 @@ sub destroy {
# return that as the return value.
sub get {
my ($self, $user, $host, $time) = @_;
- $time ||= time;
- my $id = $self->{type} . ':' . $self->{name};
- if ($self->flag_check ('locked')) {
- $self->error ("cannot get $id: object is locked");
- return;
- }
- my $kadmin = $self->{kadmin};
- my $result;
- if ($self->flag_check ('unchanging')) {
- $result = $kadmin->keytab ($self->{name});
- } else {
- my @enctypes = $self->attr ('enctypes');
- $result = $kadmin->keytab_rekey ($self->{name}, @enctypes);
- }
- if (defined $result) {
- $self->log_action ('get', $user, $host, $time);
- } else {
- $self->error ($kadmin->error);
- }
+ my $result = $self->retrieve ('get', $user, $host, $time);
+ return $result;
+}
+
+# Our update implementation. Generate a new keytab regardless of the
+# unchanging flag.
+sub update {
+ my ($self, $user, $host, $time) = @_;
+ my $result = $self->retrieve ('update', $user, $host, $time);
return $result;
}
diff --git a/perl/lib/Wallet/Object/Password.pm b/perl/lib/Wallet/Object/Password.pm
new file mode 100644
index 0000000..3fd6ec8
--- /dev/null
+++ b/perl/lib/Wallet/Object/Password.pm
@@ -0,0 +1,228 @@
+# Wallet::Object::Password -- Password object implementation for the wallet.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2015
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+##############################################################################
+# Modules and declarations
+##############################################################################
+
+package Wallet::Object::Password;
+require 5.006;
+
+use strict;
+use warnings;
+use vars qw(@ISA $VERSION);
+
+use Crypt::GeneratePassword qw(chars);
+use Digest::MD5 qw(md5_hex);
+use Wallet::Config ();
+use Wallet::Object::File;
+
+@ISA = qw(Wallet::Object::File);
+
+# This version should be increased on any code change to this module. Always
+# use two digits for the minor version with a leading zero if necessary so
+# that it will sort properly.
+$VERSION = '0.01';
+
+##############################################################################
+# File naming
+##############################################################################
+
+# Returns the path into which that password object will be stored or undef on
+# error. On error, sets the internal error.
+sub file_path {
+ my ($self) = @_;
+ my $name = $self->{name};
+ unless ($Wallet::Config::PWD_FILE_BUCKET) {
+ $self->error ('password support not configured');
+ return;
+ }
+ unless ($name) {
+ $self->error ('password objects may not have empty names');
+ return;
+ }
+ my $hash = substr (md5_hex ($name), 0, 2);
+ $name =~ s/([^\w-])/sprintf ('%%%02X', ord ($1))/ge;
+ my $parent = "$Wallet::Config::PWD_FILE_BUCKET/$hash";
+ unless (-d $parent || mkdir ($parent, 0700)) {
+ $self->error ("cannot create password bucket $hash: $!");
+ return;
+ }
+ return "$Wallet::Config::PWD_FILE_BUCKET/$hash/$name";
+}
+
+##############################################################################
+# Shared methods
+##############################################################################
+
+# Return the contents of the file.
+sub retrieve {
+ my ($self, $operation, $user, $host, $time) = @_;
+ $time ||= time;
+ my $id = $self->{type} . ':' . $self->{name};
+ if ($self->flag_check ('locked')) {
+ $self->error ("cannot get $id: object is locked");
+ return;
+ }
+ my $path = $self->file_path;
+ return unless $path;
+
+ # If nothing is yet stored, or we have requested an update, generate a
+ # random password and save it to the file.
+ my $schema = $self->{schema};
+ my %search = (ob_type => $self->{type},
+ ob_name => $self->{name});
+ my $object = $schema->resultset('Object')->find (\%search);
+ if (!$object->ob_stored_on || $operation eq 'update') {
+ unless (open (FILE, '>', $path)) {
+ $self->error ("cannot store initial settings for $id: $!\n");
+ return;
+ }
+ my $pass = chars ($Wallet::Config::PWD_LENGTH_MIN,
+ $Wallet::Config::PWD_LENGTH_MAX);
+ print FILE $pass;
+ $self->log_action ('store', $user, $host, $time);
+ unless (close FILE) {
+ $self->error ("cannot get $id: $!");
+ return;
+ }
+ }
+
+ unless (open (FILE, '<', $path)) {
+ $self->error ("cannot get $id: object has not been stored");
+ return;
+ }
+ local $/;
+ my $data = <FILE>;
+ unless (close FILE) {
+ $self->error ("cannot get $id: $!");
+ return;
+ }
+ $self->log_action ($operation, $user, $host, $time);
+ return $data;
+}
+
+##############################################################################
+# Core methods
+##############################################################################
+
+# Return the contents of the file.
+sub get {
+ my ($self, $user, $host, $time) = @_;
+ my $result = $self->retrieve ('get', $user, $host, $time);
+ return $result;
+}
+
+# Return the contents of the file after resetting them to a random string.
+sub update {
+ my ($self, $user, $host, $time) = @_;
+ my $result = $self->retrieve ('update', $user, $host, $time);
+ return $result;
+}
+
+1;
+__END__
+
+##############################################################################
+# Documentation
+##############################################################################
+
+=head1 NAME
+
+Wallet::Object::Password - Password object implementation for wallet
+
+=for stopwords
+API HOSTNAME DATETIME keytab remctld backend nul Allbery wallet-backend
+
+=head1 SYNOPSIS
+
+ my @name = qw(file mysql-lsdb)
+ my @trace = ($user, $host, time);
+ my $object = Wallet::Object::Password->create (@name, $schema, @trace);
+ unless ($object->store ("the-password\n")) {
+ die $object->error, "\n";
+ }
+ my $password = $object->get (@trace);
+ $object->destroy (@trace);
+
+=head1 DESCRIPTION
+
+Wallet::Object::Password is an extension of Wallet::Object::File,
+acting as a representation of simple file objects in the wallet. The
+difference between the two is that if there is no data stored in a
+password object when a user tries to get it for the first time, then a
+random string suited for a password will be generated and put into the
+object data.
+
+It implements the wallet object API and provides the necessary
+glue to store a file on the wallet server, retrieve it later, and delete
+it when the password object is deleted.
+
+To use this object, the configuration option specifying where on the
+wallet server to store password objects must be set. See
+L<Wallet::Config> for details on this configuration parameter and
+information about how to set wallet configuration.
+
+=head1 METHODS
+
+This object mostly inherits from Wallet::Object::File. See the
+documentation for that class for all generic methods. Below are only
+those methods that are overridden or behave specially for this
+implementation.
+
+=over 4
+
+=item get(PRINCIPAL, HOSTNAME [, DATETIME])
+
+Retrieves the current contents of the file object or undef on error.
+store() must be called before get() will be successful. The caller should
+call error() to get the error message if get() returns undef. PRINCIPAL,
+HOSTNAME, and DATETIME are stored as history information. PRINCIPAL
+should be the user who is downloading the keytab. If DATETIME isn't
+given, the current time is used.
+
+=back
+
+=head1 FILES
+
+=over 4
+
+=item PWD_FILE_BUCKET/<hash>/<file>
+
+Password files are stored on the wallet server under the directory
+PWD_FILE_BUCKET as set in the wallet configuration. <hash> is the
+first two characters of the hex-encoded MD5 hash of the wallet password
+object name, used to not put too many files in the same directory.
+<file> is the name of the password object with all characters other
+than alphanumerics, underscores, and dashes replaced by C<%> and the
+hex code of the character.
+
+=back
+
+=head1 LIMITATIONS
+
+The wallet implementation itself can handle arbitrary password object
+names. However, due to limitations in the B<remctld> server usually
+used to run B<wallet-backend>, password object names containing nul
+characters (ASCII 0) may not be permitted. The file system used for
+storing file objects may impose a length limitation on the
+password object name.
+
+=head1 SEE ALSO
+
+remctld(8), Wallet::Config(3), Wallet::Object::File(3),
+wallet-backend(8)
+
+This module is part of the wallet system. The current version is
+available from L<http://www.eyrie.org/~eagle/software/wallet/>.
+
+=head1 AUTHOR
+
+Jon Robertson <jonrober@stanford.edu>
+
+=cut
diff --git a/perl/lib/Wallet/Policy/Stanford.pm b/perl/lib/Wallet/Policy/Stanford.pm
index a392476..86e204e 100644
--- a/perl/lib/Wallet/Policy/Stanford.pm
+++ b/perl/lib/Wallet/Policy/Stanford.pm
@@ -25,8 +25,8 @@ our (@EXPORT_OK, $VERSION);
# against circular module loading (not that we load any modules, but
# consistency is good).
BEGIN {
- $VERSION = '1.00';
- @EXPORT_OK = qw(default_owner verify_name);
+ $VERSION = '1.01';
+ @EXPORT_OK = qw(default_owner verify_name is_for_host);
}
##############################################################################
@@ -66,8 +66,9 @@ our %FILE_TYPE = (
'password-root' => { host => 1 },
'password-tivoli' => { host => 1 },
properties => { extra => 1 },
- 'ssh-dsa' => { host => 1 },
- 'ssh-rsa' => { host => 1 },
+ 'ssh-dsa' => { host => 1, extra => 1 },
+ 'ssh-rsa' => { host => 1, extra => 1 },
+ 'ssl-chain' => { host => 1, extra => 1 },
'ssl-key' => { host => 1, extra => 1 },
'ssl-keypair' => { host => 1, extra => 1 },
'ssl-keystore' => { extra => 1 },
@@ -75,6 +76,29 @@ our %FILE_TYPE = (
'tivoli-key' => { host => 1 },
);
+# Password object types. Most of these mimic file object types (which should
+# be gradually phased out).
+our %PASSWORD_TYPE = (
+ 'ipmi' => { host => 1 },
+ 'root' => { host => 1 },
+ 'tivoli' => { host => 1 },
+ 'system' => { host => 1, extra => 1, need_extra => 1 },
+ 'app' => { host => 1, extra => 1, need_extra => 1 },
+ 'service' => { extra => 1, need_extra => 1 },
+);
+
+# Mappings that let us determine the host for a host-based object, if any.
+our %HOST_FOR = (
+ 'keytab' => \&_host_for_keytab,
+ 'file' => \&_host_for_file,
+ 'password' => \&_host_for_password,
+ 'duo' => \&_host_for_duo,
+ 'duo-pam' => \&_host_for_duo,
+ 'duo-radius' => \&_host_for_duo,
+ 'duo-ldap' => \&_host_for_duo,
+ 'duo-rdp' => \&_host_for_duo,
+);
+
# Host-based file object types for the legacy file object naming scheme.
our @FILE_HOST_LEGACY = qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key);
@@ -144,6 +168,17 @@ sub _host_for_file_legacy {
return $host;
}
+# Map a password object name to a hostname. Returns undef if this password
+# object name doesn't map to a hostname.
+sub _host_for_password {
+ my ($name) = @_;
+
+ # Parse the name and check whether this is a host-based object.
+ my ($type, $host) = split('/', $name);
+ return if !$PASSWORD_TYPE{$type}{host};
+ return $host;
+}
+
# Map a file object name to a hostname. Returns undef if this file object
# name doesn't map to a hostname.
sub _host_for_file {
@@ -181,6 +216,23 @@ sub _host_for_duo {
return $name;
}
+# Take a object type and name, along with a host name, and use these to
+# decide if the given object is host-based and matches the given host.
+sub is_for_host {
+ my ($type, $name, $host) = @_;
+
+ # If we have a possible host mapping, get the host and see if it matches.
+ if (defined($HOST_FOR{$type})) {
+ my $object_host = $HOST_FOR{$type}->($name);
+ return 0 unless $object_host;
+ if ($host eq $object_host) {
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
# The default owner of host-based objects should be the host keytab and the
# NetDB ACL for that host, with one twist. If the creator of a new node is
# using a root instance, we want to require everyone managing that node be
@@ -188,20 +240,9 @@ sub _host_for_duo {
sub default_owner {
my ($type, $name) = @_;
- # How to determine the host for host-based objects.
- my %host_for = (
- 'keytab' => \&_host_for_keytab,
- 'file' => \&_host_for_file,
- 'duo' => \&_host_for_duo,
- 'duo-pam' => \&_host_for_duo,
- 'duo-radius' => \&_host_for_duo,
- 'duo-ldap' => \&_host_for_duo,
- 'duo-rdp' => \&_host_for_duo,
- );
-
# If we have a possible host mapping, see if we can use that.
- if (defined($host_for{$type})) {
- my $host = $host_for{$type}->($name);
+ if (defined($HOST_FOR{$type})) {
+ my $host = $HOST_FOR{$type}->($name);
if ($host) {
my $acl_name = "host/$host";
my @acl;
@@ -242,7 +283,7 @@ sub default_owner {
# hostnames, limit the acceptable characters for service/* keytabs, and
# enforce our naming constraints on */cgi principals.
#
-# Also use this function to require that IDG staff always do implicit object
+# Also use this function to require that ACS staff always do implicit object
# creation using a */root instance.
sub verify_name {
my ($type, $name, $user) = @_;
@@ -363,6 +404,8 @@ sub verify_name {
return "missing component in $name";
}
return;
+
+
} else {
# Legacy naming scheme.
my %groups = map { $_ => 1 } @GROUPS_LEGACY;
@@ -380,6 +423,71 @@ sub verify_name {
}
}
+ # Check password object naming conventions.
+ if ($type eq 'password') {
+ if ($name =~ m{ / }xms) {
+ my @name = split('/', $name);
+
+ # Names have between two and four components and all must be
+ # non-empty.
+ if (@name > 4) {
+ return "too many components in $name";
+ }
+ if (@name < 2) {
+ return "too few components in $name";
+ }
+ if (grep { $_ eq q{} } @name) {
+ return "empty component in $name";
+ }
+
+ # All objects start with the type. First check if this is a
+ # host-based type.
+ my $type = shift @name;
+ if ($PASSWORD_TYPE{$type} && $PASSWORD_TYPE{$type}{host}) {
+ my ($host, $extra) = @name;
+ if ($host !~ m{ [.] }xms) {
+ return "host name $host is not fully qualified";
+ }
+ if (defined($extra) && !$PASSWORD_TYPE{$type}{extra}) {
+ return "extraneous component at end of $name";
+ }
+ if (!defined($extra) && $PASSWORD_TYPE{$type}{need_extra}) {
+ return "missing component in $name";
+ }
+ return;
+ }
+
+ # Otherwise, the name is group-based. There be at least two
+ # remaining components.
+ if (@name < 2) {
+ return "too few components in $name";
+ }
+ my ($group, $service, $extra) = @name;
+
+ # Check the group.
+ if (!$ACL_FOR_GROUP{$group}) {
+ return "unknown group $group";
+ }
+
+ # Check the type. Be sure it's not host-based.
+ if (!$PASSWORD_TYPE{$type}) {
+ return "unknown type $type";
+ }
+ if ($PASSWORD_TYPE{$type}{host}) {
+ return "bad name for host-based file type $type";
+ }
+
+ # Check the extra data.
+ if (defined($extra) && !$PASSWORD_TYPE{$type}{extra}) {
+ return "extraneous component at end of $name";
+ }
+ if (!defined($extra) && $PASSWORD_TYPE{$type}{need_extra}) {
+ return "missing component in $name";
+ }
+ return;
+ }
+ }
+
# Check the naming conventions for all Duo object types. The object
# should simply be the host name for now.
if ($type =~ m{^duo(-\w+)?$}) {
diff --git a/perl/lib/Wallet/Report.pm b/perl/lib/Wallet/Report.pm
index bf48308..353cd97 100644
--- a/perl/lib/Wallet/Report.pm
+++ b/perl/lib/Wallet/Report.pm
@@ -175,6 +175,20 @@ sub objects_unused {
return (\%search, \%options);
}
+# Return the SQL statement to find all fiel objects that have been created
+# but have never had information stored (via store).
+sub objects_unstored {
+ my ($self) = @_;
+ my @objects;
+
+ my %search = (ob_stored_on => undef,
+ ob_type => 'file');
+ my %options = (order_by => [ qw/ob_type ob_name/ ],
+ select => [ qw/ob_type ob_name/ ]);
+
+ return (\%search, \%options);
+}
+
# Returns a list of all objects stored in the wallet database in the form of
# type and name pairs. On error and for an empty database, the empty list
# will be returned. To distinguish between an empty list and an error, call
@@ -190,7 +204,7 @@ sub objects {
if (!defined $type || $type eq '') {
($search_ref, $options_ref) = $self->objects_all;
} else {
- if ($type ne 'unused' && @args != 1) {
+ if ($type ne 'unused' && $type ne 'unstored' && @args != 1) {
$self->error ("object searches require one argument to search");
} elsif ($type eq 'type') {
($search_ref, $options_ref) = $self->objects_type (@args);
@@ -202,6 +216,8 @@ sub objects {
($search_ref, $options_ref) = $self->objects_acl (@args);
} elsif ($type eq 'unused') {
($search_ref, $options_ref) = $self->objects_unused (@args);
+ } elsif ($type eq 'unstored') {
+ ($search_ref, $options_ref) = $self->objects_unstored (@args);
} else {
$self->error ("do not know search type: $type");
}
@@ -226,12 +242,124 @@ sub objects {
return @objects;
}
+# Returns a list of all object_history records stored in the wallet database
+# including all of their fields. On error and for an empty database, the
+# empty list will be returned. To distinguish between an empty list and an
+# error, call error(), which will return undef if there was no error.
+# Farms out specific statement to another subroutine for specific search
+# types, but each case should return ob_type and ob_name in that order.
+sub objects_history {
+ my ($self, $search_type, @args) = @_;
+ undef $self->{error};
+
+ # All fields in the order we want to see them.
+ my @fields = ('oh_on', 'oh_by', 'oh_type', 'oh_name', 'oh_action',
+ 'oh_from');
+
+ # Get the search and options array refs from specific functions.
+ my %search = ();
+ my %options = (order_by => \@fields,
+ select => \@fields);
+
+ # Perform the search and return on any errors.
+ my @objects;
+ my $schema = $self->{schema};
+ eval {
+ my @objects_rs
+ = $schema->resultset('ObjectHistory')->search (\%search,
+ \%options);
+ for my $object_rs (@objects_rs) {
+ my @rec;
+ for my $field (@fields) {
+ push (@rec, $object_rs->get_column($field));
+ }
+ push (@objects, \@rec);
+ }
+ };
+ if ($@) {
+ $self->error ("cannot list objects: $@");
+ return;
+ }
+
+ return @objects;
+}
+
+# Returns a list of all objects stored in the wallet database in the form of
+# type and name pairs. On error and for an empty database, the empty list
+# will be returned. To distinguish between an empty list and an error, call
+# error(), which will return undef if there was no error. Farms out specific
+# statement to another subroutine for specific search types, but each case
+# should return ob_type and ob_name in that order.
+sub objects_hostname {
+ my ($self, $type, $hostname) = @_;
+ undef $self->{error};
+
+ # Make sure we have a given hostname.
+ if (!$hostname) {
+ $self->error ("object hosts requires one argument to search");
+ return;
+ }
+
+ # If we don't have a way to get host-based object lists, quit.
+ unless (defined &Wallet::Config::is_for_host) {
+ $self->error ('no host-based policy defined');
+ return;
+ }
+
+ # Search on all objects.
+ my %search = ();
+ my %options = (order_by => [ qw/ob_type ob_name/ ],
+ select => [ qw/ob_type ob_name/ ]);
+
+ my @objects;
+ my $schema = $self->{schema};
+ eval {
+ my @objects_rs = $schema->resultset('Object')->search (\%search,
+ \%options);
+
+ # Check to see if an object is for the given host and add to list if
+ # so.
+ for my $object_rs (@objects_rs) {
+ my $type = $object_rs->ob_type;
+ my $name = $object_rs->ob_name;
+ next unless &Wallet::Config::is_for_host($type, $name, $hostname);
+ push (@objects, [ $type, $name ]);
+ }
+ };
+ if ($@) {
+ $self->error ("cannot list objects: $@");
+ return;
+ }
+
+ return @objects;
+}
+
+##############################################################################
+# Type reports
+##############################################################################
+
+# Return an alphabetical list of all valid types set up, along with the class
+# that they belong to.
+sub types {
+ my ($self) = @_;
+
+ my (@types);
+ my @types_rs = $self->{schema}->resultset('Type')->all;
+ for my $type_rs (@types_rs) {
+ my $name = $type_rs->ty_name;
+ my $class = $type_rs->ty_class;
+ push(@types, [ $name, $class ]);
+ }
+
+ @types = sort { $a->[0] cmp $b->[0] } @types;
+ return @types;
+}
+
##############################################################################
# ACL reports
##############################################################################
-# Returns the SQL statement required to find and return all ACLs in the
-# database.
+# Returns the array of all ACLs in the database.
sub acls_all {
my ($self) = @_;
my @acls;
@@ -255,7 +383,7 @@ sub acls_all {
return (@acls);
}
-# Returns the SQL statement required to find all empty ACLs in the database.
+# Returns the array of all empty ACLs in the database.
sub acls_empty {
my ($self) = @_;
my @acls;
@@ -281,9 +409,36 @@ sub acls_empty {
return (@acls);
}
-# Returns the SQL statement and the field required to find ACLs containing the
-# specified entry. The identifier is automatically surrounded by wildcards to
-# do a substring search.
+# Returns the array of ACLs that nest a given ACL.
+sub acls_nesting {
+ my ($self, $name) = @_;
+ my @acls;
+
+ my $schema = $self->{schema};
+ my %search = (ae_scheme => 'nested',
+ ae_identifier => $name);
+ my %options = (join => 'acl_entries',
+ prefetch => 'acl_entries',
+ order_by => [ qw/ac_id/ ],
+ select => [ qw/ac_id ac_name/ ]);
+
+ eval {
+ my @acls_rs = $schema->resultset('Acl')->search (\%search, \%options);
+ for my $acl_rs (@acls_rs) {
+ push (@acls, [ $acl_rs->ac_id, $acl_rs->ac_name ]);
+ }
+ };
+
+ if ($@) {
+ $self->error ("cannot list ACLs: $@");
+ return;
+ }
+ return (@acls);
+}
+
+# Returns the array of all ACLs containing the specified entry. The given
+# identifier is automatically surrounded by wildcards to do a substring
+# search.
sub acls_entry {
my ($self, $type, $identifier) = @_;
my @acls;
@@ -311,7 +466,7 @@ sub acls_entry {
return (@acls);
}
-# Returns the SQL statement required to find unused ACLs.
+# Returns the array of all unused ACLs.
sub acls_unused {
my ($self) = @_;
my @acls;
@@ -424,6 +579,13 @@ sub acls {
@acls = $self->acls_empty;
} elsif ($type eq 'unused') {
@acls = $self->acls_unused;
+ } elsif ($type eq 'nesting') {
+ if (@args == 0) {
+ $self->error ('ACL nesting search requires an ACL to search');
+ return;
+ } else {
+ @acls = $self->acls_nesting (@args);
+ }
} else {
$self->error ("unknown search type: $type");
return;
@@ -469,6 +631,23 @@ sub owners {
return @owners;
}
+# Return an alphabetical list of all valid types set up, along with the class
+# that they belong to.
+sub acl_schemes {
+ my ($self) = @_;
+
+ my (@schemes);
+ my @acls_rs = $self->{schema}->resultset('AclScheme')->all;
+ for my $acl_rs (@acls_rs) {
+ my $name = $acl_rs->as_name;
+ my $class = $acl_rs->as_class;
+ push(@schemes, [ $name, $class ]);
+ }
+
+ @schemes = sort { $a->[0] cmp $b->[0] } @schemes;
+ return @schemes;
+}
+
##############################################################################
# Auditing
##############################################################################
@@ -633,14 +812,17 @@ Returns a list of all objects matching a search type and string in the
database, or all objects in the database if no search information is
given.
-There are five types of searches currently. C<type>, with a given type,
-will return only those entries where the type matches the given type.
-C<owner>, with a given owner, will only return those objects owned by the
-given ACL name or ID. C<flag>, with a given flag name, will only return
-those items with a flag set to the given value. C<acl> operates like
-C<owner>, but will return only those objects that have the given ACL name
-or ID on any of the possible ACL settings, not just owner. C<unused> will
-return all entries for which a get command has never been issued.
+There are several types of searches. C<type>, with a given type, will
+return only those entries where the type matches the given type.
+C<owner>, with a given owner, will only return those objects owned by
+the given ACL name or ID. C<flag>, with a given flag name, will only
+return those items with a flag set to the given value. C<acl> operates
+like C<owner>, but will return only those objects that have the given
+ACL name or ID on any of the possible ACL settings, not just owner.
+C<unused> will return all entries for which a get command has never
+been issued. C<unstored> will return all entries for which a store
+command has never been issued (limited to file type since storing isn't
+needed for other types).
The return value is a list of references to pairs of type and name. For
example, if two objects existed in the database, both of type C<keytab>
@@ -654,6 +836,24 @@ empty search result, the caller should call error(). error() is
guaranteed to return the error message if there was an error and undef if
there was no error.
+=item objects_history(TYPE)
+
+Returns a dump of the entire object history table. The return value is
+a list of references to each field in that table, in the following order:
+
+ oh_on, oh_by, oh_type, oh_name, oh_action, oh_from
+
+=item objects_hostname(TYPE, HOSTNAME)
+
+Returns a list of all host-based objects for a given hostname. The
+output is identical to the general objects command, but we need to
+separate this out because the way it searches is very different.
+
+Returns the empty list on failure. To distinguish between this and an
+empty search result, the caller should call error(). error() is
+guaranteed to return the error message if there was an error and undef if
+there was no error.
+
=item owners(TYPE, NAME)
Returns a list of all ACL lines contained in owner ACLs for objects
diff --git a/perl/lib/Wallet/Schema.pm b/perl/lib/Wallet/Schema.pm
index 5b850c0..386801a 100644
--- a/perl/lib/Wallet/Schema.pm
+++ b/perl/lib/Wallet/Schema.pm
@@ -114,6 +114,10 @@ Holds the supported ACL schemes and their corresponding Perl classes:
insert into acl_schemes (as_name, as_class)
values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute');
insert into acl_schemes (as_name, as_class)
+ values ('ldap-attr-root', 'Wallet::ACL::LDAP::Attribute::Root');
+ insert into acl_schemes (as_name, as_class)
+ values ('nested', 'Wallet::ACL::Nested');
+ insert into acl_schemes (as_name, as_class)
values ('netdb', 'Wallet::ACL::NetDB');
insert into acl_schemes (as_name, as_class)
values ('netdb-root', 'Wallet::ACL::NetDB::Root');
diff --git a/perl/lib/Wallet/Schema/Result/AclScheme.pm b/perl/lib/Wallet/Schema/Result/AclScheme.pm
index 91a58b2..be4ec09 100644
--- a/perl/lib/Wallet/Schema/Result/AclScheme.pm
+++ b/perl/lib/Wallet/Schema/Result/AclScheme.pm
@@ -36,6 +36,10 @@ By default it contains the following entries:
insert into acl_schemes (as_name, as_class)
values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute');
insert into acl_schemes (as_name, as_class)
+ values ('ldap-attr-root', 'Wallet::ACL::LDAP::Attribute::Root');
+ insert into acl_schemes (as_name, as_class)
+ values ('nested', 'Wallet::ACL::Nested');
+ insert into acl_schemes (as_name, as_class)
values ('netdb', 'Wallet::ACL::NetDB');
insert into acl_schemes (as_name, as_class)
values ('netdb-root', 'Wallet::ACL::NetDB::Root');
diff --git a/perl/lib/Wallet/Server.pm b/perl/lib/Wallet/Server.pm
index f6ea342..946ba10 100644
--- a/perl/lib/Wallet/Server.pm
+++ b/perl/lib/Wallet/Server.pm
@@ -154,8 +154,8 @@ sub create_check {
$self->error ($acl->error);
return;
}
- @entries = sort { $$a[0] cmp $$b[0] && $$a[1] cmp $$b[1] } @entries;
- @acl = sort { $$a[0] cmp $$b[0] && $$a[1] cmp $$b[1] } @acl;
+ @entries = sort { $$a[0] cmp $$b[0] || $$a[1] cmp $$b[1] } @entries;
+ @acl = sort { $$a[0] cmp $$b[0] || $$a[1] cmp $$b[1] } @acl;
my $okay = 1;
if (@entries != @acl) {
$okay = 0;
@@ -516,6 +516,21 @@ sub get {
return $result;
}
+# Retrieve the information associated with an object, updating the current
+# information if we are of a type that allows autogenerated information.
+# Returns undef and sets the internal error if the retrieval fails or if the
+# user isn't authorized. If the object doesn't exist, attempts dynamic
+# creation of the object using the default ACL mappings (if any).
+sub update {
+ my ($self, $type, $name) = @_;
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ return unless $self->acl_verify ($object, 'get');
+ my $result = $object->update ($self->{user}, $self->{host});
+ $self->error ($object->error) unless defined $result;
+ return $result;
+}
+
# Store new data in an object, or returns undef and sets the internal error if
# the object can't be found or if the user isn't authorized. Also don't
# permit storing undef, although storing the empty string is fine. If the
@@ -734,6 +749,36 @@ sub acl_rename {
return 1;
}
+# Move all ACLs owned by one ACL to another, or return undef and set the
+# internal error.
+sub acl_replace {
+ my ($self, $old_id, $replace_id) = @_;
+ unless ($self->{admin}->check ($self->{user})) {
+ $self->acl_error ($old_id, 'replace');
+ return;
+ }
+ my $acl = eval { Wallet::ACL->new ($old_id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+ if ($acl->name eq 'ADMIN') {
+ $self->error ('cannot replace the ADMIN ACL');
+ return;
+ }
+ my $replace_acl = eval { Wallet::ACL->new ($replace_id, $self->{schema}) };
+ if ($@) {
+ $self->error ($@);
+ return;
+ }
+
+ unless ($acl->replace ($replace_id, $self->{user}, $self->{host})) {
+ $self->error ($acl->error);
+ return;
+ }
+ return 1;
+}
+
# Destroy an ACL, deleting it out of the database. Returns true on success.
# On failure, returns undef, setting the internal error.
sub acl_destroy {
@@ -942,6 +987,14 @@ either the current name or the numeric ID. NEW must not be all-numeric.
To rename an ACL, the current user must be authorized by the ADMIN ACL.
Returns true on success and false on failure.
+=item acl_replace(OLD, NEW)
+
+Moves any object owned by the ACL identified by OLD to be instead owned by
+NEW. This goes through all objects owned by OLD and individually changes
+the owner, along with history updates. OLD and NEW may be either the name
+or the numeric ID. To replace an ACL, the current user must be authorized
+by the ADMIN ACL. Returns true on success and false on failure.
+
=item acl_show(ID)
Returns a human-readable description, including membership, of the ACL
diff --git a/perl/sql/wallet-1.3-update-duo.sql b/perl/sql/wallet-1.3-update-duo.sql
new file mode 100644
index 0000000..affadcd
--- /dev/null
+++ b/perl/sql/wallet-1.3-update-duo.sql
@@ -0,0 +1,9 @@
+--
+-- Run on installing wallet 1.3 in order to update what the Duo types
+-- point to for modules.
+--
+
+UPDATE types set ty_class='Wallet::Object::Duo' where ty_name='duo-ldap';
+UPDATE types set ty_class='Wallet::Object::Duo' where ty_name='duo-pam';
+UPDATE types set ty_class='Wallet::Object::Duo' where ty_name='duo-radius';
+UPDATE types set ty_class='Wallet::Object::Duo' where ty_name='duo-rdp';
diff --git a/perl/t/general/acl.t b/perl/t/general/acl.t
index 1dd5c53..4de7493 100755
--- a/perl/t/general/acl.t
+++ b/perl/t/general/acl.t
@@ -12,11 +12,11 @@ use strict;
use warnings;
use POSIX qw(strftime);
-use Test::More tests => 101;
+use Test::More tests => 115;
use Wallet::ACL;
use Wallet::Admin;
-use Wallet::Server;
+use Wallet::Object::Base;
use lib 't/lib';
use Util;
@@ -46,7 +46,7 @@ $acl = eval { Wallet::ACL->create (3, $schema, @trace) };
ok (!defined ($acl), 'Creating with a numeric name');
is ($@, "ACL name may not be all numbers\n", ' with the right error message');
$acl = eval { Wallet::ACL->create ('test', $schema, @trace) };
-ok (!defined ($acl), 'Creating a duplicate object');
+ok (!defined ($acl), 'Creating a duplicate acl');
like ($@, qr/^cannot create ACL test: /, ' with the right error message');
$acl = eval { Wallet::ACL->new ('test2', $schema) };
ok (!defined ($acl), 'Searching for a non-existent ACL');
@@ -62,32 +62,6 @@ is ($@, '', ' with no exceptions');
ok ($acl->isa ('Wallet::ACL'), ' and the right class');
is ($acl->name, 'test', ' and the right name');
-# Test rename.
-if ($acl->rename ('example', @trace)) {
- ok (1, 'Renaming the ACL');
-} else {
- is ($acl->error, '', 'Renaming the ACL');
-}
-is ($acl->name, 'example', ' and the new name is right');
-is ($acl->id, 2, ' and the ID did not change');
-$acl = eval { Wallet::ACL->new ('test', $schema) };
-ok (!defined ($acl), ' and it cannot be found under the old name');
-is ($@, "ACL test not found\n", ' with the right error message');
-$acl = eval { Wallet::ACL->new ('example', $schema) };
-ok (defined ($acl), ' and it can be found with the new name');
-is ($@, '', ' with no exceptions');
-is ($acl->name, 'example', ' and the right name');
-is ($acl->id, 2, ' and the right ID');
-$acl = eval { Wallet::ACL->new (2, $schema) };
-ok (defined ($acl), ' and it can still found by ID');
-is ($@, '', ' with no exceptions');
-is ($acl->name, 'example', ' and the right name');
-is ($acl->id, 2, ' and the right ID');
-ok (! $acl->rename ('ADMIN', @trace),
- ' but renaming to an existing name fails');
-like ($acl->error, qr/^cannot rename ACL 2 to ADMIN: /,
- ' with the right error');
-
# Test add, check, remove, list, and show.
my @entries = $acl->list;
is (scalar (@entries), 0, 'ACL starts empty');
@@ -124,14 +98,14 @@ is ($entries[0][1], $user1, ' and the right identifier for 1');
is ($entries[1][0], 'krb5', ' and the right scheme for 2');
is ($entries[1][1], $user2, ' and the right identifier for 2');
my $expected = <<"EOE";
-Members of ACL example (id: 2) are:
+Members of ACL test (id: 2) are:
krb5 $user1
krb5 $user2
EOE
is ($acl->show, $expected, ' and show returns correctly');
ok (! $acl->remove ('krb5', $admin, @trace),
'Removing a nonexistent entry fails');
-is ($acl->error, "cannot remove krb5:$admin from 2: entry not found in ACL",
+is ($acl->error, "cannot remove krb5:$admin from test: entry not found in ACL",
' with the right error');
if ($acl->remove ('krb5', $user1, @trace)) {
ok (1, ' but removing the first user works');
@@ -145,7 +119,7 @@ is (scalar (@entries), 1, ' and now there is one entry');
is ($entries[0][0], 'krb5', ' with the right scheme');
is ($entries[0][1], $user2, ' and the right identifier');
ok (! $acl->add ('krb5', $user2), 'Adding the same entry again fails');
-like ($acl->error, qr/^cannot add \Qkrb5:$user2\E to 2: /,
+like ($acl->error, qr/^cannot add \Qkrb5:$user2\E to test: /,
' with the right error');
if ($acl->add ('krb5', '', @trace)) {
ok (1, 'Adding a bad entry works');
@@ -159,7 +133,7 @@ is ($entries[0][1], '', ' and the right identifier for 1');
is ($entries[1][0], 'krb5', ' and the right scheme for 2');
is ($entries[1][1], $user2, ' and the right identifier for 2');
$expected = <<"EOE";
-Members of ACL example (id: 2) are:
+Members of ACL test (id: 2) are:
krb5
krb5 $user2
EOE
@@ -187,17 +161,50 @@ if ($acl->remove ('krb5', '', @trace)) {
}
@entries = $acl->list;
is (scalar (@entries), 0, ' and now there are no entries');
-is ($acl->show, "Members of ACL example (id: 2) are:\n", ' and show concurs');
+is ($acl->show, "Members of ACL test (id: 2) are:\n", ' and show concurs');
is ($acl->check ($user2), 0, ' and the second user check fails');
is (scalar ($acl->check_errors), '', ' with no error message');
+# Test rename.
+my $acl_nest = eval { Wallet::ACL->create ('test-nesting', $schema, @trace) };
+ok (defined ($acl_nest), 'ACL creation for setting up nested');
+if ($acl_nest->add ('nested', 'test', @trace)) {
+ ok (1, ' and adding the nesting');
+} else {
+ is ($acl_nest->error, '', ' and adding the nesting');
+}
+if ($acl->rename ('example', @trace)) {
+ ok (1, 'Renaming the ACL');
+} else {
+ is ($acl->error, '', 'Renaming the ACL');
+}
+is ($acl->name, 'example', ' and the new name is right');
+is ($acl->id, 2, ' and the ID did not change');
+$acl = eval { Wallet::ACL->new ('test', $schema) };
+ok (!defined ($acl), ' and it cannot be found under the old name');
+is ($@, "ACL test not found\n", ' with the right error message');
+$acl = eval { Wallet::ACL->new ('example', $schema) };
+ok (defined ($acl), ' and it can be found with the new name');
+is ($@, '', ' with no exceptions');
+is ($acl->name, 'example', ' and the right name');
+is ($acl->id, 2, ' and the right ID');
+$acl = eval { Wallet::ACL->new (2, $schema) };
+ok (defined ($acl), ' and it can still found by ID');
+is ($@, '', ' with no exceptions');
+is ($acl->name, 'example', ' and the right name');
+is ($acl->id, 2, ' and the right ID');
+ok (! $acl->rename ('ADMIN', @trace),
+ ' but renaming to an existing name fails');
+like ($acl->error, qr/^cannot rename ACL example to ADMIN: /,
+ ' with the right error');
+@entries = $acl_nest->list;
+is ($entries[0][1], 'example', ' and the name in a nested ACL updated');
+
# Test history.
my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]);
my $history = <<"EOO";
$date create
by $admin from $host
-$date rename from test
- by $admin from $host
$date add krb5 $user1
by $admin from $host
$date add krb5 $user2
@@ -210,14 +217,24 @@ $date remove krb5 $user2
by $admin from $host
$date remove krb5
by $admin from $host
+$date rename from test
+ by $admin from $host
EOO
is ($acl->history, $history, 'History is correct');
# Test destroy.
+$acl->destroy (@trace);
+is ($acl->error, 'cannot destroy ACL example: ACL is nested in ACL test-nesting',
+ 'Destroying a nested ACL fails');
+if ($acl_nest->remove ('nested', 'example', @trace)) {
+ ok (1, ' and removing the nesting succeeds');
+} else {
+ is ($acl_nest->error, '', 'and removing the nesting succeeds');
+}
if ($acl->destroy (@trace)) {
- ok (1, 'Destroying the ACL works');
+ ok (1, ' and now destroying the ACL works');
} else {
- is ($acl->error, '', 'Destroying the ACL works');
+ is ($acl->error, '', ' and now destroying the ACL works');
}
$acl = eval { Wallet::ACL->new ('example', $schema) };
ok (!defined ($acl), ' and now cannot be found');
@@ -225,11 +242,71 @@ is ($@, "ACL example not found\n", ' with the right error message');
$acl = eval { Wallet::ACL->new (2, $schema) };
ok (!defined ($acl), ' or by ID');
is ($@, "ACL 2 not found\n", ' with the right error message');
+@entries = $acl_nest->list;
+is (scalar (@entries), 0, ' and it is no longer a nested entry');
$acl = eval { Wallet::ACL->create ('example', $schema, @trace) };
ok (defined ($acl), ' and creating another with the same name works');
is ($@, '', ' with no exceptions');
is ($acl->name, 'example', ' and the right name');
-like ($acl->id, qr{\A[23]\z}, ' and an ID of 2 or 3');
+like ($acl->id, qr{\A[34]\z}, ' and an ID of 3 or 4');
+
+# Test replace. by creating three acls, then assigning two objects to the
+# first, one to the second, and another to the third. Then replace the first
+# acl with the second, so that we can verify that multiple objects are moved,
+# that an object already belonging to the new acl is okay, and that the
+# objects with unrelated ACL are unaffected.
+my ($acl_old, $acl_new, $acl_other, $obj_old_one, $obj_old_two, $obj_new,
+ $obj_unrelated);
+eval {
+ $acl_old = Wallet::ACL->create ('example-old', $schema, @trace);
+ $acl_new = Wallet::ACL->create ('example-new', $schema, @trace);
+ $acl_other = Wallet::ACL->create ('example-other', $schema, @trace);
+};
+is ($@, '', 'ACLs needed for testing replace are created');
+eval {
+ $obj_old_one = Wallet::Object::Base->create ('keytab',
+ 'service/test1@EXAMPLE.COM',
+ $schema, @trace);
+ $obj_old_two = Wallet::Object::Base->create ('keytab',
+ 'service/test2@EXAMPLE.COM',
+ $schema, @trace);
+ $obj_new = Wallet::Object::Base->create ('keytab',
+ 'service/test3@EXAMPLE.COM',
+ $schema, @trace);
+ $obj_unrelated = Wallet::Object::Base->create ('keytab',
+ 'service/test4@EXAMPLE.COM',
+ $schema, @trace);
+};
+is ($@, '', ' and so were needed objects');
+if ($obj_old_one->owner ('example-old', @trace)
+ && $obj_old_two->owner ('example-old', @trace)
+ && $obj_new->owner ('example-new', @trace)
+ && $obj_unrelated->owner ('example-other', @trace)) {
+
+ ok (1, ' and setting initial ownership on the objects succeeds');
+}
+is ($acl_old->replace('example-new', @trace), 1,
+ ' and replace ran successfully');
+eval {
+ $obj_old_one = Wallet::Object::Base->new ('keytab',
+ 'service/test1@EXAMPLE.COM',
+ $schema);
+ $obj_old_two = Wallet::Object::Base->new ('keytab',
+ 'service/test2@EXAMPLE.COM',
+ $schema);
+ $obj_new = Wallet::Object::Base->new ('keytab',
+ 'service/test3@EXAMPLE.COM',
+ $schema);
+ $obj_unrelated = Wallet::Object::Base->new ('keytab',
+ 'service/test4@EXAMPLE.COM',
+ $schema);
+};
+is ($obj_old_one->owner, 'example-new', ' and first replace is correct');
+is ($obj_old_two->owner, 'example-new', ' and second replace is correct');
+is ($obj_new->owner, 'example-new',
+ ' and object already with new acl is correct');
+is ($obj_unrelated->owner, 'example-other',
+ ' and unrelated object ownership is correct');
# Clean up.
$setup->destroy;
diff --git a/perl/t/general/report.t b/perl/t/general/report.t
index 8d348ed..e47cdc6 100755
--- a/perl/t/general/report.t
+++ b/perl/t/general/report.t
@@ -11,7 +11,7 @@
use strict;
use warnings;
-use Test::More tests => 197;
+use Test::More tests => 223;
use Wallet::Admin;
use Wallet::Report;
@@ -41,6 +41,32 @@ is (scalar (@acls), 1, 'One ACL in the database');
is ($acls[0][0], 1, ' and that is ACL ID 1');
is ($acls[0][1], 'ADMIN', ' with the right name');
+# Check to see that we have all types that we expect.
+my @types = $report->types;
+is (scalar (@types), 10, 'There are ten types created');
+is ($types[0][0], 'base', ' and the first member is correct');
+is ($types[1][0], 'duo', ' and the second member is correct');
+is ($types[2][0], 'duo-ldap', ' and the third member is correct');
+is ($types[3][0], 'duo-pam', ' and the fourth member is correct');
+is ($types[4][0], 'duo-radius', ' and the fifth member is correct');
+is ($types[5][0], 'duo-rdp', ' and the sixth member is correct');
+is ($types[6][0], 'file', ' and the seventh member is correct');
+is ($types[7][0], 'keytab', ' and the eighth member is correct');
+is ($types[8][0], 'password', ' and the nineth member is correct');
+is ($types[9][0], 'wa-keyring', ' and the tenth member is correct');
+
+# And that we have all schemes that we expect.
+my @schemes = $report->acl_schemes;
+is (scalar (@schemes), 8, 'There are seven acl schemes created');
+is ($schemes[0][0], 'base', ' and the first member is correct');
+is ($schemes[1][0], 'krb5', ' and the second member is correct');
+is ($schemes[2][0], 'krb5-regex', ' and the third member is correct');
+is ($schemes[3][0], 'ldap-attr', ' and the fourth member is correct');
+is ($schemes[4][0], 'ldap-attr-root', ' and the fifth member is correct');
+is ($schemes[5][0], 'nested', ' and the sixth member is correct');
+is ($schemes[6][0], 'netdb', ' and the seventh member is correct');
+is ($schemes[7][0], 'netdb-root', ' and the eighth member is correct');
+
# Create an object.
my $server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') };
is ($@, '', 'Creating a server instance did not die');
@@ -257,6 +283,22 @@ is (scalar (@lines), 1, 'Searching for ACL naming violations finds one');
is ($lines[0][0], 3, ' and the first has the right ID');
is ($lines[0][1], 'second', ' and the right name');
+# Set a host-based object matching script so that we can test the host report.
+# The deactivation trick isn't needed here.
+package Wallet::Config;
+sub is_for_host {
+ my ($type, $name, $host) = @_;
+ my ($service, $principal) = split ('/', $name, 2);
+ return 0 unless $service && $principal;
+ return 1 if $host eq $principal;
+ return 0;
+}
+package main;
+@lines = $report->objects_hostname ('host', 'admin');
+is (scalar (@lines), 1, 'Searching for host-based objects finds one');
+is ($lines[0][0], 'base', ' and the first has the right type');
+is ($lines[0][1], 'service/admin', ' and the right name');
+
# Set up a file bucket so that we can create an object we can retrieve.
system ('rm -rf test-files') == 0 or die "cannot remove test-files\n";
mkdir 'test-files' or die "cannot create test-files: $!\n";
@@ -325,6 +367,13 @@ is ($server->acl_add ('third', 'base', 'baz'), 1,
is (scalar (@acls), 0, 'There are no duplicate ACLs');
is ($report->error, undef, ' and no error');
+# See if the acl nesting report works correctly.
+is ($server->acl_add ('fourth', 'nested', 'second'), 1,
+ 'Adding an ACL as a nested entry for another works');
+@acls = $report->acls ('nesting', 'second');
+is (scalar (@acls), 1, ' and the nested report shows one nesting');
+is ($acls[0][1], 'fourth', ' with the correct ACL nesting it');
+
# Clean up.
$admin->destroy;
system ('rm -r test-files') == 0 or die "cannot remove test-files\n";
diff --git a/perl/t/general/server.t b/perl/t/general/server.t
index 0a527a5..8f4c16c 100755
--- a/perl/t/general/server.t
+++ b/perl/t/general/server.t
@@ -89,7 +89,7 @@ is ($server->acl_rename ('empty', 'test'), undef,
is ($server->error, 'ACL empty not found', ' and returns the right error');
is ($server->acl_rename ('test', 'test2'), undef,
' and cannot rename to an existing name');
-like ($server->error, qr/^cannot rename ACL 6 to test2: /,
+like ($server->error, qr/^cannot rename ACL test to test2: /,
' and returns the right error');
is ($server->acl_rename ('test', 'empty'), 1, 'Renaming does work');
is ($server->acl_rename ('test', 'empty'), undef, ' but not twice');
@@ -138,7 +138,7 @@ is ($server->error, 'ACL test not found', ' and returns the right error');
is ($server->acl_remove ('empty', 'krb5', $user2), undef,
' and removing an entry not there fails');
is ($server->error,
- "cannot remove krb5:$user2 from 6: entry not found in ACL",
+ "cannot remove krb5:$user2 from empty: entry not found in ACL",
' and returns the right error');
is ($server->acl_show ('empty'),
"Members of ACL empty (id: 6) are:\n krb5 $user1\n",
@@ -148,7 +148,7 @@ is ($server->acl_remove ('empty', 'krb5', $user1), 1,
is ($server->acl_remove ('empty', 'krb5', $user1), undef,
' but does not work twice');
is ($server->error,
- "cannot remove krb5:$user1 from 6: entry not found in ACL",
+ "cannot remove krb5:$user1 from empty: entry not found in ACL",
' and returns the right error');
is ($server->acl_show ('empty'), "Members of ACL empty (id: 6) are:\n",
' and show returns the correct status');
@@ -168,7 +168,7 @@ is ($server->acl_remove ('ADMIN', 'krb5', $user1), 1, ' and then remove it');
is ($server->acl_remove ('ADMIN', 'krb5', $user1), undef,
' and remove a user not on it');
is ($server->error,
- "cannot remove krb5:$user1 from 1: entry not found in ACL",
+ "cannot remove krb5:$user1 from ADMIN: entry not found in ACL",
' and get the right error');
# Now, create a few objects to use for testing and test the object API while
@@ -994,7 +994,7 @@ is ($server->owner ('base', 'service/acl-user', 'test-destroy'), 1,
is ($server->acl_destroy ('test-destroy'), undef,
' and now we cannot destroy that ACL');
is ($server->error,
- 'cannot destroy ACL 9: ACL in use by base:service/acl-user',
+ 'cannot destroy ACL test-destroy: ACL in use by base:service/acl-user',
' with the right error');
is ($server->owner ('base', 'service/acl-user', ''), 1,
' but after we clear the owner');
diff --git a/perl/t/object/base.t b/perl/t/object/base.t
index ee9ff4b..8fedd64 100755
--- a/perl/t/object/base.t
+++ b/perl/t/object/base.t
@@ -12,7 +12,7 @@ use strict;
use warnings;
use POSIX qw(strftime);
-use Test::More tests => 137;
+use Test::More tests => 139;
use Wallet::ACL;
use Wallet::Admin;
@@ -208,6 +208,9 @@ is ($object->flag_clear ('locked', @trace), 1, 'Clearing locked succeeds');
eval { $object->get (@trace) };
is ($@, "Do not instantiate Wallet::Object::Base directly\n",
'Get fails with the right error');
+ok (!$object->update (@trace), 'Update fails');
+is ($object->error, 'update is not supported for this type, use get instead',
+ ' with the right error');
ok (! $object->store ("Some data", @trace), 'Store fails');
is ($object->error, "cannot store keytab:$princ: object type is immutable",
' with the right error');
diff --git a/perl/t/object/duo-ldap.t b/perl/t/object/duo-ldap.t
index 3648eba..8a00dbb 100644
--- a/perl/t/object/duo-ldap.t
+++ b/perl/t/object/duo-ldap.t
@@ -26,7 +26,7 @@ BEGIN {
BEGIN {
use_ok('Wallet::Admin');
use_ok('Wallet::Config');
- use_ok('Wallet::Object::Duo::LDAPProxy');
+ use_ok('Wallet::Object::Duo');
}
use lib 't/lib';
@@ -53,15 +53,14 @@ my $mock = Net::Duo::Mock::Agent->new ({ key_file => 't/data/duo/keys.json' });
# Test error handling in the absence of configuration.
my $object = eval {
- Wallet::Object::Duo::LDAPProxy->new ('duo-ldap', 'test', $schema);
+ Wallet::Object::Duo->new ('duo-ldap', 'test', $schema);
};
-is ($object, undef, 'Wallet::Object::Duo::LDAPProxy new with no config failed');
+is ($object, undef, 'Wallet::Object::Duo new with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
$object = eval {
- Wallet::Object::Duo::LDAPProxy->create ('duo-ldap', 'test', $schema,
- @trace);
+ Wallet::Object::Duo->create ('duo-ldap', 'test', $schema, @trace);
};
-is ($object, undef, 'Wallet::Object::Duo::LDAPProxy creation with no config failed');
+is ($object, undef, 'Wallet::Object::Duo creation with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
# Set up the Duo configuration.
@@ -83,9 +82,8 @@ $mock->expect (
response_file => 't/data/duo/integration.json',
}
);
-$object = Wallet::Object::Duo::LDAPProxy->create ('duo-ldap', 'test', $schema,
- @trace);
-isa_ok ($object, 'Wallet::Object::Duo::LDAPProxy');
+$object = Wallet::Object::Duo->create ('duo-ldap', 'test', $schema, @trace);
+isa_ok ($object, 'Wallet::Object::Duo');
# Check the metadata about the new wallet object.
$expected = <<"EOO";
@@ -127,7 +125,7 @@ is ($object->flag_clear ('locked', @trace), 1,
'...and clearing locked flag works');
# Create a new object by wallet type and name.
-$object = Wallet::Object::Duo::LDAPProxy->new ('duo-ldap', 'test', $schema);
+$object = Wallet::Object::Duo->new ('duo-ldap', 'test', $schema);
# Test deleting an integration. We can't test this entirely properly because
# currently Net::Duo::Mock::Agent doesn't support stacking multiple expected
@@ -144,8 +142,7 @@ TODO: {
local $TODO = 'Net::Duo::Mock::Agent not yet capable';
is ($object->destroy (@trace), 1, 'Duo object deletion succeeded');
- $object = eval { Wallet::Object::Duo::LDAPProxy->new ('duo-ldap', 'test',
- $schema) };
+ $object = eval { Wallet::Object::Duo->new ('duo-ldap', 'test', $schema) };
is ($object, undef, '...and now object cannot be retrieved');
is ($@, "cannot find duo:test\n", '...with correct error');
}
diff --git a/perl/t/object/duo-pam.t b/perl/t/object/duo-pam.t
index 7b88787..047343e 100644
--- a/perl/t/object/duo-pam.t
+++ b/perl/t/object/duo-pam.t
@@ -26,7 +26,7 @@ BEGIN {
BEGIN {
use_ok('Wallet::Admin');
use_ok('Wallet::Config');
- use_ok('Wallet::Object::Duo::PAM');
+ use_ok('Wallet::Object::Duo');
}
use lib 't/lib';
@@ -53,14 +53,14 @@ my $mock = Net::Duo::Mock::Agent->new ({ key_file => 't/data/duo/keys.json' });
# Test error handling in the absence of configuration.
my $object = eval {
- Wallet::Object::Duo::PAM->new ('duo-pam', 'test', $schema);
+ Wallet::Object::Duo->new ('duo-pam', 'test', $schema);
};
-is ($object, undef, 'Wallet::Object::Duo::PAM new with no config failed');
+is ($object, undef, 'Wallet::Object::Duo new with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
$object = eval {
- Wallet::Object::Duo::PAM->create ('duo-pam', 'test', $schema, @trace);
+ Wallet::Object::Duo->create ('duo-pam', 'test', $schema, @trace);
};
-is ($object, undef, 'Wallet::Object::Duo::PAM creation with no config failed');
+is ($object, undef, 'Wallet::Object::Duo creation with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
# Set up the Duo configuration.
@@ -82,9 +82,8 @@ $mock->expect (
response_file => 't/data/duo/integration.json',
}
);
-$object = Wallet::Object::Duo::PAM->create ('duo-pam', 'test', $schema,
- @trace);
-isa_ok ($object, 'Wallet::Object::Duo::PAM');
+$object = Wallet::Object::Duo->create ('duo-pam', 'test', $schema, @trace);
+isa_ok ($object, 'Wallet::Object::Duo');
# Check the metadata about the new wallet object.
$expected = <<"EOO";
@@ -126,7 +125,7 @@ is ($object->flag_clear ('locked', @trace), 1,
'...and clearing locked flag works');
# Create a new object by wallet type and name.
-$object = Wallet::Object::Duo::PAM->new ('duo-pam', 'test', $schema);
+$object = Wallet::Object::Duo->new ('duo-pam', 'test', $schema);
# Test deleting an integration. We can't test this entirely properly because
# currently Net::Duo::Mock::Agent doesn't support stacking multiple expected
@@ -143,8 +142,7 @@ TODO: {
local $TODO = 'Net::Duo::Mock::Agent not yet capable';
is ($object->destroy (@trace), 1, 'Duo object deletion succeeded');
- $object = eval { Wallet::Object::Duo::PAM->new ('duo-pam', 'test',
- $schema) };
+ $object = eval { Wallet::Object::Duo->new ('duo-pam', 'test', $schema) };
is ($object, undef, '...and now object cannot be retrieved');
is ($@, "cannot find duo:test\n", '...with correct error');
}
diff --git a/perl/t/object/duo-radius.t b/perl/t/object/duo-radius.t
index f258518..55cbb9d 100644
--- a/perl/t/object/duo-radius.t
+++ b/perl/t/object/duo-radius.t
@@ -26,7 +26,7 @@ BEGIN {
BEGIN {
use_ok('Wallet::Admin');
use_ok('Wallet::Config');
- use_ok('Wallet::Object::Duo::RadiusProxy');
+ use_ok('Wallet::Object::Duo');
}
use lib 't/lib';
@@ -53,17 +53,16 @@ my $mock = Net::Duo::Mock::Agent->new ({ key_file => 't/data/duo/keys.json' });
# Test error handling in the absence of configuration.
my $object = eval {
- Wallet::Object::Duo::RadiusProxy->new ('duo-raduys', 'test', $schema);
+ Wallet::Object::Duo->new ('duo-radius', 'test', $schema);
};
is ($object, undef,
- 'Wallet::Object::Duo::RadiusProxy new with no config failed');
+ 'Wallet::Object::Duo new with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
$object = eval {
- Wallet::Object::Duo::RadiusProxy->create ('duo-radius', 'test', $schema,
- @trace);
+ Wallet::Object::Duo->create ('duo-radius', 'test', $schema, @trace);
};
is ($object, undef,
- 'Wallet::Object::Duo::RadiusProxy creation with no config failed');
+ 'Wallet::Object::Duo creation with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
# Set up the Duo configuration.
@@ -85,9 +84,8 @@ $mock->expect (
response_file => 't/data/duo/integration-radius.json',
}
);
-$object = Wallet::Object::Duo::RadiusProxy->create ('duo-radius', 'test',
- $schema, @trace);
-isa_ok ($object, 'Wallet::Object::Duo::RadiusProxy');
+$object = Wallet::Object::Duo->create ('duo-radius', 'test', $schema, @trace);
+isa_ok ($object, 'Wallet::Object::Duo');
# Check the metadata about the new wallet object.
$expected = <<"EOO";
@@ -130,8 +128,7 @@ is ($object->flag_clear ('locked', @trace), 1,
'...and clearing locked flag works');
# Create a new object by wallet type and name.
-$object = Wallet::Object::Duo::RadiusProxy->new ('duo-radius', 'test',
- $schema);
+$object = Wallet::Object::Duo->new ('duo-radius', 'test', $schema);
# Test deleting an integration. We can't test this entirely properly because
# currently Net::Duo::Mock::Agent doesn't support stacking multiple expected
@@ -149,7 +146,7 @@ TODO: {
is ($object->destroy (@trace), 1, 'Duo object deletion succeeded');
$object = eval {
- Wallet::Object::Duo::RadiusProxy->new ('duo-radius', 'test', $schema);
+ Wallet::Object::Duo->new ('duo-radius', 'test', $schema);
};
is ($object, undef, '...and now object cannot be retrieved');
is ($@, "cannot find duo:test\n", '...with correct error');
diff --git a/perl/t/object/duo-rdp.t b/perl/t/object/duo-rdp.t
index 9b2d566..25060ac 100644
--- a/perl/t/object/duo-rdp.t
+++ b/perl/t/object/duo-rdp.t
@@ -26,7 +26,7 @@ BEGIN {
BEGIN {
use_ok('Wallet::Admin');
use_ok('Wallet::Config');
- use_ok('Wallet::Object::Duo::RDP');
+ use_ok('Wallet::Object::Duo');
}
use lib 't/lib';
@@ -53,14 +53,14 @@ my $mock = Net::Duo::Mock::Agent->new ({ key_file => 't/data/duo/keys.json' });
# Test error handling in the absence of configuration.
my $object = eval {
- Wallet::Object::Duo::RDP->new ('duo-rdp', 'test', $schema);
+ Wallet::Object::Duo->new ('duo-rdp', 'test', $schema);
};
-is ($object, undef, 'Wallet::Object::Duo::RDP new with no config failed');
+is ($object, undef, 'Wallet::Object::Duo new with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
$object = eval {
- Wallet::Object::Duo::RDP->create ('duo-rdp', 'test', $schema, @trace);
+ Wallet::Object::Duo->create ('duo-rdp', 'test', $schema, @trace);
};
-is ($object, undef, 'Wallet::Object::Duo::RDP creation with no config failed');
+is ($object, undef, 'Wallet::Object::Duo creation with no config failed');
is ($@, "duo object implementation not configured\n", '...with correct error');
# Set up the Duo configuration.
@@ -82,9 +82,8 @@ $mock->expect (
response_file => 't/data/duo/integration-rdp.json',
}
);
-$object = Wallet::Object::Duo::RDP->create ('duo-rdp', 'test', $schema,
- @trace);
-isa_ok ($object, 'Wallet::Object::Duo::RDP');
+$object = Wallet::Object::Duo->create ('duo-rdp', 'test', $schema, @trace);
+isa_ok ($object, 'Wallet::Object::Duo');
# Check the metadata about the new wallet object.
$expected = <<"EOO";
@@ -125,7 +124,7 @@ is ($object->flag_clear ('locked', @trace), 1,
'...and clearing locked flag works');
# Create a new object by wallet type and name.
-$object = Wallet::Object::Duo::RDP->new ('duo-rdp', 'test', $schema);
+$object = Wallet::Object::Duo->new ('duo-rdp', 'test', $schema);
# Test deleting an integration. We can't test this entirely properly because
# currently Net::Duo::Mock::Agent doesn't support stacking multiple expected
@@ -142,8 +141,7 @@ TODO: {
local $TODO = 'Net::Duo::Mock::Agent not yet capable';
is ($object->destroy (@trace), 1, 'Duo object deletion succeeded');
- $object = eval { Wallet::Object::Duo::RDP->new ('duo-rdp', 'test',
- $schema) };
+ $object = eval { Wallet::Object::Duo->new ('duo-rdp', 'test', $schema) };
is ($object, undef, '...and now object cannot be retrieved');
is ($@, "cannot find duo:test\n", '...with correct error');
}
diff --git a/perl/t/object/password.t b/perl/t/object/password.t
new file mode 100644
index 0000000..4fe6b50
--- /dev/null
+++ b/perl/t/object/password.t
@@ -0,0 +1,124 @@
+#!/usr/bin/perl
+#
+# Tests for the password object implementation. Only includes tests that are
+# basic or different from the file object implementation.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2015
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+use strict;
+use warnings;
+
+use POSIX qw(strftime);
+use Test::More tests => 33;
+
+use Wallet::Admin;
+use Wallet::Config;
+use Wallet::Object::Password;
+
+use lib 't/lib';
+use Util;
+
+# Some global defaults to use.
+my $user = 'admin@EXAMPLE.COM';
+my $host = 'localhost';
+my @trace = ($user, $host, time);
+
+# Flush all output immediately.
+$| = 1;
+
+# Use Wallet::Admin to set up the database.
+system ('rm -rf test-files') == 0 or die "cannot remove test-files\n";
+db_setup;
+my $admin = eval { Wallet::Admin->new };
+is ($@, '', 'Database connection succeeded');
+is ($admin->reinitialize ($user), 1, 'Database initialization succeeded');
+my $schema = $admin->schema;
+
+# Use this to accumulate the history traces so that we can check history.
+my $history = '';
+my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]);
+
+$Wallet::Config::PWD_FILE_BUCKET = undef;
+
+# Test error handling in the absence of configuration.
+my $object = eval {
+ Wallet::Object::Password->create ('password', 'test', $schema, @trace)
+ };
+ok (defined ($object), 'Creating a basic password object succeeds');
+ok ($object->isa ('Wallet::Object::Password'), ' and is the right class');
+is ($object->get (@trace), undef, ' and get fails');
+is ($object->error, 'password support not configured',
+ ' with the right error');
+is ($object->store (@trace), undef, ' and store fails');
+is ($object->error, 'password support not configured',
+ ' with the right error');
+is ($object->destroy (@trace), 1, ' but destroy succeeds');
+
+# Set up our configuration.
+mkdir 'test-files' or die "cannot create test-files: $!\n";
+$Wallet::Config::PWD_FILE_BUCKET = 'test-files';
+$Wallet::Config::PWD_LENGTH_MIN = 10;
+$Wallet::Config::PWD_LENGTH_MAX = 10;
+
+# Okay, now we can test. First, the basic object without store.
+$object = eval {
+ Wallet::Object::Password->create ('password', 'test', $schema, @trace)
+ };
+ok (defined ($object), 'Creating a basic password object succeeds');
+ok ($object->isa ('Wallet::Object::Password'), ' and is the right class');
+my $pwd = $object->get (@trace);
+like ($pwd, qr{^.{$Wallet::Config::PWD_LENGTH_MIN}$},
+ ' and get creates a random password string of the right length');
+ok (-d 'test-files/09', ' and the hash bucket was created');
+ok (-f 'test-files/09/test', ' and the file exists');
+is (contents ('test-files/09/test'), $pwd, ' with the right contents');
+my $pwd2 = $object->get (@trace);
+is ($pwd, $pwd2, ' and getting again gives the same string');
+is ($object->destroy (@trace), 1, ' and destroying the object succeeds');
+
+# Now check to see if the password length is adjusted.
+$Wallet::Config::PWD_LENGTH_MIN = 20;
+$Wallet::Config::PWD_LENGTH_MAX = 20;
+$object = eval {
+ Wallet::Object::Password->create ('password', 'test', $schema, @trace)
+ };
+ok (defined ($object), 'Recreating the object succeeds');
+$pwd = $object->get (@trace);
+like ($pwd, qr{^.{$Wallet::Config::PWD_LENGTH_MIN}$},
+ ' and get creates a random password string of a longer length');
+is ($object->destroy (@trace), 1, ' and destroying the object succeeds');
+
+# Now store something and be sure that we get something reasonable.
+$object = eval {
+ Wallet::Object::Password->create ('password', 'test', $schema, @trace)
+ };
+ok (defined ($object), 'Recreating the object succeeds');
+is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds');
+ok (-f 'test-files/09/test', ' and the file exists');
+is (contents ('test-files/09/test'), 'foo', ' with the right contents');
+is ($object->get (@trace), "foo\n", ' and get returns correctly');
+unlink 'test-files/09/test';
+is ($object->get (@trace), undef,
+ ' and get will not autocreate a password if there used to be data');
+is ($object->error, 'cannot get password:test: object has not been stored',
+ ' as if it had not been stored');
+is ($object->store ("bar\n\0baz\n", @trace), 1, ' but storing again works');
+ok (-f 'test-files/09/test', ' and the file exists');
+is (contents ('test-files/09/test'), 'bar', ' with the right contents');
+is ($object->get (@trace), "bar\n\0baz\n", ' and get returns correctly');
+
+# And check to make sure update changes the contents.
+$pwd = $object->update (@trace);
+isnt ($pwd, "bar\n\0baz\n", 'Update changes the contents');
+like ($pwd, qr{^.{$Wallet::Config::PWD_LENGTH_MIN}$},
+ ' to a random password string of the right length');
+
+# Clean up.
+$admin->destroy;
+END {
+ unlink ('wallet-db');
+}
diff --git a/perl/t/policy/stanford.t b/perl/t/policy/stanford.t
index 555086c..d2727c8 100755
--- a/perl/t/policy/stanford.t
+++ b/perl/t/policy/stanford.t
@@ -16,7 +16,7 @@ use 5.008;
use strict;
use warnings;
-use Test::More tests => 101;
+use Test::More tests => 130;
use lib 't/lib';
use Util;
@@ -24,10 +24,16 @@ use Util;
# Load the naming policy module.
BEGIN {
use_ok('Wallet::Admin');
- use_ok('Wallet::Policy::Stanford', qw(default_owner verify_name));
+ use_ok('Wallet::Policy::Stanford',
+ qw(default_owner verify_name is_for_host));
use_ok('Wallet::Server');
}
+# Set up our configuration for netdb, needed for the netdb verifier.
+$Wallet::Config::NETDB_REALM = 'stanford.edu';
+$Wallet::Config::NETDB_REMCTL_CACHE = $ENV{KRB5CCNAME};
+$Wallet::Config::NETDB_REMCTL_HOST = 'netdb-node-roles-rc.stanford.edu';
+
# Various valid keytab names.
my @VALID_KEYTABS = qw(host/example.stanford.edu HTTP/example.stanford.edu
service/example example/cgi class-example01/cgi dept-01example/cgi
@@ -101,160 +107,209 @@ for my $name (@INVALID_FILES) {
isnt(verify_name('file', $name), undef, "Invalid file $name");
}
-# Now we need an actual database. Use Wallet::Admin to set it up.
-db_setup;
-my $setup = eval { Wallet::Admin->new };
-is($@, q{}, 'Database initialization did not die');
-is($setup->reinitialize($ADMIN), 1, 'Database initialization succeeded');
-my $server = eval { Wallet::Server->new(@TRACE) };
-is($@, q{}, 'Server creation did not die');
+# Now test a few cases for checking to see if a file is host-based. We don't
+# test the legacy examples because they're more complicated and less obvious.
+for my $name (@VALID_KEYTABS) {
+ my $hostname = 'example.stanford.edu';
+ if ($name =~ m{\b$hostname\b}) {
+ is(is_for_host('keytab', $name, $hostname), 1,
+ "Keytab $name belongs to $hostname");
+ } else {
+ is(is_for_host('keytab', $name, $hostname), 0,
+ "Keytab $name doesn't belong to $hostname");
+ }
+}
+for my $name (@VALID_FILES) {
+ my $hostname = 'example.stanford.edu';
+ if ($name =~ m{\b$hostname\b}) {
+ is(is_for_host('file', $name, $hostname), 1,
+ "File $name belongs to $hostname");
+ } else {
+ is(is_for_host('file', $name, $hostname), 0,
+ "File $name doesn't belong to $hostname");
+ }
+}
-# Create a host/example.stanford.edu ACL that uses the netdb ACL type.
-is($server->acl_create('host/example.stanford.edu'), 1, 'Created netdb ACL');
-is(
- $server->acl_add('host/example.stanford.edu', 'netdb',
- 'example.stanford.edu'),
- 1,
- '...with netdb ACL line'
-);
-is(
- $server->acl_add('host/example.stanford.edu', 'krb5',
- 'host/example.stanford.edu@stanford.edu'),
- 1,
- '...and krb5 ACL line'
-);
+# Now we need an actual database. Use Wallet::Admin to set it up. These
+# remaining tests require creating NetDB ACLs, so need a Stanford Kerberos
+# principal currently.
+my $klist = `klist 2>&1` || '';
+SKIP: {
+ skip "tests useful only with Stanford Kerberos tickets", 27
+ unless ($klist =~ /^(Default p|\s+P)rincipal: \S+\@stanford\.edu$/m);
-# Likewise for host/foo.example.edu with the netdb-root ACL type.
-is($server->acl_create('host/foo.stanford.edu'), 1, 'Created netdb-root ACL');
-is(
- $server->acl_add('host/foo.stanford.edu', 'netdb-root',
- 'foo.stanford.edu'),
- 1,
- '...with netdb-root ACL line'
-);
-is(
- $server->acl_add('host/foo.stanford.edu', 'krb5',
- 'host/foo.stanford.edu@stanford.edu'),
- 1,
- '...and krb5 ACL line'
-);
+ db_setup;
+ my $setup = eval { Wallet::Admin->new };
+ is($@, q{}, 'Database initialization did not die');
+ is($setup->reinitialize($ADMIN), 1, 'Database initialization succeeded');
+ my $server = eval { Wallet::Server->new(@TRACE) };
+ is($@, q{}, 'Server creation did not die');
-# Create a group/its-idg ACL, which will be used for autocreation of file
-# objects.
-is($server->acl_create('group/its-idg'), 1, 'Created group/its-idg ACL');
-is($server->acl_add('group/its-idg', 'krb5', $ADMIN), 1, '...with member');
+ # Create a host/example.stanford.edu ACL that uses the netdb ACL type.
+ is(
+ $server->acl_create('host/example.stanford.edu'),
+ 1,
+ 'Created netdb ACL'
+ );
+ is($server->error, undef, ' with no error');
+ is(
+ $server->acl_add('host/example.stanford.edu', 'netdb',
+ 'example.stanford.edu'),
+ 1,
+ '...with netdb ACL line'
+ );
+ is($server->error, undef, ' with no error');
+ is(
+ $server->acl_add('host/example.stanford.edu', 'krb5',
+ 'host/example.stanford.edu@stanford.edu'),
+ 1,
+ '...and krb5 ACL line'
+ );
+ is($server->error, undef, ' with no error');
-# Now we can test default ACLs. First, without a root instance.
-local $ENV{REMOTE_USER} = $ADMIN;
-is_deeply(
- [default_owner('keytab', 'host/bar.stanford.edu')],
- [
- 'host/bar.stanford.edu',
- ['netdb', 'bar.stanford.edu'],
- ['krb5', 'host/bar.stanford.edu@stanford.edu']
- ],
- 'Correct default owner for host-based keytab'
-);
-is_deeply(
- [default_owner('keytab', 'HTTP/example.stanford.edu')],
- [
- 'host/example.stanford.edu',
- ['netdb', 'example.stanford.edu'],
- ['krb5', 'host/example.stanford.edu@stanford.edu']
- ],
- '...and when netdb ACL already exists'
-);
-is_deeply(
- [default_owner('keytab', 'webauth/foo.stanford.edu')],
- [
- 'host/foo.stanford.edu',
- ['netdb-root', 'foo.stanford.edu'],
- ['krb5', 'host/foo.stanford.edu@stanford.edu']
- ],
- '...and when netdb-root ACL already exists'
-);
+ # Likewise for host/foo.example.edu with the netdb-root ACL type.
+ is(
+ $server->acl_create('host/foo.stanford.edu'),
+ 1,
+ 'Created netdb-root ACL'
+ );
+ is(
+ $server->acl_add('host/foo.stanford.edu', 'netdb-root',
+ 'foo.stanford.edu'),
+ 1,
+ '...with netdb-root ACL line'
+ );
+ is(
+ $server->acl_add('host/foo.stanford.edu', 'krb5',
+ 'host/foo.stanford.edu@stanford.edu'),
+ 1,
+ '...and krb5 ACL line'
+ );
-# Now with a root instance.
-local $ENV{REMOTE_USER} = 'admin/root@stanford.edu';
-is_deeply(
- [default_owner('keytab', 'host/bar.stanford.edu')],
- [
- 'host/bar.stanford.edu',
- ['netdb-root', 'bar.stanford.edu'],
- ['krb5', 'host/bar.stanford.edu@stanford.edu']
- ],
- 'Correct default owner for host-based keytab for /root'
-);
-is_deeply(
- [default_owner('keytab', 'HTTP/example.stanford.edu')],
- [
- 'host/example.stanford.edu',
- ['netdb-root', 'example.stanford.edu'],
- ['krb5', 'host/example.stanford.edu@stanford.edu']
- ],
- '...and when netdb ACL already exists'
-);
-is_deeply(
- [default_owner('keytab', 'webauth/foo.stanford.edu')],
- [
- 'host/foo.stanford.edu',
- ['netdb-root', 'foo.stanford.edu'],
- ['krb5', 'host/foo.stanford.edu@stanford.edu']
- ],
- '...and when netdb-root ACL already exists'
-);
+ # Create a group/its-idg ACL, which will be used for autocreation of file
+ # objects.
+ is($server->acl_create('group/its-idg'), 1, 'Created group/its-idg ACL');
+ is($server->acl_add('group/its-idg', 'krb5', $ADMIN), 1, '...with member');
-# Check for a type that isn't host-based.
-is(default_owner('keytab', 'service/foo'), undef,
- 'No default owner for service/foo');
+ # Now we can test default ACLs. First, without a root instance.
+ local $ENV{REMOTE_USER} = $ADMIN;
+ is_deeply(
+ [default_owner('keytab', 'host/bar.stanford.edu')],
+ [
+ 'host/bar.stanford.edu',
+ ['netdb', 'bar.stanford.edu'],
+ ['krb5', 'host/bar.stanford.edu@stanford.edu']
+ ],
+ 'Correct default owner for host-based keytab'
+ );
+ is_deeply(
+ [default_owner('keytab', 'HTTP/example.stanford.edu')],
+ [
+ 'host/example.stanford.edu',
+ ['netdb', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb ACL already exists'
+ );
+ is_deeply(
+ [default_owner('keytab', 'webauth/foo.stanford.edu')],
+ [
+ 'host/foo.stanford.edu',
+ ['netdb-root', 'foo.stanford.edu'],
+ ['krb5', 'host/foo.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb-root ACL already exists'
+ );
-# Check for an unknown object type.
-is(default_owner('unknown', 'foo'), undef,
- 'No default owner for unknown type');
+ # Now with a root instance.
+ local $ENV{REMOTE_USER} = 'admin/root@stanford.edu';
+ is_deeply(
+ [default_owner('keytab', 'host/bar.stanford.edu')],
+ [
+ 'host/bar.stanford.edu',
+ ['netdb-root', 'bar.stanford.edu'],
+ ['krb5', 'host/bar.stanford.edu@stanford.edu']
+ ],
+ 'Correct default owner for host-based keytab for /root'
+ );
+ is_deeply(
+ [default_owner('keytab', 'HTTP/example.stanford.edu')],
+ [
+ 'host/example.stanford.edu',
+ ['netdb-root', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb ACL already exists'
+ );
+ is_deeply(
+ [default_owner('keytab', 'webauth/foo.stanford.edu')],
+ [
+ 'host/foo.stanford.edu',
+ ['netdb-root', 'foo.stanford.edu'],
+ ['krb5', 'host/foo.stanford.edu@stanford.edu']
+ ],
+ '...and when netdb-root ACL already exists'
+ );
-# Check for autocreation mappings for host-based file objects.
-is_deeply(
- [default_owner('file', 'ssl-key/example.stanford.edu')],
- [
- 'host/example.stanford.edu',
- ['netdb-root', 'example.stanford.edu'],
- ['krb5', 'host/example.stanford.edu@stanford.edu']
- ],
- 'Default owner for file ssl-key/example.stanford.edu',
-);
-is_deeply(
- [default_owner('file', 'ssl-key/example.stanford.edu/mysql')],
- [
- 'host/example.stanford.edu',
- ['netdb-root', 'example.stanford.edu'],
- ['krb5', 'host/example.stanford.edu@stanford.edu']
- ],
- 'Default owner for file ssl-key/example.stanford.edu/mysql',
-);
+ # Check for a type that isn't host-based.
+ is(
+ default_owner('keytab', 'service/foo'),
+ undef,
+ 'No default owner for service/foo'
+ );
-# Check for a file object that isn't host-based.
-is_deeply(
- [default_owner('file', 'config/its-idg/example/foo')],
- ['group/its-idg', ['krb5', $ADMIN]],
- 'Default owner for file config/its-idg/example/foo',
-);
+ # Check for an unknown object type.
+ is(
+ default_owner('unknown', 'foo'),
+ undef,
+ 'No default owner for unknown type'
+ );
-# Check for legacy autocreation mappings for file objects.
-for my $type (qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key)) {
- my $name = "idg-example-$type";
+ # Check for autocreation mappings for host-based file objects.
is_deeply(
- [default_owner('file', $name)],
+ [default_owner('file', 'ssl-key/example.stanford.edu')],
[
'host/example.stanford.edu',
['netdb-root', 'example.stanford.edu'],
['krb5', 'host/example.stanford.edu@stanford.edu']
],
- "Default owner for file $name",
+ 'Default owner for file ssl-key/example.stanford.edu',
);
+ is_deeply(
+ [default_owner('file', 'ssl-key/example.stanford.edu/mysql')],
+ [
+ 'host/example.stanford.edu',
+ ['netdb-root', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ 'Default owner for file ssl-key/example.stanford.edu/mysql',
+ );
+
+ # Check for a file object that isn't host-based.
+ is_deeply(
+ [default_owner('file', 'config/its-idg/example/foo')],
+ ['group/its-idg', ['krb5', $ADMIN]],
+ 'Default owner for file config/its-idg/example/foo',
+ );
+
+ # Check for legacy autocreation mappings for file objects.
+ for my $type (qw(htpasswd ssh-rsa ssh-dsa ssl-key tivoli-key)) {
+ my $name = "idg-example-$type";
+ is_deeply(
+ [default_owner('file', $name)],
+ [
+ 'host/example.stanford.edu',
+ ['netdb-root', 'example.stanford.edu'],
+ ['krb5', 'host/example.stanford.edu@stanford.edu']
+ ],
+ "Default owner for file $name",
+ );
+ }
+
+ # Clean up.
+ $setup->destroy;
}
-# Clean up.
-$setup->destroy;
END {
unlink 'wallet-db';
}
diff --git a/perl/t/verifier/ldap-attr.t b/perl/t/verifier/ldap-attr.t
index 3c132e2..cff3b63 100755
--- a/perl/t/verifier/ldap-attr.t
+++ b/perl/t/verifier/ldap-attr.t
@@ -24,16 +24,18 @@ plan skip_all => 'LDAP verifier tests only run for maintainer'
unless $ENV{RRA_MAINTAINER_TESTS};
# Declare a plan.
-plan tests => 10;
+plan tests => 22;
require_ok ('Wallet::ACL::LDAP::Attribute');
+require_ok ('Wallet::ACL::LDAP::Attribute::Root');
-my $host = 'ldap.stanford.edu';
-my $base = 'cn=people,dc=stanford,dc=edu';
-my $filter = 'uid';
-my $user = 'rra@stanford.edu';
-my $attr = 'suPrivilegeGroup';
-my $value = 'stanford:stanford';
+my $host = 'ldap.stanford.edu';
+my $base = 'cn=people,dc=stanford,dc=edu';
+my $filter = 'uid';
+my $user = 'jonrober@stanford.edu';
+my $rootuser = 'jonrober/root@stanford.edu';
+my $attr = 'suPrivilegeGroup';
+my $value = 'stanford:stanford';
# Remove the realm from principal names.
package Wallet::Config;
@@ -68,7 +70,28 @@ SKIP: {
is ($verifier->check ($user, "BOGUS=$value"), undef,
"Checking BOGUS=$value fails with error");
is ($verifier->error,
- 'cannot check LDAP attribute BOGUS for rra: Undefined attribute type',
+ 'cannot check LDAP attribute BOGUS for jonrober: Undefined attribute type',
+ '...with correct error');
+ is ($verifier->check ('user-does-not-exist', "$attr=$value"), 0,
+ "Checking for nonexistent user fails");
+ is ($verifier->error, undef, '...with no error');
+
+ # Then also test the root version.
+ $verifier = eval { Wallet::ACL::LDAP::Attribute::Root->new };
+ isa_ok ($verifier, 'Wallet::ACL::LDAP::Attribute::Root');
+ is ($verifier->check ($user, "$attr=$value"), 0,
+ "Checking as a non /root user fails");
+ is ($verifier->error, undef, '...with no error');
+ is ($verifier->check ($rootuser, "$attr=$value"), 1,
+ "Checking $attr=$value succeeds");
+ is ($verifier->error, undef, '...with no error');
+ is ($verifier->check ($rootuser, "$attr=BOGUS"), 0,
+ "Checking $attr=BOGUS fails");
+ is ($verifier->error, undef, '...with no error');
+ is ($verifier->check ($rootuser, "BOGUS=$value"), undef,
+ "Checking BOGUS=$value fails with error");
+ is ($verifier->error,
+ 'cannot check LDAP attribute BOGUS for jonrober: Undefined attribute type',
'...with correct error');
is ($verifier->check ('user-does-not-exist', "$attr=$value"), 0,
"Checking for nonexistent user fails");
diff --git a/perl/t/verifier/nested.t b/perl/t/verifier/nested.t
new file mode 100755
index 0000000..ec7ce40
--- /dev/null
+++ b/perl/t/verifier/nested.t
@@ -0,0 +1,84 @@
+#!/usr/bin/perl
+#
+# Tests for the wallet ACL nested verifier.
+#
+# Written by Jon Robertson <jonrober@stanford.edu>
+# Copyright 2015
+# The Board of Trustees of the Leland Stanford Junior University
+#
+# See LICENSE for licensing terms.
+
+use strict;
+use warnings;
+
+use Test::More tests => 22;
+
+use Wallet::ACL::Base;
+use Wallet::ACL::Nested;
+use Wallet::Admin;
+use Wallet::Config;
+
+use lib 't/lib';
+use Util;
+
+# Some global defaults to use.
+my $admin = 'admin@EXAMPLE.COM';
+my $user1 = 'alice@EXAMPLE.COM';
+my $user2 = 'bob@EXAMPLE.COM';
+my $user3 = 'jack@EXAMPLE.COM';
+my $host = 'localhost';
+my @trace = ($admin, $host, time);
+
+# Use Wallet::Admin to set up the database.
+db_setup;
+my $setup = eval { Wallet::Admin->new };
+is ($@, '', 'Database connection succeeded');
+is ($setup->reinitialize ($setup), 1, 'Database initialization succeeded');
+my $schema = $setup->schema;
+
+# Create a few ACLs for later testing.
+my $acl = eval { Wallet::ACL->create ('test', $schema, @trace) };
+ok (defined ($acl), 'ACL creation');
+my $acl_nesting = eval { Wallet::ACL->create ('nesting', $schema, @trace) };
+ok (defined ($acl), ' and another');
+my $acl_deep = eval { Wallet::ACL->create ('deepnesting', $schema, @trace) };
+ok (defined ($acl), ' and another');
+
+# Create an verifier to make sure that works
+my $verifier = Wallet::ACL::Nested->new ('test', $schema);
+ok (defined $verifier, 'Wallet::ACL::Nested creation');
+ok ($verifier->isa ('Wallet::ACL::Nested'), ' and class verification');
+is ($verifier->syntax_check ('notcreated'), 0,
+ ' and it rejects a nested name that is not already an ACL');
+is ($verifier->syntax_check ('test'), 1,
+ ' and accepts one that already exists');
+
+# Add a few entries to one ACL and then see if they validate.
+ok ($acl->add ('krb5', $user1, @trace), 'Added test scheme');
+ok ($acl->add ('krb5', $user2, @trace), ' and another');
+ok ($acl_nesting->add ('nested', 'test', @trace), ' and then nested it');
+ok ($acl_nesting->add ('krb5', $user3, @trace),
+ ' and added a non-nesting user');
+is ($acl_nesting->check ($user1), 1, ' so check of nested succeeds');
+is ($acl_nesting->check ($user3), 1, ' so check of non-nested succeeds');
+is (scalar ($acl_nesting->list), 2,
+ ' and the acl has the right number of items');
+
+# Add a recursive nesting to make sure it doesn't send us into loop.
+ok ($acl_deep->add ('nested', 'test', @trace),
+ 'Adding deep nesting for one nest succeeds');
+ok ($acl_deep->add ('nested', 'nesting', @trace), ' and another');
+ok ($acl_deep->add ('krb5', $user3, @trace),
+ ' and added a non-nesting user');
+is ($acl_deep->check ($user1), 1, ' so check of nested succeeds');
+is ($acl_deep->check ($user3), 1, ' so check of non-nested succeeds');
+
+# Test getting an error in adding an invalid group to an ACL object itself.
+isnt ($acl->add ('nested', 'doesnotexist', @trace), 1,
+ 'Adding bad nested acl fails');
+
+# Clean up.
+$setup->destroy;
+END {
+ unlink 'wallet-db';
+}
diff --git a/server/wallet-backend b/server/wallet-backend
index 8dfc952..ea3e21e 100755
--- a/server/wallet-backend
+++ b/server/wallet-backend
@@ -173,6 +173,9 @@ sub command {
} elsif ($action eq 'rename') {
check_args (2, 2, [], @args);
$server->acl_rename (@args) or failure ($server->error, @_);
+ } elsif ($action eq 'replace') {
+ check_args (2, 2, [], @args);
+ $server->acl_replace (@args) or failure ($server->error, @_);
} elsif ($action eq 'show') {
check_args (1, 1, [], @args);
my $output = $server->acl_show (@args);
@@ -312,6 +315,14 @@ sub command {
}
splice (@_, 3);
$server->store (@args) or failure ($server->error, @_);
+ } elsif ($command eq 'update') {
+ check_args (2, 2, [], @args);
+ my $output = $server->update (@args);
+ if (defined $output) {
+ print $output;
+ } else {
+ failure ($server->error, @_);
+ }
} else {
error "unknown command $command";
}
@@ -449,6 +460,25 @@ accidental lockout, but administrators can remove themselves from the
C<ADMIN> ACL and can leave only a non-functioning entry on the ACL. Use
caution when removing entries from the C<ADMIN> ACL.
+=item acl rename <id> <name>
+
+Renames the ACL identified by <id> to <name>. This changes the
+human-readable name, not the underlying numeric ID, so the ACL's
+associations with objects will be unchanged. The C<ADMIN> ACL may not be
+renamed. <id> may be either the current name or the numeric ID. <name>
+must not be all-numeric. To rename an ACL, the current user must be
+authorized by the C<ADMIN> ACL.
+
+=item acl replace <id> <new-id>
+
+Find any objects owned by <id>, and then change their ownership to
+<new_id> instead. <new-id> should already exist, and may already have
+some objects owned by it. <id> is not deleted afterwards, though in
+most cases that is probably your next step. The C<ADMIN> ACL may not be
+replaced from. <id> and <new-id> may be either the current name or the
+numeric ID. To replace an ACL, the current user must be authorized by
+the C<ADMIN> ACL.
+
=item acl show <id>
Display the name, numeric ID, and entries of the ACL <id>.
@@ -589,6 +619,14 @@ Stores <data> for the object identified by <type> and <name> for later
retrieval with C<get>. Not all object types support this. If <data> is
not given as an argument, it will be read from standard input.
+=item update <type> <name>
+
+Prints to standard output the data associated with the object identified
+by <type> and <name>. If the object is one that can have changing
+information, such as a keytab or password, then we generate new data for
+that object regardless of whether there is current data or the unchanging
+flag is set.
+
=back
=head1 ATTRIBUTES
diff --git a/server/wallet-report b/server/wallet-report
index b5a2247..4719a8a 100755
--- a/server/wallet-report
+++ b/server/wallet-report
@@ -17,16 +17,22 @@ Wallet reporting help:
acls duplicate ACLs that duplicate another
acls empty All empty ACLs
acls entry <scheme> <id> ACLs containing this entry (wildcarded)
+ acls nesting <acl> ACLs containing this ACL as a nested entry
acls unused ACLs that are not referenced by any object
audit acls name ACLs failing the naming policy
audit objects name Objects failing the naming policy
objects All objects
objects acl <acl> Objects granting permissions to that ACL
objects flag <flag> Objects with that flag set
+ objects history History of all objects
+ objects host <hostname> All host-based objects for a specific host
objects owner <owner> Objects owned by that owner
objects type <type> Objects of that type
- objects unused Objects that have never been stored/gotten
+ objects unused Objects that have never been gotten
+ objects unstored Objects that have never been stored
owners <type> <name> All ACL entries owning matching objects
+ schemes All configured ACL schemes
+ types All configured wallet types
EOH
##############################################################################
@@ -74,7 +80,14 @@ sub command {
print $HELP;
} elsif ($command eq 'objects') {
die "too many arguments to objects\n" if @args > 2;
- my @objects = $report->objects (@args);
+ my @objects;
+ if (@args && $args[0] eq 'history') {
+ @objects = $report->objects_history (@args);
+ } elsif (@args && $args[0] eq 'host') {
+ @objects = $report->objects_hostname (@args);
+ } else {
+ @objects = $report->objects (@args);
+ }
if (!@objects and $report->error) {
die $report->error, "\n";
}
@@ -91,6 +104,20 @@ sub command {
for my $entry (@entries) {
print join (' ', @$entry), "\n";
}
+ } elsif ($command eq 'schemes') {
+ die "too many arguments to schemes\n" if @args > 0;
+ my @schemes = $report->acl_schemes;
+ for my $entry (@schemes) {
+ print join (' ', @$entry), "\n";
+ }
+
+ } elsif ($command eq 'types') {
+ die "too many arguments to types\n" if @args > 0;
+ my @types = $report->types;
+ for my $entry (@types) {
+ print join (' ', @$entry), "\n";
+ }
+
} else {
die "unknown command $command\n";
}
@@ -220,6 +247,8 @@ Displays a summary of all available commands.
=item objects unused
+=item objects unstored
+
Returns a list of objects in the database. Objects will be listed in the
form: