From 76ccf098c6e9c8849c8ca459a54d7383baf39ddb Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Sun, 13 Apr 2014 16:36:36 -0700 Subject: Change my email address to eagle@eyrie.org Change-Id: I4c2b5d7c807d6c27dd18a3b92eef66d21287d21e Reviewed-on: https://gerrit.stanford.edu/1481 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index 2e1a986..2a9fbd3 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,6 +1,6 @@ # Automake makefile for wallet. # -# Written by Russ Allbery +# Written by Russ Allbery # Copyright 2006, 2007, 2008, 2010, 2013 # The Board of Trustees of the Leland Stanford Junior University # -- cgit v1.2.3 From 26927d5b7bda7d2892e460fdb2867b6bcd55c8ad Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 11 Jul 2014 17:19:59 -0700 Subject: Add new object type for Duo integrations A new object type, duo (Wallet::Object::Duo), is now supported. This creates an integration with the Duo Security cloud multifactor authentication service and allows retrieval of the integration key, secret key, and admin hostname. Currently, only UNIX integration types are supported. The Net::Duo Perl module is required to use this object type. New configuration settings are required as well; see Wallet::Config for more information. To enable this object type for an existing wallet database, use wallet-admin to register the new object. Change-Id: I2c0dac75e81f526b34d6b509c4bdaecb43dd4a9d Reviewed-on: https://gerrit.stanford.edu/1516 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 40 +-- NEWS | 10 + README | 32 ++- docs/objects-and-schemes | 14 +- perl/Wallet/Config.pm | 47 +++- perl/Wallet/Object/Duo.pm | 331 ++++++++++++++++++++++++ perl/Wallet/Schema.pm | 17 +- perl/Wallet/Schema/Result/Duo.pm | 53 ++++ perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql | 17 ++ perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql | 12 + perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql | 11 + perl/sql/Wallet-Schema-0.09-MySQL.sql | 204 +++++++++++++++ perl/sql/Wallet-Schema-0.09-PostgreSQL.sql | 208 +++++++++++++++ perl/sql/Wallet-Schema-0.09-SQLite.sql | 212 +++++++++++++++ perl/t/data/duo/integration.json | 11 + perl/t/data/duo/keys.json | 5 + perl/t/duo.t | 157 +++++++++++ tests/server/admin-t | 6 +- 18 files changed, 1348 insertions(+), 39 deletions(-) create mode 100644 perl/Wallet/Object/Duo.pm create mode 100644 perl/Wallet/Schema/Result/Duo.pm create mode 100644 perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql create mode 100644 perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql create mode 100644 perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql create mode 100644 perl/sql/Wallet-Schema-0.09-MySQL.sql create mode 100644 perl/sql/Wallet-Schema-0.09-PostgreSQL.sql create mode 100644 perl/sql/Wallet-Schema-0.09-SQLite.sql create mode 100644 perl/t/data/duo/integration.json create mode 100644 perl/t/data/duo/keys.json create mode 100755 perl/t/duo.t (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index 2a9fbd3..dba1f94 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,7 +1,7 @@ # Automake makefile for wallet. # # Written by Russ Allbery -# Copyright 2006, 2007, 2008, 2010, 2013 +# Copyright 2006, 2007, 2008, 2010, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -16,14 +16,15 @@ PERL_FILES = perl/Wallet/ACL.pm perl/Wallet/ACL/Base.pm \ perl/Wallet/ACL/NetDB/Root.pm perl/Wallet/Admin.pm \ perl/Wallet/Config.pm perl/Wallet/Database.pm perl/Wallet/Kadmin.pm \ perl/Wallet/Kadmin/Heimdal.pm perl/Wallet/Kadmin/MIT.pm \ - perl/Wallet/Object/Base.pm perl/Wallet/Object/File.pm \ - perl/Wallet/Object/Keytab.pm perl/Wallet/Object/WAKeyring.pm \ - perl/Wallet/Policy/Stanford.pm perl/Wallet/Report.pm \ - perl/Wallet/Schema.pm perl/Wallet/Server.pm \ + perl/Wallet/Object/Base.pm perl/Wallet/Object/Duo.pm \ + perl/Wallet/Object/File.pm perl/Wallet/Object/Keytab.pm \ + perl/Wallet/Object/WAKeyring.pm perl/Wallet/Policy/Stanford.pm \ + perl/Wallet/Report.pm perl/Wallet/Schema.pm perl/Wallet/Server.pm \ perl/Wallet/Schema/Result/Acl.pm \ perl/Wallet/Schema/Result/AclEntry.pm \ perl/Wallet/Schema/Result/AclHistory.pm \ perl/Wallet/Schema/Result/AclScheme.pm \ + perl/Wallet/Schema/Result/Duo.pm \ perl/Wallet/Schema/Result/Enctype.pm \ perl/Wallet/Schema/Result/Flag.pm \ perl/Wallet/Schema/Result/KeytabEnctype.pm \ @@ -31,19 +32,14 @@ PERL_FILES = perl/Wallet/ACL.pm perl/Wallet/ACL/Base.pm \ perl/Wallet/Schema/Result/Object.pm \ perl/Wallet/Schema/Result/ObjectHistory.pm \ perl/Wallet/Schema/Result/SyncTarget.pm \ - perl/Wallet/Schema/Result/Type.pm \ - perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql \ - perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql \ - perl/sql/Wallet-Schema-0.07-MySQL.sql \ - perl/sql/Wallet-Schema-0.07-SQLite.sql \ - perl/sql/Wallet-Schema-0.08-MySQL.sql \ - perl/sql/Wallet-Schema-0.08-PostgreSQL.sql \ - perl/sql/Wallet-Schema-0.08-SQLite.sql perl/t/acl.t perl/t/admin.t \ - perl/t/config.t perl/t/data/README perl/t/data/keytab-fake \ - perl/t/data/keytab.conf perl/t/data/netdb.conf \ - perl/t/data/netdb-fake perl/t/file.t perl/t/init.t perl/t/kadmin.t \ - perl/t/keytab.t perl/t/lib/Util.pm perl/t/object.t \ - perl/t/pod-spelling.t perl/t/pod.t perl/t/report.t perl/t/server.t \ + perl/Wallet/Schema/Result/Type.pm perl/sql perl/t/acl.t \ + perl/t/admin.t perl/t/config.t perl/t/data/README \ + perl/t/data/duo/integration.json perl/t/data/duo/keys.json \ + perl/t/data/keytab-fake perl/t/data/keytab.conf \ + perl/t/data/netdb.conf perl/t/data/netdb-fake perl/t/duo.t \ + perl/t/file.t perl/t/init.t perl/t/kadmin.t perl/t/keytab.t \ + perl/t/lib/Util.pm perl/t/object.t perl/t/pod-spelling.t \ + perl/t/pod.t perl/t/report.t perl/t/server.t \ perl/t/stanford-naming.t perl/t/verifier-ldap-attr.t \ perl/t/verifier-netdb.t perl/t/verifier.t perl/t/wa-keyring.t @@ -110,9 +106,15 @@ dist_pkgdata_DATA = perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql \ perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql \ perl/sql/Wallet-Schema-0.07-MySQL.sql \ perl/sql/Wallet-Schema-0.07-SQLite.sql \ + perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql \ + perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql \ perl/sql/Wallet-Schema-0.08-MySQL.sql \ perl/sql/Wallet-Schema-0.08-PostgreSQL.sql \ - perl/sql/Wallet-Schema-0.08-SQLite.sql + perl/sql/Wallet-Schema-0.08-SQLite.sql \ + perl/sql/Wallet-Schema-0.09-MySQL.sql \ + perl/sql/Wallet-Schema-0.09-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.09-SQLite.sql # A set of flags for warnings. Add -O because gcc won't find some warnings # without optimization turned on. Desirable warnings that can't be turned diff --git a/NEWS b/NEWS index c79b999..a7cab7e 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,16 @@ wallet 1.1 (unreleased) + A new object type, duo (Wallet::Object::Duo), is now supported. This + creates an integration with the Duo Security cloud multifactor + authentication service and allows retrieval of the integration key, + secret key, and admin hostname. Currently, only UNIX integration + types are supported. The Net::Duo Perl module is required to use this + object type. New configuration settings are required as well; see + Wallet::Config for more information. To enable this object type for + an existing wallet database, use wallet-admin to register the new + object. + Fix wallet-rekey on keytabs containing multiple principals. Previous versions assumed one could concatenate keytab files together to make a valid keytab file, which doesn't work with some Kerberos libraries. diff --git a/README b/README index 6781ff8..85a6299 100644 --- a/README +++ b/README @@ -3,10 +3,10 @@ Written by Russ Allbery - Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013 The Board of Trustees - of the Leland Stanford Junior University. This software is distributed - under a BSD-style license. Please see the section LICENSE below for - more information. + Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013, 2014 The Board of + Trustees of the Leland Stanford Junior University. This software is + distributed under a BSD-style license. Please see the section LICENSE + below for more information. BLURB @@ -43,15 +43,16 @@ DESCRIPTION regexes matching Kerberos principal names, and LDAP attribute checks. Currently, the object types supported are simple files, Kerberos - keytabs, and WebAuth keyrings. By default, whenever a Kerberos keytab - object is retrieved from the wallet, the key is changed in the Kerberos - KDC and the wallet returns a keytab for the new key. However, a keytab - object can also be configured to preserve the existing keys when - retrieved. Included in the wallet distribution is a script that can be - run via remctl on an MIT Kerberos KDC to extract the existing key for a - principal, and the wallet system will use that interface to retrieve the - current key if the unchanging flag is set on a Kerberos keytab object - for MIT Kerberos. (Heimdal doesn't require any special support.) + keytabs, WebAuth keyrings, and Duo integrations. By default, whenever a + Kerberos keytab object is retrieved from the wallet, the key is changed + in the Kerberos KDC and the wallet returns a keytab for the new key. + However, a keytab object can also be configured to preserve the existing + keys when retrieved. Included in the wallet distribution is a script + that can be run via remctl on an MIT Kerberos KDC to extract the + existing key for a principal, and the wallet system will use that + interface to retrieve the current key if the unchanging flag is set on a + Kerberos keytab object for MIT Kerberos. (Heimdal doesn't require any + special support.) REQUIREMENTS @@ -104,6 +105,9 @@ REQUIREMENTS The WebAuth keyring object support in the wallet server requires the WebAuth Perl module from WebAuth 4.4.0 or later. + The Duo integration object support in the wallet server requires the + Net::Duo Perl module. + To support the LDAP attribute ACL verifier, the Authen::SASL and Net::LDAP Perl modules must be installed on the server. This verifier only works with LDAP servers that support GSS-API binds. @@ -323,7 +327,7 @@ LICENSE The wallet distribution as a whole is covered by the following copyright statement and license: - Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013 + Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013, 2014 The Board of Trustees of the Leland Stanford Junior University Permission is hereby granted, free of charge, to any person obtaining diff --git a/docs/objects-and-schemes b/docs/objects-and-schemes index 57c2f9f..97e6289 100644 --- a/docs/objects-and-schemes +++ b/docs/objects-and-schemes @@ -10,6 +10,18 @@ Introduction Object Types + duo + + 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. + + Implemented via Wallet::Object::Duo. + file Stores an arbitrary file and allows retrieval of that file. The file @@ -91,7 +103,7 @@ ACL Schemes License - Copyright 2012, 2013 + Copyright 2012, 2013, 2014 The Board of Trustees of the Leland Stanford Junior University Copying and distribution of this file, with or without modification, diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index 0d9d506..ed3dded 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -1,7 +1,7 @@ # Wallet::Config -- Configuration handling for the wallet server. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2013 +# Copyright 2007, 2008, 2010, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -181,6 +181,51 @@ our $DB_PASSWORD; =back +=head1 DUO OBJECT CONFIGURATION + +These configuration variables only need to be set if you intend to use the +C object type (the Wallet::Object::Duo class). + +=over 4 + +=item DUO_AGENT + +If this configuration variable is set, its value should be an object that +is call-compatible with LWP::UserAgent. This object will be used instead +of LWP::UserAgent to make API calls to Duo. This is primarily useful for +testing, allowing replacement of the user agent with a mock implementation +so that a test can run without needing a Duo account. + +=cut + +our $DUO_AGENT; + +=item DUO_KEY_FILE + +The path to a file in JSON format that contains the key and hostname data +for the Duo Admin API integration used to manage integrations via wallet. +This file should be in the format expected by the C parameter +to the Net::Duo::Admin constructor. See L for more +information. + +DUO_KEY_FILE must be set to use Duo objects. + +=cut + +our $DUO_KEY_FILE; + +=item DUO_TYPE + +The type of integration to create. Currently, only one type of integration +can be created by one wallet configuration. This restriction may be relaxed +in the future. The default value is C to create UNIX integrations. + +=cut + +our $DUO_TYPE = 'unix'; + +=back + =head1 FILE OBJECT CONFIGURATION These configuration variables only need to be set if you intend to use the diff --git a/perl/Wallet/Object/Duo.pm b/perl/Wallet/Object/Duo.pm new file mode 100644 index 0000000..af2dfab --- /dev/null +++ b/perl/Wallet/Object/Duo.pm @@ -0,0 +1,331 @@ +# Wallet::Object::Duo -- Duo integration object implementation for the wallet. +# +# Written by Russ Allbery +# Copyright 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Object::Duo; +require 5.006; + +use strict; +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::Base; + +@ISA = qw(Wallet::Object::Base); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.01'; + +############################################################################## +# Core methods +############################################################################## + +# Override attr_show to display the Duo integration key attribute. +sub attr_show { + my ($self) = @_; + my $output = ''; + 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; + } + return sprintf ("%15s: %s\n", 'Duo key', $key); +} + +# Override new to start by creating a Net::Duo::Admin object for subsequent +# calls. +sub new { + my ($class, $type, $name, $schema) = @_; + + # We have to have a Duo integration key file set. + if (not $Wallet::Config::DUO_KEY_FILE) { + die "duo object implementation not configured\n"; + } + my $key_file = $Wallet::Config::DUO_KEY_FILE; + my $agent = $Wallet::Config::DUO_AGENT; + + # Construct the Net::Duo::Admin object. + require Net::Duo::Admin; + my $duo = Net::Duo::Admin->new ( + { + key_file => $key_file, + user_agent => $agent, + } + ); + + # Construct the object. + my $self = $class->SUPER::new ($type, $name, $schema); + $self->{duo} = $duo; + return $self; +} + +# Override create to start by creating a new integration in Duo, and only +# create the entry in the database if that succeeds. Error handling isn't +# 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) = @_; + + # We have to have a Duo integration key file set. + if (not $Wallet::Config::DUO_KEY_FILE) { + die "duo object implementation not configured\n"; + } + my $key_file = $Wallet::Config::DUO_KEY_FILE; + my $agent = $Wallet::Config::DUO_AGENT; + + # Construct the Net::Duo::Admin object. + require Net::Duo::Admin; + my $duo = Net::Duo::Admin->new ( + { + key_file => $key_file, + user_agent => $agent, + } + ); + + # Create the object in Duo. + require Net::Duo::Admin::Integration; + my %data = ( + name => $name, + notes => 'Managed by wallet', + type => $Wallet::Config::DUO_TYPE, + ); + my $integration = Net::Duo::Admin::Integration->create ($duo, \%data); + + # Create the object in wallet. + my @trace = ($creator, $host, $time); + my $self = $class->SUPER::create ($type, $name, $schema, @trace); + $self->{duo} = $duo; + + # Add the integration key to the object metadata. + my $guard = $self->{schema}->txn_scope_guard; + eval { + my %record = ( + du_name => $name, + du_key => $integration->integration_key, + ); + $self->{schema}->resultset ('Duo')->create (\%record); + $guard->commit; + }; + if ($@) { + my $id = $self->{type} . ':' . $self->{name}; + $self->error ("cannot set Duo key for $id: $@"); + return; + } + + # Done. Return the object. + return $self; +} + +# Override destroy to delete the integration out of Duo as well. +sub destroy { + my ($self, $user, $host, $time) = @_; + my $id = $self->{type} . ':' . $self->{name}; + if ($self->flag_check ('locked')) { + $self->error ("cannot destroy $id: object is locked"); + return; + } + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; + eval { + my %search = (du_name => $self->{name}); + my $row = $schema->resultset ('Duo')->find (\%search); + my $key = $row->get_column ('du_key'); + my $int = Net::Duo::Admin::Integration->new ($self->{duo}, $key); + $int->delete; + $row->delete; + $guard->commit; + }; + if ($@) { + $self->error ($@); + return; + } + return $self->SUPER::destroy ($user, $host, $time); +} + +# Our get implementation. Retrieve the integration information from Duo and +# construct the configuration file expected by the Duo 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); + 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 + +=head1 NAME + +Wallet::Object::Duo - Duo integration object implementation for wallet + +=head1 SYNOPSIS + + my @name = qw(duo host.example.com); + my @trace = ($user, $host, time); + my $object = Wallet::Object::Duo->create (@name, $schema, @trace); + my $config = $object->get (@trace); + $object->destroy (@trace); + +=head1 DESCRIPTION + +Wallet::Object::Duo is a representation of Duo integrations the wallet. +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. + +Currently, only one configured integration type can be managed by the +wallet, and 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 for details on supported configuration parameters and +information about how to set wallet configuration. + +=head1 METHODS + +This object mostly inherits from Wallet::Object::Base. 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 is a class method and should be called on the Wallet::Object::Duo +class. It creates a new object with the given TYPE and NAME (TYPE is +normally C 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. The new integration's type is controlled by the DUO_TYPE +configuration variable, which defaults to C. See L +for more information. + +If create() fails, it throws an exception. + +=item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) + +Destroys a Duo integration object by removing it from the database and +deleting the integration from Duo. If deleting the Duo integration fails, +destroy() fails. Returns true on success and false on failure. The +caller should call error() to get the error message after a failure. +PRINCIPAL, HOSTNAME, and DATETIME are stored as history information. +PRINCIPAL should be the user who is destroying the object. If DATETIME +isn't given, the current time is used. + +=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 = + skey = + host = + +The C 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. +Currently, only one Duo integration type is supported as well. Further +development should expand the available integration types, possibly as +additional wallet object types. + +=head1 SEE ALSO + +Net::Duo(3), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index 2176cab..74b4c99 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -18,7 +18,7 @@ use base 'DBIx::Class::Schema'; # This version should be increased on any code change to this module. Always # use two digits for the minor version with a leading zero if necessary so # that it will sort properly. -our $VERSION = '0.08'; +our $VERSION = '0.09'; __PACKAGE__->load_namespaces; __PACKAGE__->load_components (qw/Schema::Versioned/); @@ -272,6 +272,21 @@ oh_by stores the authenticated identity that made the change, oh_from stores the host from which they made the change, and oh_on stores the time the change was made. +=head2 Duo Backend Data + +Duo integration objects store some additional metadata about the +integration to aid in synchronization with Duo. + + create table duo + (du_name varchar(255) + not null references objects(ob_name), + du_key varchar(255) not null); + create index du_key on duo (du_key); + +du_key holds the Duo integration key, which is the unique name of the +integration within Duo. Additional data may be added later to represent +the other possible settings within Duo. + =head2 Keytab Backend Data The keytab backend has stub support for synchronizing keys with an diff --git a/perl/Wallet/Schema/Result/Duo.pm b/perl/Wallet/Schema/Result/Duo.pm new file mode 100644 index 0000000..80a71dc --- /dev/null +++ b/perl/Wallet/Schema/Result/Duo.pm @@ -0,0 +1,53 @@ +# Wallet schema for Duo metadata. +# +# Written by Jon Robertson +# Copyright 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Duo; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +keytab enctype + +=head1 NAME + +Wallet::Schema::Result::Duo - Wallet schema for Duo metadata + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("duo"); + +=head1 ACCESSORS + +=head2 du_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 du_key + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "du_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "du_key", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("du_name"); + +1; diff --git a/perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql b/perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql new file mode 100644 index 0000000..acc517e --- /dev/null +++ b/perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql @@ -0,0 +1,17 @@ +-- Convert schema 'sql/Wallet-Schema-0.08-MySQL.sql' to 'Wallet::Schema v0.09':; + +BEGIN; + +SET foreign_key_checks=0; + +CREATE TABLE `duo` ( + `du_name` varchar(255) NOT NULL, + `du_key` varchar(255) NOT NULL, + PRIMARY KEY (`du_name`) +); + +SET foreign_key_checks=1; + + +COMMIT; + diff --git a/perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql b/perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql new file mode 100644 index 0000000..0384f67 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql @@ -0,0 +1,12 @@ +-- Convert schema 'sql/Wallet-Schema-0.08-PostgreSQL.sql' to 'sql/Wallet-Schema-0.09-PostgreSQL.sql':; + +BEGIN; + +CREATE TABLE "duo" ( + "du_name" character varying(255) NOT NULL, + "du_key" character varying(255) NOT NULL, + PRIMARY KEY ("du_name") +); + +COMMIT; + diff --git a/perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql b/perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql new file mode 100644 index 0000000..9964a17 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql @@ -0,0 +1,11 @@ +-- Convert schema 'sql/Wallet-Schema-0.08-SQLite.sql' to 'sql/Wallet-Schema-0.09-SQLite.sql':; + +BEGIN; + +CREATE TABLE duo ( + du_name varchar(255) NOT NULL, + du_key varchar(255) NOT NULL, + PRIMARY KEY (du_name) +); + +COMMIT; diff --git a/perl/sql/Wallet-Schema-0.09-MySQL.sql b/perl/sql/Wallet-Schema-0.09-MySQL.sql new file mode 100644 index 0000000..eb582e5 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.09-MySQL.sql @@ -0,0 +1,204 @@ +-- +-- Created by SQL::Translator::Producer::MySQL +-- Created on Fri Jul 11 16:33:47 2014 +-- +SET foreign_key_checks=0; + +DROP TABLE IF EXISTS `acl_history`; + +-- +-- Table: `acl_history` +-- +CREATE TABLE `acl_history` ( + `ah_id` integer NOT NULL auto_increment, + `ah_acl` integer NOT NULL, + `ah_action` varchar(16) NOT NULL, + `ah_scheme` varchar(32) NULL, + `ah_identifier` varchar(255) NULL, + `ah_by` varchar(255) NOT NULL, + `ah_from` varchar(255) NOT NULL, + `ah_on` datetime NOT NULL, + PRIMARY KEY (`ah_id`) +); + +DROP TABLE IF EXISTS `acl_schemes`; + +-- +-- Table: `acl_schemes` +-- +CREATE TABLE `acl_schemes` ( + `as_name` varchar(32) NOT NULL, + `as_class` varchar(64) NULL, + PRIMARY KEY (`as_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `acls`; + +-- +-- Table: `acls` +-- +CREATE TABLE `acls` ( + `ac_id` integer NOT NULL auto_increment, + `ac_name` varchar(255) NOT NULL, + PRIMARY KEY (`ac_id`), + UNIQUE `ac_name` (`ac_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `duo`; + +-- +-- Table: `duo` +-- +CREATE TABLE `duo` ( + `du_name` varchar(255) NOT NULL, + `du_key` varchar(255) NOT NULL, + PRIMARY KEY (`du_name`) +); + +DROP TABLE IF EXISTS `enctypes`; + +-- +-- Table: `enctypes` +-- +CREATE TABLE `enctypes` ( + `en_name` varchar(255) NOT NULL, + PRIMARY KEY (`en_name`) +); + +DROP TABLE IF EXISTS `flags`; + +-- +-- Table: `flags` +-- +CREATE TABLE `flags` ( + `fl_type` varchar(16) NOT NULL, + `fl_name` varchar(255) NOT NULL, + `fl_flag` enum('locked', 'unchanging') NOT NULL, + PRIMARY KEY (`fl_type`, `fl_name`, `fl_flag`) +); + +DROP TABLE IF EXISTS `keytab_enctypes`; + +-- +-- Table: `keytab_enctypes` +-- +CREATE TABLE `keytab_enctypes` ( + `ke_name` varchar(255) NOT NULL, + `ke_enctype` varchar(255) NOT NULL, + PRIMARY KEY (`ke_name`, `ke_enctype`) +); + +DROP TABLE IF EXISTS `keytab_sync`; + +-- +-- Table: `keytab_sync` +-- +CREATE TABLE `keytab_sync` ( + `ks_name` varchar(255) NOT NULL, + `ks_target` varchar(255) NOT NULL, + PRIMARY KEY (`ks_name`, `ks_target`) +); + +DROP TABLE IF EXISTS `sync_targets`; + +-- +-- Table: `sync_targets` +-- +CREATE TABLE `sync_targets` ( + `st_name` varchar(255) NOT NULL, + PRIMARY KEY (`st_name`) +); + +DROP TABLE IF EXISTS `types`; + +-- +-- Table: `types` +-- +CREATE TABLE `types` ( + `ty_name` varchar(16) NOT NULL, + `ty_class` varchar(64) NULL, + PRIMARY KEY (`ty_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `acl_entries`; + +-- +-- Table: `acl_entries` +-- +CREATE TABLE `acl_entries` ( + `ae_id` integer NOT NULL, + `ae_scheme` varchar(32) NOT NULL, + `ae_identifier` varchar(255) NOT NULL, + INDEX `acl_entries_idx_ae_scheme` (`ae_scheme`), + INDEX `acl_entries_idx_ae_id` (`ae_id`), + PRIMARY KEY (`ae_id`, `ae_scheme`, `ae_identifier`), + CONSTRAINT `acl_entries_fk_ae_scheme` FOREIGN KEY (`ae_scheme`) REFERENCES `acl_schemes` (`as_name`), + CONSTRAINT `acl_entries_fk_ae_id` FOREIGN KEY (`ae_id`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `objects`; + +-- +-- Table: `objects` +-- +CREATE TABLE `objects` ( + `ob_type` varchar(16) NOT NULL, + `ob_name` varchar(255) NOT NULL, + `ob_owner` integer NULL, + `ob_acl_get` integer NULL, + `ob_acl_store` integer NULL, + `ob_acl_show` integer NULL, + `ob_acl_destroy` integer NULL, + `ob_acl_flags` integer NULL, + `ob_expires` datetime NULL, + `ob_created_by` varchar(255) NOT NULL, + `ob_created_from` varchar(255) NOT NULL, + `ob_created_on` datetime NOT NULL, + `ob_stored_by` varchar(255) NULL, + `ob_stored_from` varchar(255) NULL, + `ob_stored_on` datetime NULL, + `ob_downloaded_by` varchar(255) NULL, + `ob_downloaded_from` varchar(255) NULL, + `ob_downloaded_on` datetime NULL, + `ob_comment` varchar(255) NULL, + INDEX `objects_idx_ob_acl_destroy` (`ob_acl_destroy`), + INDEX `objects_idx_ob_acl_flags` (`ob_acl_flags`), + INDEX `objects_idx_ob_acl_get` (`ob_acl_get`), + INDEX `objects_idx_ob_owner` (`ob_owner`), + INDEX `objects_idx_ob_acl_show` (`ob_acl_show`), + INDEX `objects_idx_ob_acl_store` (`ob_acl_store`), + INDEX `objects_idx_ob_type` (`ob_type`), + PRIMARY KEY (`ob_name`, `ob_type`), + CONSTRAINT `objects_fk_ob_acl_destroy` FOREIGN KEY (`ob_acl_destroy`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_flags` FOREIGN KEY (`ob_acl_flags`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_get` FOREIGN KEY (`ob_acl_get`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_owner` FOREIGN KEY (`ob_owner`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_show` FOREIGN KEY (`ob_acl_show`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_acl_store` FOREIGN KEY (`ob_acl_store`) REFERENCES `acls` (`ac_id`) ON DELETE CASCADE ON UPDATE CASCADE, + CONSTRAINT `objects_fk_ob_type` FOREIGN KEY (`ob_type`) REFERENCES `types` (`ty_name`) +) ENGINE=InnoDB; + +DROP TABLE IF EXISTS `object_history`; + +-- +-- Table: `object_history` +-- +CREATE TABLE `object_history` ( + `oh_id` integer NOT NULL auto_increment, + `oh_type` varchar(16) NOT NULL, + `oh_name` varchar(255) NOT NULL, + `oh_action` varchar(16) NOT NULL, + `oh_field` varchar(16) NULL, + `oh_type_field` varchar(255) NULL, + `oh_old` varchar(255) NULL, + `oh_new` varchar(255) NULL, + `oh_by` varchar(255) NOT NULL, + `oh_from` varchar(255) NOT NULL, + `oh_on` datetime NOT NULL, + INDEX `object_history_idx_oh_type_oh_name` (`oh_type`, `oh_name`), + PRIMARY KEY (`oh_id`), + CONSTRAINT `object_history_fk_oh_type_oh_name` FOREIGN KEY (`oh_type`, `oh_name`) REFERENCES `objects` (`ob_type`, `ob_name`) +) ENGINE=InnoDB; + +SET foreign_key_checks=1; + diff --git a/perl/sql/Wallet-Schema-0.09-PostgreSQL.sql b/perl/sql/Wallet-Schema-0.09-PostgreSQL.sql new file mode 100644 index 0000000..a7b8881 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.09-PostgreSQL.sql @@ -0,0 +1,208 @@ +-- +-- Created by SQL::Translator::Producer::PostgreSQL +-- Created on Fri Jul 11 16:33:49 2014 +-- +-- +-- Table: duo. +-- +DROP TABLE "duo" CASCADE; +CREATE TABLE "duo" ( + "du_name" character varying(255) NOT NULL, + "du_key" character varying(255) NOT NULL, + PRIMARY KEY ("du_name") +); + +-- +-- Table: acl_history. +-- +DROP TABLE "acl_history" CASCADE; +CREATE TABLE "acl_history" ( + "ah_id" serial NOT NULL, + "ah_acl" integer NOT NULL, + "ah_action" character varying(16) NOT NULL, + "ah_scheme" character varying(32), + "ah_identifier" character varying(255), + "ah_by" character varying(255) NOT NULL, + "ah_from" character varying(255) NOT NULL, + "ah_on" timestamp NOT NULL, + PRIMARY KEY ("ah_id") +); + +-- +-- Table: acl_schemes. +-- +DROP TABLE "acl_schemes" CASCADE; +CREATE TABLE "acl_schemes" ( + "as_name" character varying(32) NOT NULL, + "as_class" character varying(64), + PRIMARY KEY ("as_name") +); + +-- +-- Table: acls. +-- +DROP TABLE "acls" CASCADE; +CREATE TABLE "acls" ( + "ac_id" serial NOT NULL, + "ac_name" character varying(255) NOT NULL, + PRIMARY KEY ("ac_id"), + CONSTRAINT "ac_name" UNIQUE ("ac_name") +); + +-- +-- Table: enctypes. +-- +DROP TABLE "enctypes" CASCADE; +CREATE TABLE "enctypes" ( + "en_name" character varying(255) NOT NULL, + PRIMARY KEY ("en_name") +); + +-- +-- Table: flags. +-- +DROP TABLE "flags" CASCADE; +CREATE TABLE "flags" ( + "fl_type" character varying(16) NOT NULL, + "fl_name" character varying(255) NOT NULL, + "fl_flag" character varying NOT NULL, + PRIMARY KEY ("fl_type", "fl_name", "fl_flag") +); + +-- +-- Table: keytab_enctypes. +-- +DROP TABLE "keytab_enctypes" CASCADE; +CREATE TABLE "keytab_enctypes" ( + "ke_name" character varying(255) NOT NULL, + "ke_enctype" character varying(255) NOT NULL, + PRIMARY KEY ("ke_name", "ke_enctype") +); + +-- +-- Table: keytab_sync. +-- +DROP TABLE "keytab_sync" CASCADE; +CREATE TABLE "keytab_sync" ( + "ks_name" character varying(255) NOT NULL, + "ks_target" character varying(255) NOT NULL, + PRIMARY KEY ("ks_name", "ks_target") +); + +-- +-- Table: sync_targets. +-- +DROP TABLE "sync_targets" CASCADE; +CREATE TABLE "sync_targets" ( + "st_name" character varying(255) NOT NULL, + PRIMARY KEY ("st_name") +); + +-- +-- Table: types. +-- +DROP TABLE "types" CASCADE; +CREATE TABLE "types" ( + "ty_name" character varying(16) NOT NULL, + "ty_class" character varying(64), + PRIMARY KEY ("ty_name") +); + +-- +-- Table: acl_entries. +-- +DROP TABLE "acl_entries" CASCADE; +CREATE TABLE "acl_entries" ( + "ae_id" integer NOT NULL, + "ae_scheme" character varying(32) NOT NULL, + "ae_identifier" character varying(255) NOT NULL, + PRIMARY KEY ("ae_id", "ae_scheme", "ae_identifier") +); +CREATE INDEX "acl_entries_idx_ae_scheme" on "acl_entries" ("ae_scheme"); +CREATE INDEX "acl_entries_idx_ae_id" on "acl_entries" ("ae_id"); + +-- +-- Table: objects. +-- +DROP TABLE "objects" CASCADE; +CREATE TABLE "objects" ( + "ob_type" character varying(16) NOT NULL, + "ob_name" character varying(255) NOT NULL, + "ob_owner" integer, + "ob_acl_get" integer, + "ob_acl_store" integer, + "ob_acl_show" integer, + "ob_acl_destroy" integer, + "ob_acl_flags" integer, + "ob_expires" timestamp, + "ob_created_by" character varying(255) NOT NULL, + "ob_created_from" character varying(255) NOT NULL, + "ob_created_on" timestamp NOT NULL, + "ob_stored_by" character varying(255), + "ob_stored_from" character varying(255), + "ob_stored_on" timestamp, + "ob_downloaded_by" character varying(255), + "ob_downloaded_from" character varying(255), + "ob_downloaded_on" timestamp, + "ob_comment" character varying(255), + PRIMARY KEY ("ob_name", "ob_type") +); +CREATE INDEX "objects_idx_ob_acl_destroy" on "objects" ("ob_acl_destroy"); +CREATE INDEX "objects_idx_ob_acl_flags" on "objects" ("ob_acl_flags"); +CREATE INDEX "objects_idx_ob_acl_get" on "objects" ("ob_acl_get"); +CREATE INDEX "objects_idx_ob_owner" on "objects" ("ob_owner"); +CREATE INDEX "objects_idx_ob_acl_show" on "objects" ("ob_acl_show"); +CREATE INDEX "objects_idx_ob_acl_store" on "objects" ("ob_acl_store"); +CREATE INDEX "objects_idx_ob_type" on "objects" ("ob_type"); + +-- +-- Table: object_history. +-- +DROP TABLE "object_history" CASCADE; +CREATE TABLE "object_history" ( + "oh_id" serial NOT NULL, + "oh_type" character varying(16) NOT NULL, + "oh_name" character varying(255) NOT NULL, + "oh_action" character varying(16) NOT NULL, + "oh_field" character varying(16), + "oh_type_field" character varying(255), + "oh_old" character varying(255), + "oh_new" character varying(255), + "oh_by" character varying(255) NOT NULL, + "oh_from" character varying(255) NOT NULL, + "oh_on" timestamp NOT NULL, + PRIMARY KEY ("oh_id") +); +CREATE INDEX "object_history_idx_oh_type_oh_name" on "object_history" ("oh_type", "oh_name"); + +-- +-- Foreign Key Definitions +-- + +ALTER TABLE "acl_entries" ADD CONSTRAINT "acl_entries_fk_ae_scheme" FOREIGN KEY ("ae_scheme") + REFERENCES "acl_schemes" ("as_name") DEFERRABLE; + +ALTER TABLE "acl_entries" ADD CONSTRAINT "acl_entries_fk_ae_id" FOREIGN KEY ("ae_id") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD CONSTRAINT "objects_fk_ob_acl_destroy" FOREIGN KEY ("ob_acl_destroy") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD CONSTRAINT "objects_fk_ob_acl_flags" FOREIGN KEY ("ob_acl_flags") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD CONSTRAINT "objects_fk_ob_acl_get" FOREIGN KEY ("ob_acl_get") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD CONSTRAINT "objects_fk_ob_owner" FOREIGN KEY ("ob_owner") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD CONSTRAINT "objects_fk_ob_acl_show" FOREIGN KEY ("ob_acl_show") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD CONSTRAINT "objects_fk_ob_acl_store" FOREIGN KEY ("ob_acl_store") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD CONSTRAINT "objects_fk_ob_type" FOREIGN KEY ("ob_type") + REFERENCES "types" ("ty_name") DEFERRABLE; + diff --git a/perl/sql/Wallet-Schema-0.09-SQLite.sql b/perl/sql/Wallet-Schema-0.09-SQLite.sql new file mode 100644 index 0000000..fbde466 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.09-SQLite.sql @@ -0,0 +1,212 @@ +-- +-- Created by SQL::Translator::Producer::SQLite +-- Created on Fri Jul 11 16:33:48 2014 +-- + +BEGIN TRANSACTION; + +-- +-- Table: duo +-- +DROP TABLE IF EXISTS duo; + +CREATE TABLE duo ( + du_name varchar(255) NOT NULL, + du_key varchar(255) NOT NULL, + PRIMARY KEY (du_name) +); + +-- +-- Table: acl_history +-- +DROP TABLE IF EXISTS acl_history; + +CREATE TABLE acl_history ( + ah_id INTEGER PRIMARY KEY NOT NULL, + ah_acl integer NOT NULL, + ah_action varchar(16) NOT NULL, + ah_scheme varchar(32), + ah_identifier varchar(255), + ah_by varchar(255) NOT NULL, + ah_from varchar(255) NOT NULL, + ah_on datetime NOT NULL +); + +-- +-- Table: acl_schemes +-- +DROP TABLE IF EXISTS acl_schemes; + +CREATE TABLE acl_schemes ( + as_name varchar(32) NOT NULL, + as_class varchar(64), + PRIMARY KEY (as_name) +); + +-- +-- Table: acls +-- +DROP TABLE IF EXISTS acls; + +CREATE TABLE acls ( + ac_id INTEGER PRIMARY KEY NOT NULL, + ac_name varchar(255) NOT NULL +); + +CREATE UNIQUE INDEX ac_name ON acls (ac_name); + +-- +-- Table: enctypes +-- +DROP TABLE IF EXISTS enctypes; + +CREATE TABLE enctypes ( + en_name varchar(255) NOT NULL, + PRIMARY KEY (en_name) +); + +-- +-- Table: flags +-- +DROP TABLE IF EXISTS flags; + +CREATE TABLE flags ( + fl_type varchar(16) NOT NULL, + fl_name varchar(255) NOT NULL, + fl_flag enum NOT NULL, + PRIMARY KEY (fl_type, fl_name, fl_flag) +); + +-- +-- Table: keytab_enctypes +-- +DROP TABLE IF EXISTS keytab_enctypes; + +CREATE TABLE keytab_enctypes ( + ke_name varchar(255) NOT NULL, + ke_enctype varchar(255) NOT NULL, + PRIMARY KEY (ke_name, ke_enctype) +); + +-- +-- Table: keytab_sync +-- +DROP TABLE IF EXISTS keytab_sync; + +CREATE TABLE keytab_sync ( + ks_name varchar(255) NOT NULL, + ks_target varchar(255) NOT NULL, + PRIMARY KEY (ks_name, ks_target) +); + +-- +-- Table: sync_targets +-- +DROP TABLE IF EXISTS sync_targets; + +CREATE TABLE sync_targets ( + st_name varchar(255) NOT NULL, + PRIMARY KEY (st_name) +); + +-- +-- Table: types +-- +DROP TABLE IF EXISTS types; + +CREATE TABLE types ( + ty_name varchar(16) NOT NULL, + ty_class varchar(64), + PRIMARY KEY (ty_name) +); + +-- +-- Table: acl_entries +-- +DROP TABLE IF EXISTS acl_entries; + +CREATE TABLE acl_entries ( + ae_id integer NOT NULL, + ae_scheme varchar(32) NOT NULL, + ae_identifier varchar(255) NOT NULL, + PRIMARY KEY (ae_id, ae_scheme, ae_identifier), + FOREIGN KEY (ae_scheme) REFERENCES acl_schemes(as_name), + FOREIGN KEY (ae_id) REFERENCES acls(ac_id) ON DELETE CASCADE ON UPDATE CASCADE +); + +CREATE INDEX acl_entries_idx_ae_scheme ON acl_entries (ae_scheme); + +CREATE INDEX acl_entries_idx_ae_id ON acl_entries (ae_id); + +-- +-- Table: objects +-- +DROP TABLE IF EXISTS objects; + +CREATE TABLE objects ( + ob_type varchar(16) NOT NULL, + ob_name varchar(255) NOT NULL, + ob_owner integer, + ob_acl_get integer, + ob_acl_store integer, + ob_acl_show integer, + ob_acl_destroy integer, + ob_acl_flags integer, + ob_expires datetime, + ob_created_by varchar(255) NOT NULL, + ob_created_from varchar(255) NOT NULL, + ob_created_on datetime NOT NULL, + ob_stored_by varchar(255), + ob_stored_from varchar(255), + ob_stored_on datetime, + ob_downloaded_by varchar(255), + ob_downloaded_from varchar(255), + ob_downloaded_on datetime, + ob_comment varchar(255), + PRIMARY KEY (ob_name, ob_type), + FOREIGN KEY (ob_acl_destroy) REFERENCES acls(ac_id) ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY (ob_acl_flags) REFERENCES acls(ac_id) ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY (ob_acl_get) REFERENCES acls(ac_id) ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY (ob_owner) REFERENCES acls(ac_id) ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY (ob_acl_show) REFERENCES acls(ac_id) ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY (ob_acl_store) REFERENCES acls(ac_id) ON DELETE CASCADE ON UPDATE CASCADE, + FOREIGN KEY (ob_type) REFERENCES types(ty_name) +); + +CREATE INDEX objects_idx_ob_acl_destroy ON objects (ob_acl_destroy); + +CREATE INDEX objects_idx_ob_acl_flags ON objects (ob_acl_flags); + +CREATE INDEX objects_idx_ob_acl_get ON objects (ob_acl_get); + +CREATE INDEX objects_idx_ob_owner ON objects (ob_owner); + +CREATE INDEX objects_idx_ob_acl_show ON objects (ob_acl_show); + +CREATE INDEX objects_idx_ob_acl_store ON objects (ob_acl_store); + +CREATE INDEX objects_idx_ob_type ON objects (ob_type); + +-- +-- Table: object_history +-- +DROP TABLE IF EXISTS object_history; + +CREATE TABLE object_history ( + oh_id INTEGER PRIMARY KEY NOT NULL, + oh_type varchar(16) NOT NULL, + oh_name varchar(255) NOT NULL, + oh_action varchar(16) NOT NULL, + oh_field varchar(16), + oh_type_field varchar(255), + oh_old varchar(255), + oh_new varchar(255), + oh_by varchar(255) NOT NULL, + oh_from varchar(255) NOT NULL, + oh_on datetime NOT NULL, + FOREIGN KEY (oh_type, oh_name) REFERENCES objects(ob_type, ob_name) +); + +CREATE INDEX object_history_idx_oh_type_oh_name ON object_history (oh_type, oh_name); + +COMMIT; diff --git a/perl/t/data/duo/integration.json b/perl/t/data/duo/integration.json new file mode 100644 index 0000000..6e569d6 --- /dev/null +++ b/perl/t/data/duo/integration.json @@ -0,0 +1,11 @@ +{ + "enroll_policy": "enroll", + "greeting": "", + "groups_allowed": [], + "integration_key": "DIRWIH0ZZPV4G88B37VQ", + "name": "Integration for UNIX PAM", + "notes": "", + "secret_key": "QO4ZLqQVRIOZYkHfdPDORfcNf8LeXIbCWwHazY7o", + "type": "unix", + "visual_style": "default" +} diff --git a/perl/t/data/duo/keys.json b/perl/t/data/duo/keys.json new file mode 100644 index 0000000..0de11ff --- /dev/null +++ b/perl/t/data/duo/keys.json @@ -0,0 +1,5 @@ +{ + "integration_key": "VWFQIFMA9E79ZFG0ABIQ", + "secret_key": "BAbja87NB8AmzlgalGAm09abNqpGZVva985al1zF", + "api_hostname": "example-admin.duosecurity.com" +} diff --git a/perl/t/duo.t b/perl/t/duo.t new file mode 100755 index 0000000..12fee3a --- /dev/null +++ b/perl/t/duo.t @@ -0,0 +1,157 @@ +#!/usr/bin/perl +# +# Tests for the Duo integration object implementation. +# +# Written by Russ Allbery +# Copyright 2014 +# 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; + +BEGIN { + eval 'use Net::Duo'; + plan skip_all => 'Net::Duo required for testing duo' + if $@; + eval 'use Net::Duo::Mock::Agent'; + plan skip_all => 'Net::Duo::Mock::Agent required for testing duo' + if $@; +} + +BEGIN { + use_ok('Wallet::Admin'); + use_ok('Wallet::Config'); + use_ok('Wallet::Object::Duo'); +} + +use lib 't/lib'; +use Util; + +# Some global defaults to use. +my $user = 'admin@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($user, $host, time); +my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); + +# Flush all output immediately. +$| = 1; + +# Use Wallet::Admin to set up the database. +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); +my $schema = $admin->schema; + +# Create a mock object to use for Duo calls. +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->new ('duo', 'test', $schema); +}; +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->create ('duo', 'test', $schema, @trace); +}; +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. +$Wallet::Config::DUO_AGENT = $mock; +$Wallet::Config::DUO_KEY_FILE = 't/data/duo/keys.json'; + +# Test creating an integration. +note ('Test creating an integration'); +my $expected = { + name => 'test', + notes => 'Managed by wallet', + type => 'unix', +}; +$mock->expect ( + { + method => 'POST', + uri => '/admin/v1/integrations', + content => $expected, + response_file => 't/data/duo/integration.json', + } +); +$object = Wallet::Object::Duo->create ('duo', 'test', $schema, @trace); +isa_ok ($object, 'Wallet::Object::Duo'); + +# Check the metadata about the new wallet object. +$expected = <<"EOO"; + Type: duo + Name: test + Duo key: DIRWIH0ZZPV4G88B37VQ + Created by: $user + Created from: $host + Created on: $date +EOO +is ($object->show, $expected, 'Show output is correct'); + +# Test retrieving the integration information. +note ('Test retrieving an integration'); +$mock->expect ( + { + method => 'GET', + uri => '/admin/v1/integrations/DIRWIH0ZZPV4G88B37VQ', + response_file => 't/data/duo/integration.json', + } +); +my $data = $object->get (@trace); +ok (defined ($data), 'Retrieval succeeds'); +$expected = <<'EOO'; +[duo] +ikey = DIRWIH0ZZPV4G88B37VQ +skey = QO4ZLqQVRIOZYkHfdPDORfcNf8LeXIbCWwHazY7o +host = example-admin.duosecurity.com +EOO +is ($data, $expected, '...and integration data is correct'); + +# Ensure that we can't retrieve the object when locked. +is ($object->flag_set ('locked', @trace), 1, + 'Setting object to locked succeeds'); +is ($object->get, undef, '...and now get fails'); +is ($object->error, 'cannot get duo:test: object is locked', + '...with correct error'); +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->new ('duo', '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 +# calls and delete makes two calls. +note ('Test deleting an integration'); +$mock->expect ( + { + method => 'GET', + uri => '/admin/v1/integrations/DIRWIH0ZZPV4G88B37VQ', + response_file => 't/data/duo/integration.json', + } +); +TODO: { + local $TODO = 'Net::Duo::Mock::Agent not yet capable'; + + is ($object->destroy (@trace), 1, 'Duo object deletion succeeded'); + $object = eval { Wallet::Object::Duo->new ('duo', 'test', $schema) }; + is ($object, undef, '...and now object cannot be retrieved'); + is ($@, "cannot find duo:test\n", '...with correct error'); +} + +# Clean up. +$admin->destroy; +undef $admin; +undef $object; +unlink ('wallet-db'); + +# Done testing. +done_testing (); diff --git a/tests/server/admin-t b/tests/server/admin-t index 3c80d81..f025d98 100755 --- a/tests/server/admin-t +++ b/tests/server/admin-t @@ -3,7 +3,7 @@ # Tests for the wallet-admin dispatch code. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2011 +# Copyright 2008, 2009, 2010, 2011, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -142,7 +142,7 @@ is ($err, "invalid admin principal rra\n", 'Initialize requires a principal'); is ($out, "new\n", ' and nothing was run'); ($out, $err) = run_admin ('initialize', 'eagle@eyrie.org'); is ($err, '', 'Initialize succeeds with a principal'); -is ($out, "new\ninitialize rra\@stanford.edu\n", ' and runs the right code'); +is ($out, "new\ninitialize eagle\@eyrie.org\n", ' and runs the right code'); # Test register. ($out, $err) = run_admin ('register', 'foo', 'foo', 'Foo::Bar'); @@ -172,7 +172,7 @@ is ($out, "new\n" . ' Are you sure (N/y)? ' . "destroy\n", ' and calls the right methods'); ($out, $err) = run_admin ('initialize', 'eagle@eyrie.org'); is ($err, "some error\n", 'Error handling succeeds for initialize'); -is ($out, "new\ninitialize rra\@stanford.edu\n", +is ($out, "new\ninitialize eagle\@eyrie.org\n", ' and calls the right methods'); ($out, $err) = run_admin ('register', 'object', 'foo', 'Foo::Object'); is ($err, "some error\n", 'Error handling succeeds for register object'); -- cgit v1.2.3 From cc98e4d332295a336f0b4363f4399dab5d7ec189 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 11 Jul 2014 19:55:07 -0700 Subject: List all SQL files separately in Makefile.am Otherwise, they won't be copied properly to the perl directory when building out of tree. Change-Id: Id178d1b58d14a3595f372e25744dbdc61a81ff34 Reviewed-on: https://gerrit.stanford.edu/1527 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index dba1f94..3fd574d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -32,14 +32,26 @@ PERL_FILES = perl/Wallet/ACL.pm perl/Wallet/ACL/Base.pm \ perl/Wallet/Schema/Result/Object.pm \ perl/Wallet/Schema/Result/ObjectHistory.pm \ perl/Wallet/Schema/Result/SyncTarget.pm \ - perl/Wallet/Schema/Result/Type.pm perl/sql perl/t/acl.t \ - perl/t/admin.t perl/t/config.t perl/t/data/README \ - perl/t/data/duo/integration.json perl/t/data/duo/keys.json \ - perl/t/data/keytab-fake perl/t/data/keytab.conf \ - perl/t/data/netdb.conf perl/t/data/netdb-fake perl/t/duo.t \ - perl/t/file.t perl/t/init.t perl/t/kadmin.t perl/t/keytab.t \ - perl/t/lib/Util.pm perl/t/object.t perl/t/pod-spelling.t \ - perl/t/pod.t perl/t/report.t perl/t/server.t \ + perl/Wallet/Schema/Result/Type.pm \ + perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql \ + perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql \ + perl/sql/Wallet-Schema-0.07-MySQL.sql \ + perl/sql/Wallet-Schema-0.07-SQLite.sql \ + perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql \ + perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql \ + perl/sql/Wallet-Schema-0.08-MySQL.sql \ + perl/sql/Wallet-Schema-0.08-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.08-SQLite.sql \ + perl/sql/Wallet-Schema-0.09-MySQL.sql \ + perl/sql/Wallet-Schema-0.09-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.09-SQLite.sql perl/t/acl.t perl/t/admin.t \ + perl/t/config.t perl/t/data/README perl/t/data/duo/integration.json \ + perl/t/data/duo/keys.json perl/t/data/keytab-fake \ + perl/t/data/keytab.conf perl/t/data/netdb.conf \ + perl/t/data/netdb-fake perl/t/duo.t perl/t/file.t perl/t/init.t \ + perl/t/kadmin.t perl/t/keytab.t perl/t/lib/Util.pm perl/t/object.t \ + perl/t/pod-spelling.t perl/t/pod.t perl/t/report.t perl/t/server.t \ perl/t/stanford-naming.t perl/t/verifier-ldap-attr.t \ perl/t/verifier-netdb.t perl/t/verifier.t perl/t/wa-keyring.t -- cgit v1.2.3 From da0aba21779529d98436e42323fc12f702390969 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 11 Jul 2014 20:18:41 -0700 Subject: Update to rra-c-util 5.5 and C TAP Harness 3.1 Update to rra-c-util 5.5: * Use Lancaster Consensus environment variables to control tests. * Use calloc or reallocarray for protection against integer overflows. * Suppress warnings from Kerberos headers in non-system paths. * Assume calloc initializes pointers to NULL. * Assume free(NULL) is properly ignored. * Improve error handling in xasprintf and xvasprintf. * Check the return status of snprintf and vsnprintf properly. * Preserve errno if snprintf fails in vasprintf replacement. Update to C TAP Harness 3.1: * Reopen standard input to /dev/null when running a test list. * Don't leak extraneous file descriptors to tests. * Suppress lazy plans and test summaries if the test failed with bail. * runtests now treats the command line as a list of tests by default. * The full test executable path can now be passed to runtests -o. * Improved harness output for tests with lazy plans. * Improved harness output to a terminal for some abort cases. * Flush harness output after each test even when not on a terminal. Change-Id: I05161eb3d3be49a98f7762e876cb114da0c84e9a Reviewed-on: https://gerrit.stanford.edu/1529 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 24 +- NEWS | 22 ++ configure.ac | 11 +- m4/krb5.m4 | 66 ++-- m4/remctl.m4 | 13 +- portable/asprintf.c | 8 +- portable/dummy.c | 6 +- portable/krb5.h | 2 + portable/reallocarray.c | 56 +++ portable/snprintf.c | 9 +- portable/system.h | 24 +- tests/docs/pod-spelling-t | 11 +- tests/docs/pod-t | 10 +- tests/runtests.c | 700 ++++++++++++++++++++++++++---------- tests/tap/basic.c | 586 ++++++++++++++++++++++-------- tests/tap/basic.h | 79 ++-- tests/tap/kerberos.c | 105 +++--- tests/tap/kerberos.h | 26 +- tests/tap/libtap.sh | 4 +- tests/tap/macros.h | 9 +- tests/tap/messages.c | 8 +- tests/tap/perl/Test/RRA.pm | 71 +++- tests/tap/perl/Test/RRA/Automake.pm | 2 +- tests/tap/perl/Test/RRA/Config.pm | 13 +- tests/tap/process.c | 350 +++++++++++++++++- tests/tap/process.h | 31 +- tests/util/messages-krb5-t.c | 24 +- tests/util/xmalloc-t | 121 ++++--- tests/util/xmalloc.c | 43 ++- util/messages-krb5.c | 3 +- util/messages-krb5.h | 6 +- util/messages.c | 37 +- util/messages.h | 9 +- util/xmalloc.c | 39 +- util/xmalloc.h | 15 +- 35 files changed, 1936 insertions(+), 607 deletions(-) create mode 100644 portable/reallocarray.c (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index 3fd574d..82b84f7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -128,25 +128,27 @@ dist_pkgdata_DATA = perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql \ perl/sql/Wallet-Schema-0.09-PostgreSQL.sql \ perl/sql/Wallet-Schema-0.09-SQLite.sql -# A set of flags for warnings. Add -O because gcc won't find some warnings +# A set of flags for warnings. Add -O because gcc won't find some warnings # without optimization turned on. Desirable warnings that can't be turned # on due to other problems: # -# -Wconversion http://bugs.debian.org/488884 (htons warnings) +# -Wconversion http://bugs.debian.org/488884 (htons warnings) # -# Last checked against gcc 4.6.1 (2011-05-04). -D_FORTIFY_SOURCE=2 enables +# Last checked against gcc 4.8.2 (2014-04-12). -D_FORTIFY_SOURCE=2 enables # warn_unused_result attribute markings on glibc functions on Linux, which # catches a few more issues. -WARNINGS = -g -O -D_FORTIFY_SOURCE=2 -Wall -Wextra -Wendif-labels \ - -Wformat=2 -Winit-self -Wswitch-enum -Wdeclaration-after-statement \ +WARNINGS = -g -O -fstrict-overflow -fstrict-aliasing -D_FORTIFY_SOURCE=2 \ + -Wall -Wextra -Wendif-labels -Wformat=2 -Winit-self -Wswitch-enum \ + -Wstrict-overflow=5 -Wfloat-equal -Wdeclaration-after-statement \ -Wshadow -Wpointer-arith -Wbad-function-cast -Wcast-align \ - -Wwrite-strings -Wjump-misses-init -Wlogical-op \ - -Wstrict-prototypes -Wmissing-prototypes -Wredundant-decls \ - -Wnested-externs -Werror + -Wwrite-strings -Wjump-misses-init -Wlogical-op -Wstrict-prototypes \ + -Wold-style-definition -Wmissing-prototypes -Wnormalized=nfc \ + -Wpacked -Wredundant-decls -Wnested-externs -Winline -Wvla -Werror warnings: - $(MAKE) V=0 CFLAGS='$(WARNINGS)' - $(MAKE) V=0 CFLAGS='$(WARNINGS)' $(check_PROGRAMS) + $(MAKE) V=0 CFLAGS='$(WARNINGS)' KRB5_CPPFLAGS='$(KRB5_CPPFLAGS_GCC)' + $(MAKE) V=0 CFLAGS='$(WARNINGS)' \ + KRB5_CPPFLAGS='$(KRB5_CPPFLAGS_GCC)' $(check_PROGRAMS) # Remove some additional files. DISTCLEANFILES = perl/Makefile @@ -237,7 +239,7 @@ tests_util_messages_t_LDADD = tests/tap/libtap.a util/libutil.a \ tests_util_xmalloc_LDADD = util/libutil.a portable/libportable.a check-local: $(check_PROGRAMS) - cd tests && ./runtests $(abs_top_srcdir)/tests/TESTS + cd tests && ./runtests -l $(abs_top_srcdir)/tests/TESTS @echo '' cd perl && $(MAKE) test diff --git a/NEWS b/NEWS index 7864311..76ddfd1 100644 --- a/NEWS +++ b/NEWS @@ -39,6 +39,28 @@ wallet 1.1 (unreleased) and an incorrect linkage in the schema for the ACL history, and add indices for the object type, name, and ACL instead. + Update to rra-c-util 5.5: + + * Use Lancaster Consensus environment variables to control tests. + * Use calloc or reallocarray for protection against integer overflows. + * Suppress warnings from Kerberos headers in non-system paths. + * Assume calloc initializes pointers to NULL. + * Assume free(NULL) is properly ignored. + * Improve error handling in xasprintf and xvasprintf. + * Check the return status of snprintf and vsnprintf properly. + * Preserve errno if snprintf fails in vasprintf replacement. + + Update to C TAP Harness 3.1: + + * Reopen standard input to /dev/null when running a test list. + * Don't leak extraneous file descriptors to tests. + * Suppress lazy plans and test summaries if the test failed with bail. + * runtests now treats the command line as a list of tests by default. + * The full test executable path can now be passed to runtests -o. + * Improved harness output for tests with lazy plans. + * Improved harness output to a terminal for some abort cases. + * Flush harness output after each test even when not on a terminal. + wallet 1.0 (2013-03-27) Owners of wallet objects are now allowed to destroy them. In previous diff --git a/configure.ac b/configure.ac index 4c6e5f7..b1b335d 100644 --- a/configure.ac +++ b/configure.ac @@ -19,11 +19,14 @@ dnl AM_PROG_AR is required for Automake 1.12 by Libtool but not defined at all dnl (or needed) in Automake 1.11. Work around this bug. AC_PROG_CC AC_USE_SYSTEM_EXTENSIONS +AC_SYS_LARGEFILE AM_PROG_CC_C_O m4_ifdef([AM_PROG_AR], [AM_PROG_AR]) AC_PROG_INSTALL AC_PROG_RANLIB +dnl Allow modification of the default wallet port, and setting a default +dnl wallet server when none is defined in krb5.conf. AC_ARG_WITH([wallet-server], [AC_HELP_STRING([--with-wallet-server=HOST], [Default wallet server])], [AS_IF([test x"$withval" != xno && test x"$withval" != xyes], @@ -36,6 +39,7 @@ AC_ARG_WITH([wallet-port], [AC_DEFINE_UNQUOTED([WALLET_PORT], [$withval], [Define to the default server port.])])]) +dnl Probe for required libraries. RRA_LIB_REMCTL RRA_LIB_KRB5 RRA_LIB_KRB5_SWITCH @@ -49,6 +53,7 @@ AC_CHECK_DECLS([krb5_kt_free_entry]) AC_CHECK_MEMBERS([krb5_keytab_entry.keyblock], [], [], [RRA_INCLUDES_KRB5]) RRA_LIB_KRB5_RESTORE +dnl Probe for properties of the C library. AC_HEADER_STDBOOL AC_CHECK_HEADERS([sys/bitypes.h sys/uio.h syslog.h]) AC_CHECK_DECLS([snprintf, vsnprintf]) @@ -59,14 +64,16 @@ AC_CHECK_TYPES([ssize_t], [], [], [#include ]) RRA_FUNC_SNPRINTF AC_CHECK_FUNCS([setrlimit]) -AC_REPLACE_FUNCS([asprintf mkstemp setenv strlcat strlcpy]) +AC_REPLACE_FUNCS([asprintf mkstemp reallocarray setenv strlcat strlcpy]) +dnl Find a remctld binary for the test suite. AC_ARG_VAR([REMCTLD], [Path to the remctld binary]) -AC_PATH_PROG([REMCTLD], [remctld], , [$PATH:/usr/sbin:/usr/local/sbin]) +AC_PATH_PROG([REMCTLD], [remctld], [], [$PATH:/usr/sbin:/usr/local/sbin]) AS_IF([test x"$REMCTLD" != x], [AC_DEFINE_UNQUOTED([PATH_REMCTLD], ["$REMCTLD"], [Define to the full path to remctld to run remctl tests.])]) +dnl Output section. AC_CONFIG_HEADER([config.h]) AC_CONFIG_FILES([Makefile perl/Makefile.PL]) AC_CONFIG_FILES([tests/client/basic-t], [chmod +x tests/client/basic-t]) diff --git a/m4/krb5.m4 b/m4/krb5.m4 index 2556425..79ef961 100644 --- a/m4/krb5.m4 +++ b/m4/krb5.m4 @@ -11,23 +11,33 @@ dnl KRB5_CPPFLAGS, KRB5_LDFLAGS, and KRB5_LIBS. Also provides dnl RRA_LIB_KRB5_SWITCH to set CPPFLAGS, LDFLAGS, and LIBS to include the dnl Kerberos libraries, saving the current values first, and dnl RRA_LIB_KRB5_RESTORE to restore those settings to before the last -dnl RRA_LIB_KRB5_SWITCH. HAVE_KERBEROS will always be defined if RRA_LIB_KRB5 -dnl is used. +dnl RRA_LIB_KRB5_SWITCH. HAVE_KRB5 will always be defined if RRA_LIB_KRB5 is +dnl used. dnl dnl If KRB5_CPPFLAGS, KRB5_LDFLAGS, or KRB5_LIBS are set before calling these dnl macros, their values will be added to whatever the macros discover. dnl +dnl KRB5_CPPFLAGS_GCC will be set to the same value as KRB5_CPPFLAGS but with +dnl any occurrences of -I changed to -isystem. This may be useful to suppress +dnl warnings from the Kerberos header files when building with GCC and +dnl aggressive warning flags. Be aware that this change will change the +dnl compiler header file search order as well. +dnl dnl Provides the RRA_LIB_KRB5_OPTIONAL macro, which should be used if Kerberos -dnl support is optional. This macro will still always set the substitution -dnl variables, but they'll be empty unless --with-krb5 is given. Also, -dnl HAVE_KERBEROS will be defined if --with-krb5 is given and -dnl $rra_use_kerberos will be set to "true". +dnl support is optional. In this case, Kerberos libraries are mandatory if +dnl --with-krb5 is given, and will not be probed for if --without-krb5 is +dnl given. Otherwise, they'll be probed for but will not be required. +dnl Defines HAVE_KRB5 and sets rra_use_KRB5 to true if the libraries are +dnl found. The substitution variables will always be set, but they will be +dnl empty unless Kerberos libraries are found and the user did not disable +dnl Kerberos support. dnl dnl Sets the Automake conditional KRB5_USES_COM_ERR saying whether we use dnl com_err, since if we're also linking with AFS libraries, we may have to dnl change library ordering in that case. dnl -dnl Depends on RRA_ENABLE_REDUCED_DEPENDS and RRA_SET_LDFLAGS. +dnl Depends on RRA_KRB5_CONFIG, RRA_ENABLE_REDUCED_DEPENDS, and +dnl RRA_SET_LDFLAGS. dnl dnl Also provides RRA_FUNC_KRB5_GET_INIT_CREDS_OPT_FREE_ARGS, which checks dnl whether krb5_get_init_creds_opt_free takes one argument or two. Defines @@ -40,13 +50,16 @@ dnl The canonical version of this file is maintained in the rra-c-util dnl package, available at . dnl dnl Written by Russ Allbery -dnl Copyright 2005, 2006, 2007, 2008, 2009, 2010, 2011 +dnl Copyright 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2013, 2014 dnl The Board of Trustees of the Leland Stanford Junior University dnl dnl This file is free software; the authors give unlimited permission to copy dnl and/or distribute it, with or without modifications, as long as this dnl notice is preserved. +dnl Ignore Automake conditionals if not using Automake. +m4_define_default([AM_CONDITIONAL], [:]) + dnl Headers to include when probing for Kerberos library properties. AC_DEFUN([RRA_INCLUDES_KRB5], [[ #if HAVE_KRB5_H @@ -124,7 +137,9 @@ AC_DEFUN([_RRA_LIB_KRB5_REDUCED], [RRA_INCLUDES_KRB5])], [AC_CHECK_LIB([com_err], [com_err], [KRB5_LIBS="$KRB5_LIBS -lcom_err"], - [AC_MSG_ERROR([cannot find usable com_err library])]) + [AS_IF([test x"$1" = xtrue], + [AC_MSG_ERROR([cannot find usable com_err library])], + [KRB5_LIBS=""])]) AC_CHECK_HEADERS([et/com_err.h])])])])]) RRA_LIB_KRB5_RESTORE]) @@ -230,6 +245,10 @@ dnl checking. AC_DEFUN([_RRA_LIB_KRB5_INTERNAL], [AC_REQUIRE([RRA_ENABLE_REDUCED_DEPENDS]) rra_krb5_incroot= + AC_SUBST([KRB5_CPPFLAGS]) + AC_SUBST([KRB5_CPPFLAGS_GCC]) + AC_SUBST([KRB5_LDFLAGS]) + AC_SUBST([KRB5_LIBS]) AS_IF([test x"$rra_krb5_includedir" != x], [rra_krb5_incroot="$rra_krb5_includedir"], [AS_IF([test x"$rra_krb5_root" != x], @@ -242,18 +261,17 @@ AC_DEFUN([_RRA_LIB_KRB5_INTERNAL], [_RRA_LIB_KRB5_PATHS _RRA_LIB_KRB5_MANUAL([$1])])]) rra_krb5_uses_com_err=false - AS_CASE([$LIBS], [*-lcom_err*], [rra_krb5_uses_com_err=true]) - AM_CONDITIONAL([KRB5_USES_COM_ERR], [test x"$rra_krb5_uses_com_err" = xtrue])]) + AS_CASE([$KRB5_LIBS], [*-lcom_err*], [rra_krb5_uses_com_err=true]) + AM_CONDITIONAL([KRB5_USES_COM_ERR], + [test x"$rra_krb5_uses_com_err" = xtrue]) + KRB5_CPPFLAGS_GCC=`echo "$KRB5_CPPFLAGS" | sed -e 's/-I/-isystem /g'`]) dnl The main macro for packages with mandatory Kerberos support. AC_DEFUN([RRA_LIB_KRB5], [rra_krb5_root= rra_krb5_libdir= rra_krb5_includedir= - rra_use_kerberos=true - AC_SUBST([KRB5_CPPFLAGS]) - AC_SUBST([KRB5_LDFLAGS]) - AC_SUBST([KRB5_LIBS]) + rra_use_KRB5=true AC_ARG_WITH([krb5], [AS_HELP_STRING([--with-krb5=DIR], @@ -271,25 +289,22 @@ AC_DEFUN([RRA_LIB_KRB5], [AS_IF([test x"$withval" != xyes && test x"$withval" != xno], [rra_krb5_libdir="$withval"])]) _RRA_LIB_KRB5_INTERNAL([true]) - AC_DEFINE([HAVE_KERBEROS], 1, [Define to enable Kerberos features.])]) + AC_DEFINE([HAVE_KRB5], 1, [Define to enable Kerberos features.])]) dnl The main macro for packages with optional Kerberos support. AC_DEFUN([RRA_LIB_KRB5_OPTIONAL], [rra_krb5_root= rra_krb5_libdir= rra_krb5_includedir= - rra_use_kerberos= - AC_SUBST([KRB5_CPPFLAGS]) - AC_SUBST([KRB5_LDFLAGS]) - AC_SUBST([KRB5_LIBS]) + rra_use_KRB5= AC_ARG_WITH([krb5], [AS_HELP_STRING([--with-krb5@<:@=DIR@:>@], [Location of Kerberos headers and libraries])], [AS_IF([test x"$withval" = xno], - [rra_use_kerberos=false], + [rra_use_KRB5=false], [AS_IF([test x"$withval" != xyes], [rra_krb5_root="$withval"]) - rra_use_kerberos=true])]) + rra_use_KRB5=true])]) AC_ARG_WITH([krb5-include], [AS_HELP_STRING([--with-krb5-include=DIR], [Location of Kerberos headers])], @@ -301,13 +316,14 @@ AC_DEFUN([RRA_LIB_KRB5_OPTIONAL], [AS_IF([test x"$withval" != xyes && test x"$withval" != xno], [rra_krb5_libdir="$withval"])]) - AS_IF([test x"$rra_use_kerberos" != xfalse], - [AS_IF([test x"$rra_use_kerberos" = xtrue], + AS_IF([test x"$rra_use_KRB5" != xfalse], + [AS_IF([test x"$rra_use_KRB5" = xtrue], [_RRA_LIB_KRB5_INTERNAL([true])], [_RRA_LIB_KRB5_INTERNAL([false])])], [AM_CONDITIONAL([KRB5_USES_COM_ERR], [false])]) AS_IF([test x"$KRB5_LIBS" != x], - [AC_DEFINE([HAVE_KERBEROS], 1, [Define to enable Kerberos features.])])]) + [rra_use_KRB5=true + AC_DEFINE([HAVE_KRB5], 1, [Define to enable Kerberos features.])])]) dnl Source used by RRA_FUNC_KRB5_GET_INIT_CREDS_OPT_FREE_ARGS. AC_DEFUN([_RRA_FUNC_KRB5_OPT_FREE_ARGS_SOURCE], [RRA_INCLUDES_KRB5] [[ diff --git a/m4/remctl.m4 b/m4/remctl.m4 index 5b492f3..c2fbf9a 100644 --- a/m4/remctl.m4 +++ b/m4/remctl.m4 @@ -13,11 +13,11 @@ dnl RRA_LIB_REMCTL_RESTORE to restore those settings to before the last dnl RRA_LIB_REMCTL_SWITCH. HAVE_REMCTL will always be defined if dnl RRA_LIB_REMCTL is used. dnl -dnl Provides the RRA_LIB_REMCTL_OPTIONAL macro, which should be used if -dnl Kerberos support is optional. This macro will still always est the -dnl substitution variables, but they'll be empty unless --with-remctl is -dnl given. HAVE_REMCTL will be defined if --with-remctl is given and -dnl $rra_use_remctl will be set to "true". +dnl Provides the RRA_LIB_REMCTL_OPTIONAL macro, which should be used if remctl +dnl support is optional. This macro will still always set the substitution +dnl variables described above, but they'll be empty unless remctl libraries +dnl are found. Defines HAVE_REMCTL and sets rra_use_remctl to true if the +dnl remctl library is found. dnl dnl Depends on RRA_ENABLE_REDUCED_DEPENDS, RRA_SET_LDFLAGS, and dnl RRA_LIB_GSSAPI. @@ -26,7 +26,7 @@ dnl The canonical version of this file is maintained in the rra-c-util dnl package, available at . dnl dnl Written by Russ Allbery -dnl Copyright 2008, 2009, 2011 +dnl Copyright 2008, 2009, 2011, 2013 dnl The Board of Trustees of the Leland Stanford Junior University dnl dnl This file is free software; the authors give unlimited permission to copy @@ -119,6 +119,7 @@ AC_DEFUN([RRA_LIB_REMCTL], [AS_IF([test x"$withval" != xyes && test x"$withval" != xno], [rra_remctl_libdir="$withval"])]) _RRA_LIB_REMCTL_INTERNAL([true]) + rra_use_remctl=true AC_DEFINE([HAVE_REMCTL], 1, [Define to enable remctl features.])]) dnl The main macro for packages with optional remctl support. diff --git a/portable/asprintf.c b/portable/asprintf.c index 7bdfd0d..eb2b713 100644 --- a/portable/asprintf.c +++ b/portable/asprintf.c @@ -21,6 +21,8 @@ #include #include +#include + /* * If we're running the test suite, rename the functions to avoid conflicts * with the system versions. @@ -33,6 +35,7 @@ int test_asprintf(char **, const char *, ...) int test_vasprintf(char **, const char *, va_list); #endif + int asprintf(char **strp, const char *fmt, ...) { @@ -45,11 +48,12 @@ asprintf(char **strp, const char *fmt, ...) return status; } + int vasprintf(char **strp, const char *fmt, va_list args) { va_list args_copy; - int status, needed; + int status, needed, oerrno; va_copy(args_copy, args); needed = vsnprintf(NULL, 0, fmt, args_copy); @@ -65,8 +69,10 @@ vasprintf(char **strp, const char *fmt, va_list args) if (status >= 0) return status; else { + oerrno = errno; free(*strp); *strp = NULL; + errno = oerrno; return status; } } diff --git a/portable/dummy.c b/portable/dummy.c index f2ac917..890bc0c 100644 --- a/portable/dummy.c +++ b/portable/dummy.c @@ -19,8 +19,10 @@ * work. */ -/* Prototype to avoid gcc warnings. */ -int portable_dummy(void); +#include + +/* Prototype to avoid gcc warnings and set visibility. */ +int portable_dummy(void) __attribute__((__visibility__("hidden"))); int portable_dummy(void) diff --git a/portable/krb5.h b/portable/krb5.h index a3cb173..6dfffd5 100644 --- a/portable/krb5.h +++ b/portable/krb5.h @@ -113,4 +113,6 @@ const char *krb5_principal_get_realm(krb5_context, krb5_const_principal); /* Undo default visibility change. */ #pragma GCC visibility pop +END_DECLS + #endif /* !PORTABLE_KRB5_H */ diff --git a/portable/reallocarray.c b/portable/reallocarray.c new file mode 100644 index 0000000..7d40a7a --- /dev/null +++ b/portable/reallocarray.c @@ -0,0 +1,56 @@ +/* + * Replacement for a missing reallocarray. + * + * Provides the same functionality as the OpenBSD library function reallocrray + * for those systems that don't have it. This function is the same as + * realloc, but takes the size arguments in the same form as calloc and checks + * for overflow so that the caller doesn't need to. + * + * The canonical version of this file is maintained in the rra-c-util package, + * which can be found at . + * + * Written by Russ Allbery + * + * The authors hereby relinquish any claim to any copyright that they may have + * in this work, whether granted under contract or by operation of law or + * international treaty, and hereby commit to the public, at large, that they + * shall not, at any time in the future, seek to enforce any copyright in this + * work against any person or entity, or prevent any person or entity from + * copying, publishing, distributing or creating derivative works of this + * work. + */ + +#include +#include + +#include + +/* + * If we're running the test suite, rename reallocarray to avoid conflicts + * with the system version. #undef it first because some systems may define + * it to another name. + */ +#if TESTING +# undef reallocarray +# define reallocarray test_reallocarray +void *test_reallocarray(void *, size_t, size_t); +#endif + +/* + * nmemb * size cannot overflow if both are smaller than sqrt(SIZE_MAX). We + * can calculate that value statically by using 2^(sizeof(size_t) * 8) as the + * value of SIZE_MAX and then taking the square root, which gives + * 2^(sizeof(size_t) * 4). Compute the exponentiation with shift. + */ +#define CHECK_THRESHOLD (1UL << (sizeof(size_t) * 4)) + +void * +reallocarray(void *ptr, size_t nmemb, size_t size) +{ + if (nmemb >= CHECK_THRESHOLD || size >= CHECK_THRESHOLD) + if (nmemb > 0 && SIZE_MAX / nmemb <= size) { + errno = ENOMEM; + return NULL; + } + return realloc(ptr, nmemb * size); +} diff --git a/portable/snprintf.c b/portable/snprintf.c index 225455b..c35ad80 100644 --- a/portable/snprintf.c +++ b/portable/snprintf.c @@ -2,8 +2,9 @@ * Replacement for a missing snprintf or vsnprintf. * * The following implementation of snprintf was taken mostly verbatim from - * ; it is the version of snprintf - * used in Mutt. + * ; it is the version of snprintf + * used in Mutt. A possibly newer version is used in wget, found at + * . * * Please do not reformat or otherwise change this file more than necessary so * that later merges with the original source are easy. Bug fixes and @@ -432,7 +433,7 @@ static int dopr (char *buffer, size_t maxlen, const char *format, va_list args) break; case 'w': /* not supported yet, treat as next char */ - ch = *format++; + format++; break; default: /* Unknown, skip */ @@ -695,7 +696,7 @@ static int fmtfp (char *buffer, size_t *currlen, size_t maxlen, /* For each leading 0 in fractional part, print one more fractional digit. */ LDOUBLE temp; - if (ufvalue != 0) + if (ufvalue > 0) for (temp = ufvalue; temp < 0.1; temp *= 10) ++max; } diff --git a/portable/system.h b/portable/system.h index 3be86dd..544b2de 100644 --- a/portable/system.h +++ b/portable/system.h @@ -5,15 +5,17 @@ * file is the equivalent of including all of the following headers, * portably: * - * #include + * #include + * #include * #include * #include + * #include * #include * #include - * #include * #include * #include * #include + * #include * #include * * Missing functions are provided via #define or prototyped if available from @@ -43,21 +45,22 @@ #include /* A set of standard ANSI C headers. We don't care about pre-ANSI systems. */ +#if HAVE_INTTYPES_H +# include +#endif +#include #include #include +#if HAVE_STDINT_H +# include +#endif #include #include -#include #include #if HAVE_STRINGS_H # include #endif -#if HAVE_INTTYPES_H -# include -#endif -#if HAVE_STDINT_H -# include -#endif +#include #if HAVE_UNISTD_H # include #endif @@ -127,6 +130,9 @@ extern int vsnprintf(char *, size_t, const char *, va_list); #if !HAVE_MKSTEMP extern int mkstemp(char *); #endif +#if !HAVE_REALLOCARRAY +extern void *reallocarray(void *, size_t, size_t); +#endif #if !HAVE_SETENV extern int setenv(const char *, const char *, int); #endif diff --git a/tests/docs/pod-spelling-t b/tests/docs/pod-spelling-t index 1a02af8..7b61c86 100755 --- a/tests/docs/pod-spelling-t +++ b/tests/docs/pod-spelling-t @@ -1,14 +1,12 @@ #!/usr/bin/perl # # Checks all POD files in the tree for spelling errors using Test::Spelling. -# This test is disabled unless RRA_MAINTAINER_TESTS is set, since spelling -# dictionaries vary too much between environments. # # The canonical version of this file is maintained in the rra-c-util package, # which can be found at . # # Written by Russ Allbery -# Copyright 2012, 2013 +# Copyright 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # Permission is hereby granted, free of charge, to any person obtaining a @@ -36,11 +34,12 @@ use warnings; use lib "$ENV{SOURCE}/tap/perl"; use Test::More; -use Test::RRA qw(skip_unless_maintainer use_prereq); +use Test::RRA qw(skip_unless_author use_prereq); use Test::RRA::Automake qw(automake_setup perl_dirs); -# Only run this test for the maintainer. -skip_unless_maintainer('Spelling tests'); +# Only run this test for the module author since the required stopwords are +# too sensitive to the exact spell-checking program and dictionary. +skip_unless_author('Spelling tests'); # Load prerequisite modules. use_prereq('Test::Spelling'); diff --git a/tests/docs/pod-t b/tests/docs/pod-t index 6918271..53f9925 100755 --- a/tests/docs/pod-t +++ b/tests/docs/pod-t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Check all POD documents in the tree, except for any embedded Perl module # distribution, for POD formatting errors. @@ -7,7 +7,7 @@ # which can be found at . # # Written by Russ Allbery -# Copyright 2012, 2013 +# Copyright 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # Permission is hereby granted, free of charge, to any person obtaining a @@ -35,9 +35,13 @@ use warnings; use lib "$ENV{SOURCE}/tap/perl"; use Test::More; -use Test::RRA qw(use_prereq); +use Test::RRA qw(skip_unless_automated use_prereq); use Test::RRA::Automake qw(automake_setup perl_dirs); +# Skip this test for normal user installs, since we normally pre-generate all +# of the documentation and the end user doesn't care. +skip_unless_automated('POD syntax tests'); + # Load prerequisite modules. use_prereq('Test::Pod'); diff --git a/tests/runtests.c b/tests/runtests.c index 3756aa6..a9d2373 100644 --- a/tests/runtests.c +++ b/tests/runtests.c @@ -54,8 +54,8 @@ * should be sent to the e-mail address below. This program is part of C TAP * Harness . * - * Copyright 2000, 2001, 2004, 2006, 2007, 2008, 2009, 2010, 2011 - * Russ Allbery + * Copyright 2000, 2001, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, + * 2014 Russ Allbery * * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), @@ -86,7 +86,9 @@ #include #include #include +#include #include +#include #include #include #include @@ -101,11 +103,28 @@ /* sys/time.h must be included before sys/resource.h on some platforms. */ #include -/* AIX doesn't have WCOREDUMP. */ +/* AIX 6.1 (and possibly later) doesn't have WCOREDUMP. */ #ifndef WCOREDUMP -# define WCOREDUMP(status) ((unsigned)(status) & 0x80) +# define WCOREDUMP(status) ((unsigned)(status) & 0x80) #endif +/* + * POSIX requires that these be defined in , but they're not always + * available. If one of them has been defined, all the rest almost certainly + * have. + */ +#ifndef STDIN_FILENO +# define STDIN_FILENO 0 +# define STDOUT_FILENO 1 +# define STDERR_FILENO 2 +#endif + +/* + * Used for iterating through arrays. Returns the number of elements in the + * array (useful for a < upper bound in a for loop). + */ +#define ARRAY_SIZE(array) (sizeof(array) / sizeof((array)[0])) + /* * The source and build versions of the tests directory. This is used to set * the SOURCE and BUILD environment variables and find test programs, if set. @@ -138,7 +157,8 @@ enum plan_status { /* Error exit statuses for test processes. */ #define CHILDERR_DUP 100 /* Couldn't redirect stderr or stdout. */ #define CHILDERR_EXEC 101 /* Couldn't exec child process. */ -#define CHILDERR_STDERR 102 /* Couldn't open stderr file. */ +#define CHILDERR_STDIN 102 /* Couldn't open stdin file. */ +#define CHILDERR_STDERR 103 /* Couldn't open stderr file. */ /* Structure to hold data for a set of tests. */ struct testset { @@ -153,7 +173,7 @@ struct testset { unsigned long skipped; /* Count of skipped tests (passed). */ unsigned long allocated; /* The size of the results table. */ enum test_status *results; /* Table of results by test number. */ - unsigned int aborted; /* Whether the set as aborted. */ + unsigned int aborted; /* Whether the set was aborted. */ int reported; /* Whether the results were reported. */ int status; /* The exit status of the test. */ unsigned int all_skipped; /* Whether all tests were skipped. */ @@ -167,21 +187,25 @@ struct testlist { }; /* - * Usage message. Should be used as a printf format with two arguments: the - * path to runtests, given twice. + * Usage message. Should be used as a printf format with four arguments: the + * path to runtests, given three times, and the usage_description. This is + * split into variables to satisfy the pedantic ISO C90 limit on strings. */ static const char usage_message[] = "\ -Usage: %s [-b ] [-s ] \n\ +Usage: %s [-b ] [-s ] ...\n\ + %s [-b ] [-s ] -l \n\ %s -o [-b ] [-s ] \n\ -\n\ +\n%s"; +static const char usage_extra[] = "\ Options:\n\ -b Set the build directory to \n\ + -l Take the list of tests to run from \n\ -o Run a single test rather than a list of tests\n\ -s Set the source directory to \n\ \n\ -runtests normally runs each test listed in a file whose path is given as\n\ -its command-line argument. With the -o option, it instead runs a single\n\ -test and shows its complete output.\n"; +runtests normally runs each test listed on the command line. With the -l\n\ +option, it instead runs every test listed in a file. With the -o option,\n\ +it instead runs a single test and shows its complete output.\n"; /* * Header used for test output. %s is replaced by the file name of the list @@ -197,9 +221,57 @@ Failed Set Fail/Total (%) Skip Stat Failing Tests\n\ -------------------------- -------------- ---- ---- ------------------------"; /* Include the file name and line number in malloc failures. */ -#define xmalloc(size) x_malloc((size), __FILE__, __LINE__) -#define xrealloc(p, size) x_realloc((p), (size), __FILE__, __LINE__) -#define xstrdup(p) x_strdup((p), __FILE__, __LINE__) +#define xcalloc(n, size) x_calloc((n), (size), __FILE__, __LINE__) +#define xmalloc(size) x_malloc((size), __FILE__, __LINE__) +#define xstrdup(p) x_strdup((p), __FILE__, __LINE__) +#define xreallocarray(p, n, size) \ + x_reallocarray((p), (n), (size), __FILE__, __LINE__) + +/* + * __attribute__ is available in gcc 2.5 and later, but only with gcc 2.7 + * could you use the __format__ form of the attributes, which is what we use + * (to avoid confusion with other macros). + */ +#ifndef __attribute__ +# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 7) +# define __attribute__(spec) /* empty */ +# endif +#endif + +/* + * We use __alloc_size__, but it was only available in fairly recent versions + * of GCC. Suppress warnings about the unknown attribute if GCC is too old. + * We know that we're GCC at this point, so we can use the GCC variadic macro + * extension, which will still work with versions of GCC too old to have C99 + * variadic macro support. + */ +#if !defined(__attribute__) && !defined(__alloc_size__) +# if __GNUC__ < 4 || (__GNUC__ == 4 && __GNUC_MINOR__ < 3) +# define __alloc_size__(spec, args...) /* empty */ +# endif +#endif + +/* + * LLVM and Clang pretend to be GCC but don't support all of the __attribute__ + * settings that GCC does. For them, suppress warnings about unknown + * attributes on declarations. This unfortunately will affect the entire + * compilation context, but there's no push and pop available. + */ +#if !defined(__attribute__) && (defined(__llvm__) || defined(__clang__)) +# pragma GCC diagnostic ignored "-Wattributes" +#endif + +/* Declare internal functions that benefit from compiler attributes. */ +static void sysdie(const char *, ...) + __attribute__((__nonnull__, __noreturn__, __format__(printf, 1, 2))); +static void *x_calloc(size_t, size_t, const char *, int) + __attribute__((__alloc_size__(1, 2), __malloc__, __nonnull__)); +static void *x_malloc(size_t, const char *, int) + __attribute__((__alloc_size__(1), __malloc__, __nonnull__)); +static void *x_reallocarray(void *, size_t, size_t, const char *, int) + __attribute__((__alloc_size__(2, 3), __malloc__, __nonnull__(4))); +static char *x_strdup(const char *, const char *, int) + __attribute__((__malloc__, __nonnull__)); /* @@ -222,6 +294,24 @@ sysdie(const char *format, ...) } +/* + * Allocate zeroed memory, reporting a fatal error and exiting on failure. + */ +static void * +x_calloc(size_t n, size_t size, const char *file, int line) +{ + void *p; + + n = (n > 0) ? n : 1; + size = (size > 0) ? size : 1; + p = calloc(n, size); + if (p == NULL) + sysdie("failed to calloc %lu bytes at %s line %d", + (unsigned long) size, file, line); + return p; +} + + /* * Allocate memory, reporting a fatal error and exiting on failure. */ @@ -240,14 +330,26 @@ x_malloc(size_t size, const char *file, int line) /* * Reallocate memory, reporting a fatal error and exiting on failure. + * + * We should technically use SIZE_MAX here for the overflow check, but + * SIZE_MAX is C99 and we're only assuming C89 + SUSv3, which does not + * guarantee that it exists. They do guarantee that UINT_MAX exists, and we + * can assume that UINT_MAX <= SIZE_MAX. And we should not be allocating + * anything anywhere near that large. + * + * (In theory, C89 and C99 permit size_t to be smaller than unsigned int, but + * I disbelieve in the existence of such systems and they will have to cope + * without overflow checks.) */ static void * -x_realloc(void *p, size_t size, const char *file, int line) +x_reallocarray(void *p, size_t n, size_t size, const char *file, int line) { - p = realloc(p, size); + if (n > 0 && UINT_MAX / n <= size) + sysdie("realloc too large at %s line %d", file, line); + p = realloc(p, n * size); if (p == NULL) sysdie("failed to realloc %lu bytes at %s line %d", - (unsigned long) size, file, line); + (unsigned long) (n * size), file, line); return p; } @@ -271,6 +373,55 @@ x_strdup(const char *s, const char *file, int line) } +/* + * Form a new string by concatenating multiple strings. The arguments must be + * terminated by (const char *) 0. + * + * This function only exists because we can't assume asprintf. We can't + * simulate asprintf with snprintf because we're only assuming SUSv3, which + * does not require that snprintf with a NULL buffer return the required + * length. When those constraints are relaxed, this should be ripped out and + * replaced with asprintf or a more trivial replacement with snprintf. + */ +static char * +concat(const char *first, ...) +{ + va_list args; + char *result; + const char *string; + size_t offset; + size_t length = 0; + + /* + * Find the total memory required. Ensure we don't overflow length. We + * aren't guaranteed to have SIZE_MAX, so use UINT_MAX as an acceptable + * substitute (see the x_nrealloc comments). + */ + va_start(args, first); + for (string = first; string != NULL; string = va_arg(args, const char *)) { + if (length >= UINT_MAX - strlen(string)) { + errno = EINVAL; + sysdie("strings too long in concat"); + } + length += strlen(string); + } + va_end(args); + length++; + + /* Create the string. */ + result = xmalloc(length); + va_start(args, first); + offset = 0; + for (string = first; string != NULL; string = va_arg(args, const char *)) { + memcpy(result + offset, string, strlen(string)); + offset += strlen(string); + } + va_end(args); + result[offset] = '\0'; + return result; +} + + /* * Given a struct timeval, return the number of seconds it represents as a * double. Use difftime() to convert a time_t to a double. @@ -323,36 +474,62 @@ skip_whitespace(const char *p) static pid_t test_start(const char *path, int *fd) { - int fds[2], errfd; + int fds[2], infd, errfd; pid_t child; + /* Create a pipe used to capture the output from the test program. */ if (pipe(fds) == -1) { puts("ABORTED"); fflush(stdout); sysdie("can't create pipe"); } + + /* Fork a child process, massage the file descriptors, and exec. */ child = fork(); - if (child == (pid_t) -1) { + switch (child) { + case -1: puts("ABORTED"); fflush(stdout); sysdie("can't fork"); - } else if (child == 0) { - /* In child. Set up our stdout and stderr. */ + + /* In the child. Set up our standard output. */ + case 0: + close(fds[0]); + close(STDOUT_FILENO); + if (dup2(fds[1], STDOUT_FILENO) < 0) + _exit(CHILDERR_DUP); + close(fds[1]); + + /* Point standard input at /dev/null. */ + close(STDIN_FILENO); + infd = open("/dev/null", O_RDONLY); + if (infd < 0) + _exit(CHILDERR_STDIN); + if (infd != STDIN_FILENO) { + if (dup2(infd, STDIN_FILENO) < 0) + _exit(CHILDERR_DUP); + close(infd); + } + + /* Point standard error at /dev/null. */ + close(STDERR_FILENO); errfd = open("/dev/null", O_WRONLY); if (errfd < 0) _exit(CHILDERR_STDERR); - if (dup2(errfd, 2) == -1) - _exit(CHILDERR_DUP); - close(fds[0]); - if (dup2(fds[1], 1) == -1) - _exit(CHILDERR_DUP); + if (errfd != STDERR_FILENO) { + if (dup2(errfd, STDERR_FILENO) < 0) + _exit(CHILDERR_DUP); + close(errfd); + } /* Now, exec our process. */ if (execl(path, path, (char *) 0) == -1) _exit(CHILDERR_EXEC); - } else { - /* In parent. Close the extra file descriptor. */ + + /* In parent. Close the extra file descriptor. */ + default: close(fds[1]); + break; } *fd = fds[0]; return child; @@ -379,6 +556,40 @@ test_backspace(struct testset *ts) } +/* + * Allocate or resize the array of test results to be large enough to contain + * the test number in. + */ +static void +resize_results(struct testset *ts, unsigned long n) +{ + unsigned long i; + size_t s; + + /* If there's already enough space, return quickly. */ + if (n <= ts->allocated) + return; + + /* + * If no space has been allocated, do the initial allocation. Otherwise, + * resize. Start with 32 test cases and then add 1024 with each resize to + * try to reduce the number of reallocations. + */ + if (ts->allocated == 0) { + s = (n > 32) ? n : 32; + ts->results = xcalloc(s, sizeof(enum test_status)); + } else { + s = (n > ts->allocated + 1024) ? n : ts->allocated + 1024; + ts->results = xreallocarray(ts->results, s, sizeof(enum test_status)); + } + + /* Set the results for the newly-allocated test array. */ + for (i = ts->allocated; i < s; i++) + ts->results[i] = TEST_INVALID; + ts->allocated = s; +} + + /* * Read the plan line of test output, which should contain the range of test * numbers. We may initialize the testset structure here if we haven't yet @@ -388,7 +599,6 @@ test_backspace(struct testset *ts) static int test_plan(const char *line, struct testset *ts) { - unsigned long i; long n; /* @@ -401,12 +611,14 @@ test_plan(const char *line, struct testset *ts) line += 3; /* - * Get the count, check it for validity, and initialize the struct. If we - * have something of the form "1..0 # skip foo", the whole file was + * Get the count and check it for validity. + * + * If we have something of the form "1..0 # skip foo", the whole file was * skipped; record that. If we do skip the whole file, zero out all of - * our statistics, since they're no longer relevant. strtol is called - * with a second argument to advance the line pointer past the count to - * make it simpler to detect the # skip case. + * our statistics, since they're no longer relevant. + * + * strtol is called with a second argument to advance the line pointer + * past the count to make it simpler to detect the # skip case. */ n = strtol(line, (char **) &line, 10); if (n == 0) { @@ -435,29 +647,30 @@ test_plan(const char *line, struct testset *ts) ts->reported = 1; return 0; } - if (ts->plan == PLAN_INIT && ts->allocated == 0) { - ts->count = n; - ts->allocated = n; + + /* + * If we are doing lazy planning, check the plan against the largest test + * number that we saw and fail now if we saw a check outside the plan + * range. + */ + if (ts->plan == PLAN_PENDING && (unsigned long) n < ts->count) { + test_backspace(ts); + printf("ABORTED (invalid test number %lu)\n", ts->count); + ts->aborted = 1; + ts->reported = 1; + return 0; + } + + /* + * Otherwise, allocated or resize the results if needed and update count, + * and then record that we've seen a plan. + */ + resize_results(ts, n); + ts->count = n; + if (ts->plan == PLAN_INIT) ts->plan = PLAN_FIRST; - ts->results = xmalloc(ts->count * sizeof(enum test_status)); - for (i = 0; i < ts->count; i++) - ts->results[i] = TEST_INVALID; - } else if (ts->plan == PLAN_PENDING) { - if ((unsigned long) n < ts->count) { - printf("ABORTED (invalid test number %lu)\n", ts->count); - ts->aborted = 1; - ts->reported = 1; - return 0; - } - ts->count = n; - if ((unsigned long) n > ts->allocated) { - ts->results = xrealloc(ts->results, n * sizeof(enum test_status)); - for (i = ts->allocated; i < ts->count; i++) - ts->results[i] = TEST_INVALID; - ts->allocated = n; - } + else if (ts->plan == PLAN_PENDING) ts->plan = PLAN_FINAL; - } return 1; } @@ -475,7 +688,7 @@ test_checkline(const char *line, struct testset *ts) const char *bail; char *end; long number; - unsigned long i, current; + unsigned long current; int outlen; /* Before anything, check for a test abort. */ @@ -516,6 +729,7 @@ test_checkline(const char *line, struct testset *ts) if (!test_plan(line, ts)) return; } else { + test_backspace(ts); puts("ABORTED (multiple plans)"); ts->aborted = 1; ts->reported = 1; @@ -547,19 +761,9 @@ test_checkline(const char *line, struct testset *ts) /* We have a valid test result. Tweak the results array if needed. */ if (ts->plan == PLAN_INIT || ts->plan == PLAN_PENDING) { ts->plan = PLAN_PENDING; + resize_results(ts, current); if (current > ts->count) ts->count = current; - if (current > ts->allocated) { - unsigned long n; - - n = (ts->allocated == 0) ? 32 : ts->allocated * 2; - if (n < current) - n = current; - ts->results = xrealloc(ts->results, n * sizeof(enum test_status)); - for (i = ts->allocated; i < n; i++) - ts->results[i] = TEST_INVALID; - ts->allocated = n; - } } /* @@ -595,9 +799,12 @@ test_checkline(const char *line, struct testset *ts) } ts->current = current; ts->results[current - 1] = status; - test_backspace(ts); if (isatty(STDOUT_FILENO)) { - outlen = printf("%lu/%lu", current, ts->count); + test_backspace(ts); + if (ts->plan == PLAN_PENDING) + outlen = printf("%lu/?", current); + else + outlen = printf("%lu/%lu", current, ts->count); ts->length = (outlen >= 0) ? outlen : 0; fflush(stdout); } @@ -754,6 +961,7 @@ test_analyze(struct testset *ts) if (!ts->reported) puts("ABORTED (execution failed -- not found?)"); break; + case CHILDERR_STDIN: case CHILDERR_STDERR: if (!ts->reported) puts("ABORTED (can't open /dev/null)"); @@ -883,109 +1091,203 @@ test_fail_summary(const struct testlist *fails) if (first != 0) test_print_range(first, last, chars, 19); putchar('\n'); - free(ts->file); - free(ts->path); - free(ts->results); - if (ts->reason != NULL) - free(ts->reason); - free(ts); } } +/* + * Check whether a given file path is a valid test. Currently, this checks + * whether it is executable and is a regular file. Returns true or false. + */ +static int +is_valid_test(const char *path) +{ + struct stat st; + + if (access(path, X_OK) < 0) + return 0; + if (stat(path, &st) < 0) + return 0; + if (!S_ISREG(st.st_mode)) + return 0; + return 1; +} + + /* * Given the name of a test, a pointer to the testset struct, and the source * and build directories, find the test. We try first relative to the current * directory, then in the build directory (if not NULL), then in the source * directory. In each of those directories, we first try a "-t" extension and - * then a ".t" extension. When we find an executable program, we fill in the - * path member of the testset struct. If none of those paths are executable, - * just fill in the name of the test with "-t" appended. + * then a ".t" extension. When we find an executable program, we return the + * path to that program. If none of those paths are executable, just fill in + * the name of the test as is. * * The caller is responsible for freeing the path member of the testset * struct. */ -static void -find_test(const char *name, struct testset *ts, const char *source, - const char *build) +static char * +find_test(const char *name, const char *source, const char *build) { char *path; - const char *bases[4]; - unsigned int i; + const char *bases[3], *suffix, *base; + unsigned int i, j; + const char *suffixes[3] = { "-t", ".t", "" }; + /* Possible base directories. */ bases[0] = "."; bases[1] = build; bases[2] = source; - bases[3] = NULL; - for (i = 0; i < 3; i++) { - if (bases[i] == NULL) - continue; - path = xmalloc(strlen(bases[i]) + strlen(name) + 4); - sprintf(path, "%s/%s-t", bases[i], name); - if (access(path, X_OK) != 0) - path[strlen(path) - 2] = '.'; - if (access(path, X_OK) == 0) - break; - free(path); - path = NULL; + /* Try each suffix with each base. */ + for (i = 0; i < ARRAY_SIZE(suffixes); i++) { + suffix = suffixes[i]; + for (j = 0; j < ARRAY_SIZE(bases); j++) { + base = bases[j]; + if (base == NULL) + continue; + path = concat(base, "/", name, suffix, (const char *) 0); + if (is_valid_test(path)) + return path; + free(path); + path = NULL; + } } - if (path == NULL) { - path = xmalloc(strlen(name) + 3); - sprintf(path, "%s-t", name); + if (path == NULL) + path = xstrdup(name); + return path; +} + + +/* + * Read a list of tests from a file, returning the list of tests as a struct + * testlist. Reports an error to standard error and exits if the list of + * tests cannot be read. + */ +static struct testlist * +read_test_list(const char *filename) +{ + FILE *file; + unsigned int line; + size_t length; + char buffer[BUFSIZ]; + struct testlist *listhead, *current; + + /* Create the initial container list that will hold our results. */ + listhead = xcalloc(1, sizeof(struct testlist)); + current = NULL; + + /* + * Open our file of tests to run and read it line by line, creating a new + * struct testlist and struct testset for each line. + */ + file = fopen(filename, "r"); + if (file == NULL) + sysdie("can't open %s", filename); + line = 0; + while (fgets(buffer, sizeof(buffer), file)) { + line++; + length = strlen(buffer) - 1; + if (buffer[length] != '\n') { + fprintf(stderr, "%s:%u: line too long\n", filename, line); + exit(1); + } + buffer[length] = '\0'; + if (current == NULL) + current = listhead; + else { + current->next = xcalloc(1, sizeof(struct testlist)); + current = current->next; + } + current->ts = xcalloc(1, sizeof(struct testset)); + current->ts->plan = PLAN_INIT; + current->ts->file = xstrdup(buffer); } - ts->path = path; + fclose(file); + + /* Return the results. */ + return listhead; } /* - * Run a batch of tests from a given file listing each test on a line by - * itself. Takes two additional parameters: the root of the source directory - * and the root of the build directory. Test programs will be first searched - * for in the current directory, then the build directory, then the source - * directory. The file must be rewindable. Returns true iff all tests - * passed. + * Build a list of tests from command line arguments. Takes the argv and argc + * representing the command line arguments and returns a newly allocated test + * list. The caller is responsible for freeing. + */ +static struct testlist * +build_test_list(char *argv[], int argc) +{ + int i; + struct testlist *listhead, *current; + + /* Create the initial container list that will hold our results. */ + listhead = xcalloc(1, sizeof(struct testlist)); + current = NULL; + + /* Walk the list of arguments and create test sets for them. */ + for (i = 0; i < argc; i++) { + if (current == NULL) + current = listhead; + else { + current->next = xcalloc(1, sizeof(struct testlist)); + current = current->next; + } + current->ts = xcalloc(1, sizeof(struct testset)); + current->ts->plan = PLAN_INIT; + current->ts->file = xstrdup(argv[i]); + } + + /* Return the results. */ + return listhead; +} + + +/* Free a struct testset. */ +static void +free_testset(struct testset *ts) +{ + free(ts->file); + free(ts->path); + free(ts->results); + free(ts->reason); + free(ts); +} + + +/* + * Run a batch of tests. Takes two additional parameters: the root of the + * source directory and the root of the build directory. Test programs will + * be first searched for in the current directory, then the build directory, + * then the source directory. Returns true iff all tests passed, and always + * frees the test list that's passed in. */ static int -test_batch(const char *testlist, const char *source, const char *build) +test_batch(struct testlist *tests, const char *source, const char *build) { - FILE *tests; - unsigned int length, i; + size_t length; + unsigned int i; unsigned int longest = 0; - char buffer[BUFSIZ]; - unsigned int line; - struct testset ts, *tmp; + unsigned int count = 0; + struct testset *ts; struct timeval start, end; struct rusage stats; struct testlist *failhead = NULL; struct testlist *failtail = NULL; - struct testlist *next; + struct testlist *current, *next; + int succeeded; unsigned long total = 0; unsigned long passed = 0; unsigned long skipped = 0; unsigned long failed = 0; unsigned long aborted = 0; - /* - * Open our file of tests to run and scan it, checking for lines that - * are too long and searching for the longest line. - */ - tests = fopen(testlist, "r"); - if (!tests) - sysdie("can't open %s", testlist); - line = 0; - while (fgets(buffer, sizeof(buffer), tests)) { - line++; - length = strlen(buffer) - 1; - if (buffer[length] != '\n') { - fprintf(stderr, "%s:%u: line too long\n", testlist, line); - exit(1); - } + /* Walk the list of tests to find the longest name. */ + for (current = tests; current != NULL; current = current->next) { + length = strlen(current->ts->file); if (length > longest) longest = length; } - if (fseek(tests, 0, SEEK_SET) == -1) - sysdie("can't rewind %s", testlist); /* * Add two to longest and round up to the nearest tab stop. This is how @@ -998,64 +1300,50 @@ test_batch(const char *testlist, const char *source, const char *build) /* Start the wall clock timer. */ gettimeofday(&start, NULL); - /* - * Now, plow through our tests again, running each one. Check line - * length again out of paranoia. - */ - line = 0; - while (fgets(buffer, sizeof(buffer), tests)) { - line++; - length = strlen(buffer) - 1; - if (buffer[length] != '\n') { - fprintf(stderr, "%s:%u: line too long\n", testlist, line); - exit(1); - } - buffer[length] = '\0'; - fputs(buffer, stdout); - for (i = length; i < longest; i++) + /* Now, plow through our tests again, running each one. */ + for (current = tests; current != NULL; current = current->next) { + ts = current->ts; + + /* Print out the name of the test file. */ + fputs(ts->file, stdout); + for (i = strlen(ts->file); i < longest; i++) putchar('.'); if (isatty(STDOUT_FILENO)) fflush(stdout); - memset(&ts, 0, sizeof(ts)); - ts.plan = PLAN_INIT; - ts.file = xstrdup(buffer); - find_test(buffer, &ts, source, build); - ts.reason = NULL; - if (test_run(&ts)) { - free(ts.file); - free(ts.path); - free(ts.results); - if (ts.reason != NULL) - free(ts.reason); - } else { - tmp = xmalloc(sizeof(struct testset)); - memcpy(tmp, &ts, sizeof(struct testset)); - if (!failhead) { + + /* Run the test. */ + ts->path = find_test(ts->file, source, build); + succeeded = test_run(ts); + fflush(stdout); + + /* Record cumulative statistics. */ + aborted += ts->aborted; + total += ts->count + ts->all_skipped; + passed += ts->passed; + skipped += ts->skipped + ts->all_skipped; + failed += ts->failed; + count++; + + /* If the test fails, we shuffle it over to the fail list. */ + if (!succeeded) { + if (failhead == NULL) { failhead = xmalloc(sizeof(struct testset)); - failhead->ts = tmp; - failhead->next = NULL; failtail = failhead; } else { failtail->next = xmalloc(sizeof(struct testset)); failtail = failtail->next; - failtail->ts = tmp; - failtail->next = NULL; } + failtail->ts = ts; + failtail->next = NULL; } - aborted += ts.aborted; - total += ts.count + ts.all_skipped; - passed += ts.passed; - skipped += ts.skipped + ts.all_skipped; - failed += ts.failed; } total -= skipped; - fclose(tests); /* Stop the timer and get our child resource statistics. */ gettimeofday(&end, NULL); getrusage(RUSAGE_CHILDREN, &stats); - /* Print out our final results. */ + /* Summarize the failures and free the failure list. */ if (failhead != NULL) { test_fail_summary(failhead); while (failhead != NULL) { @@ -1064,6 +1352,16 @@ test_batch(const char *testlist, const char *source, const char *build) failhead = next; } } + + /* Free the memory used by the test lists. */ + while (tests != NULL) { + next = tests->next; + free_testset(tests->ts); + free(tests); + tests = next; + } + + /* Print out the final test summary. */ putchar('\n'); if (aborted != 0) { if (aborted == 1) @@ -1084,7 +1382,7 @@ test_batch(const char *testlist, const char *source, const char *build) printf(", %lu tests skipped", skipped); } puts("."); - printf("Files=%u, Tests=%lu", line, total); + printf("Files=%u, Tests=%lu", count, total); printf(", %.2f seconds", tv_diff(&end, &start)); printf(" (%.2f usr + %.2f sys = %.2f CPU)\n", tv_seconds(&stats.ru_utime), tv_seconds(&stats.ru_stime), @@ -1100,12 +1398,11 @@ test_batch(const char *testlist, const char *source, const char *build) static void test_single(const char *program, const char *source, const char *build) { - struct testset ts; + char *path; - memset(&ts, 0, sizeof(ts)); - find_test(program, &ts, source, build); - if (execl(ts.path, ts.path, (char *) 0) == -1) - sysdie("cannot exec %s", ts.path); + path = find_test(program, source, build); + if (execl(path, path, (char *) 0) == -1) + sysdie("cannot exec %s", path); } @@ -1121,19 +1418,24 @@ main(int argc, char *argv[]) int single = 0; char *source_env = NULL; char *build_env = NULL; - const char *list; + const char *shortlist; + const char *list = NULL; const char *source = SOURCE; const char *build = BUILD; + struct testlist *tests; - while ((option = getopt(argc, argv, "b:hos:")) != EOF) { + while ((option = getopt(argc, argv, "b:hl:os:")) != EOF) { switch (option) { case 'b': build = optarg; break; case 'h': - printf(usage_message, argv[0], argv[0]); + printf(usage_message, argv[0], argv[0], argv[0], usage_extra); exit(0); break; + case 'l': + list = optarg; + break; case 'o': single = 1; break; @@ -1144,39 +1446,43 @@ main(int argc, char *argv[]) exit(1); } } - if (argc - optind != 1) { - fprintf(stderr, usage_message, argv[0], argv[0]); + argv += optind; + argc -= optind; + if ((list == NULL && argc < 1) || (list != NULL && argc > 0)) { + fprintf(stderr, usage_message, argv[0], argv[0], argv[0], usage_extra); exit(1); } - argc -= optind; - argv += optind; + /* Set SOURCE and BUILD environment variables. */ if (source != NULL) { - source_env = xmalloc(strlen("SOURCE=") + strlen(source) + 1); - sprintf(source_env, "SOURCE=%s", source); + source_env = concat("SOURCE=", source, (const char *) 0); if (putenv(source_env) != 0) sysdie("cannot set SOURCE in the environment"); } if (build != NULL) { - build_env = xmalloc(strlen("BUILD=") + strlen(build) + 1); - sprintf(build_env, "BUILD=%s", build); + build_env = concat("BUILD=", build, (const char *) 0); if (putenv(build_env) != 0) sysdie("cannot set BUILD in the environment"); } + /* Run the tests as instructed. */ if (single) test_single(argv[0], source, build); - else { - list = strrchr(argv[0], '/'); - if (list == NULL) - list = argv[0]; + else if (list != NULL) { + shortlist = strrchr(list, '/'); + if (shortlist == NULL) + shortlist = list; else - list++; - printf(banner, list); - status = test_batch(argv[0], source, build) ? 0 : 1; + shortlist++; + printf(banner, shortlist); + tests = read_test_list(list); + status = test_batch(tests, source, build) ? 0 : 1; + } else { + tests = build_test_list(argv, argc); + status = test_batch(tests, source, build) ? 0 : 1; } - /* For valgrind cleanliness. */ + /* For valgrind cleanliness, free all our memory. */ if (source_env != NULL) { putenv((char *) "SOURCE="); free(source_env); diff --git a/tests/tap/basic.c b/tests/tap/basic.c index 70ee093..92a749b 100644 --- a/tests/tap/basic.c +++ b/tests/tap/basic.c @@ -12,8 +12,8 @@ * This file is part of C TAP Harness. The current version plus supporting * documentation is at . * - * Copyright 2009, 2010, 2011, 2012 Russ Allbery - * Copyright 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2011, 2012 + * Copyright 2009, 2010, 2011, 2012, 2013, 2014 Russ Allbery + * Copyright 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2011, 2012, 2013, 2014 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -36,6 +36,7 @@ */ #include +#include #include #include #include @@ -58,7 +59,7 @@ /* * The test count. Always contains the number that will be used for the next - * test status. + * test status. This is exported to callers of the library. */ unsigned long testnum = 1; @@ -66,72 +67,298 @@ unsigned long testnum = 1; * Status information stored so that we can give a test summary at the end of * the test case. We store the planned final test and the count of failures. * We can get the highest test count from testnum. - * - * We also store the PID of the process that called plan() and only summarize - * results when that process exits, so as to not misreport results in forked - * processes. - * - * If _lazy is true, we're doing lazy planning and will print out the plan - * based on the last test number at the end of testing. */ static unsigned long _planned = 0; static unsigned long _failed = 0; + +/* + * Store the PID of the process that called plan() and only summarize + * results when that process exits, so as to not misreport results in forked + * processes. + */ static pid_t _process = 0; + +/* + * If true, we're doing lazy planning and will print out the plan based on the + * last test number at the end of testing. + */ static int _lazy = 0; +/* + * If true, the test was aborted by calling bail(). Currently, this is only + * used to ensure that we pass a false value to any cleanup functions even if + * all tests to that point have passed. + */ +static int _aborted = 0; + +/* + * Registered cleanup functions. These are stored as a linked list and run in + * registered order by finish when the test program exits. Each function is + * passed a boolean value indicating whether all tests were successful. + */ +struct cleanup_func { + test_cleanup_func func; + struct cleanup_func *next; +}; +static struct cleanup_func *cleanup_funcs = NULL; + +/* + * Registered diag files. Any output found in these files will be printed out + * as if it were passed to diag() before any other output we do. This allows + * background processes to log to a file and have that output interleved with + * the test output. + */ +struct diag_file { + char *name; + FILE *file; + char *buffer; + size_t bufsize; + struct diag_file *next; +}; +static struct diag_file *diag_files = NULL; + +/* + * Print a specified prefix and then the test description. Handles turning + * the argument list into a va_args structure suitable for passing to + * print_desc, which has to be done in a macro. Assumes that format is the + * argument immediately before the variadic arguments. + */ +#define PRINT_DESC(prefix, format) \ + do { \ + if (format != NULL) { \ + va_list args; \ + if (prefix != NULL) \ + printf("%s", prefix); \ + va_start(args, format); \ + vprintf(format, args); \ + va_end(args); \ + } \ + } while (0) + + +/* + * Form a new string by concatenating multiple strings. The arguments must be + * terminated by (const char *) 0. + * + * This function only exists because we can't assume asprintf. We can't + * simulate asprintf with snprintf because we're only assuming SUSv3, which + * does not require that snprintf with a NULL buffer return the required + * length. When those constraints are relaxed, this should be ripped out and + * replaced with asprintf or a more trivial replacement with snprintf. + */ +static char * +concat(const char *first, ...) +{ + va_list args; + char *result; + const char *string; + size_t offset; + size_t length = 0; + + /* + * Find the total memory required. Ensure we don't overflow length. See + * the comment for breallocarray for why we're using UINT_MAX here. + */ + va_start(args, first); + for (string = first; string != NULL; string = va_arg(args, const char *)) { + if (length >= UINT_MAX - strlen(string)) + bail("strings too long in concat"); + length += strlen(string); + } + va_end(args); + length++; + + /* Create the string. */ + result = bmalloc(length); + va_start(args, first); + offset = 0; + for (string = first; string != NULL; string = va_arg(args, const char *)) { + memcpy(result + offset, string, strlen(string)); + offset += strlen(string); + } + va_end(args); + result[offset] = '\0'; + return result; +} + + +/* + * Check all registered diag_files for any output. We only print out the + * output if we see a complete line; otherwise, we wait for the next newline. + */ +static void +check_diag_files(void) +{ + struct diag_file *file; + fpos_t where; + size_t length; + int incomplete; + + /* + * Walk through each file and read each line of output available. The + * general scheme here used is as follows: try to read a line of output at + * a time. If we get NULL, check for EOF; on EOF, advance to the next + * file. + * + * If we get some data, see if it ends in a newline. If it doesn't end in + * a newline, we have one of two cases: our buffer isn't large enough, in + * which case we resize it and try again, or we have incomplete data in + * the file, in which case we rewind the file and will try again next + * time. + */ + for (file = diag_files; file != NULL; file = file->next) { + clearerr(file->file); + + /* Store the current position in case we have to rewind. */ + if (fgetpos(file->file, &where) < 0) + sysbail("cannot get position in %s", file->name); + + /* Continue until we get EOF or an incomplete line of data. */ + incomplete = 0; + while (!feof(file->file) && !incomplete) { + if (fgets(file->buffer, file->bufsize, file->file) == NULL) { + if (ferror(file->file)) + sysbail("cannot read from %s", file->name); + continue; + } + + /* + * See if the line ends in a newline. If not, see which error + * case we have. Use UINT_MAX as a substitute for SIZE_MAX (see + * the comment for breallocarray). + */ + length = strlen(file->buffer); + if (file->buffer[length - 1] != '\n') { + if (length < file->bufsize - 1) + incomplete = 1; + else { + if (file->bufsize >= UINT_MAX - BUFSIZ) + sysbail("line too long in %s", file->name); + file->bufsize += BUFSIZ; + file->buffer = brealloc(file->buffer, file->bufsize); + } + + /* + * On either incomplete lines or too small of a buffer, rewind + * and read the file again (on the next pass, if incomplete). + * It's simpler than trying to double-buffer the file. + */ + if (fsetpos(file->file, &where) < 0) + sysbail("cannot set position in %s", file->name); + continue; + } + + /* We saw a complete line. Print it out. */ + printf("# %s", file->buffer); + } + } +} + /* * Our exit handler. Called on completion of the test to report a summary of * results provided we're still in the original process. This also handles * printing out the plan if we used plan_lazy(), although that's suppressed if - * we never ran a test (due to an early bail, for example). + * we never ran a test (due to an early bail, for example), and running any + * registered cleanup functions. */ static void finish(void) { + int success, primary; + struct cleanup_func *current; unsigned long highest = testnum - 1; + struct diag_file *file, *tmp; + + /* Check for pending diag_file output. */ + check_diag_files(); + + /* Free the diag_files. */ + file = diag_files; + while (file != NULL) { + tmp = file; + file = file->next; + fclose(tmp->file); + free(tmp->name); + free(tmp->buffer); + free(tmp); + } + diag_files = NULL; + + /* + * Determine whether all tests were successful, which is needed before + * calling cleanup functions since we pass that fact to the functions. + */ + if (_planned == 0 && _lazy) + _planned = highest; + success = (!_aborted && _planned == highest && _failed == 0); + + /* + * If there are any registered cleanup functions, we run those first. We + * always run them, even if we didn't run a test. Don't do anything + * except free the diag_files and call cleanup functions if we aren't the + * primary process (the process in which plan or plan_lazy was called), + * and tell the cleanup functions that fact. + */ + primary = (_process == 0 || getpid() == _process); + while (cleanup_funcs != NULL) { + cleanup_funcs->func(success, primary); + current = cleanup_funcs; + cleanup_funcs = cleanup_funcs->next; + free(current); + } + if (!primary) + return; - if (_planned == 0 && !_lazy) + /* Don't do anything further if we never planned a test. */ + if (_planned == 0) return; + + /* If we're aborting due to bail, don't print summaries. */ + if (_aborted) + return; + + /* Print out the lazy plan if needed. */ fflush(stderr); - if (_process != 0 && getpid() == _process) { - if (_lazy && highest > 0) { - printf("1..%lu\n", highest); - _planned = highest; - } - if (_planned > highest) - printf("# Looks like you planned %lu test%s but only ran %lu\n", - _planned, (_planned > 1 ? "s" : ""), highest); - else if (_planned < highest) - printf("# Looks like you planned %lu test%s but ran %lu extra\n", - _planned, (_planned > 1 ? "s" : ""), highest - _planned); - else if (_failed > 0) - printf("# Looks like you failed %lu test%s of %lu\n", _failed, - (_failed > 1 ? "s" : ""), _planned); - else if (_planned > 1) - printf("# All %lu tests successful or skipped\n", _planned); - else - printf("# %lu test successful or skipped\n", _planned); - } + if (_lazy && _planned > 0) + printf("1..%lu\n", _planned); + + /* Print out a summary of the results. */ + if (_planned > highest) + diag("Looks like you planned %lu test%s but only ran %lu", _planned, + (_planned > 1 ? "s" : ""), highest); + else if (_planned < highest) + diag("Looks like you planned %lu test%s but ran %lu extra", _planned, + (_planned > 1 ? "s" : ""), highest - _planned); + else if (_failed > 0) + diag("Looks like you failed %lu test%s of %lu", _failed, + (_failed > 1 ? "s" : ""), _planned); + else if (_planned != 1) + diag("All %lu tests successful or skipped", _planned); + else + diag("%lu test successful or skipped", _planned); } /* * Initialize things. Turns on line buffering on stdout and then prints out - * the number of tests in the test suite. + * the number of tests in the test suite. We intentionally don't check for + * pending diag_file output here, since it should really come after the plan. */ void plan(unsigned long count) { if (setvbuf(stdout, NULL, _IOLBF, BUFSIZ) != 0) - fprintf(stderr, "# cannot set stdout to line buffered: %s\n", - strerror(errno)); + sysdiag("cannot set stdout to line buffered"); fflush(stderr); printf("1..%lu\n", count); testnum = 1; _planned = count; _process = getpid(); - atexit(finish); + if (atexit(finish) != 0) { + sysdiag("cannot register exit handler"); + diag("cleanups will not be run"); + } } @@ -143,83 +370,66 @@ void plan_lazy(void) { if (setvbuf(stdout, NULL, _IOLBF, BUFSIZ) != 0) - fprintf(stderr, "# cannot set stdout to line buffered: %s\n", - strerror(errno)); + sysdiag("cannot set stdout to line buffered"); testnum = 1; _process = getpid(); _lazy = 1; - atexit(finish); + if (atexit(finish) != 0) + sysbail("cannot register exit handler to display plan"); } /* * Skip the entire test suite and exits. Should be called instead of plan(), - * not after it, since it prints out a special plan line. + * not after it, since it prints out a special plan line. Ignore diag_file + * output here, since it's not clear if it's allowed before the plan. */ void skip_all(const char *format, ...) { fflush(stderr); printf("1..0 # skip"); - if (format != NULL) { - va_list args; - - putchar(' '); - va_start(args, format); - vprintf(format, args); - va_end(args); - } + PRINT_DESC(" ", format); putchar('\n'); exit(0); } -/* - * Print the test description. - */ -static void -print_desc(const char *format, va_list args) -{ - printf(" - "); - vprintf(format, args); -} - - /* * Takes a boolean success value and assumes the test passes if that value * is true and fails if that value is false. */ -void +int ok(int success, const char *format, ...) { fflush(stderr); + check_diag_files(); printf("%sok %lu", success ? "" : "not ", testnum++); if (!success) _failed++; - if (format != NULL) { - va_list args; - - va_start(args, format); - print_desc(format, args); - va_end(args); - } + PRINT_DESC(" - ", format); putchar('\n'); + return success; } /* * Same as ok(), but takes the format arguments as a va_list. */ -void +int okv(int success, const char *format, va_list args) { fflush(stderr); + check_diag_files(); printf("%sok %lu", success ? "" : "not ", testnum++); if (!success) _failed++; - if (format != NULL) - print_desc(format, args); + if (format != NULL) { + printf(" - "); + vprintf(format, args); + } putchar('\n'); + return success; } @@ -230,15 +440,9 @@ void skip(const char *reason, ...) { fflush(stderr); + check_diag_files(); printf("ok %lu # skip", testnum++); - if (reason != NULL) { - va_list args; - - va_start(args, reason); - putchar(' '); - vprintf(reason, args); - va_end(args); - } + PRINT_DESC(" ", reason); putchar('\n'); } @@ -246,25 +450,21 @@ skip(const char *reason, ...) /* * Report the same status on the next count tests. */ -void -ok_block(unsigned long count, int status, const char *format, ...) +int +ok_block(unsigned long count, int success, const char *format, ...) { unsigned long i; fflush(stderr); + check_diag_files(); for (i = 0; i < count; i++) { - printf("%sok %lu", status ? "" : "not ", testnum++); - if (!status) + printf("%sok %lu", success ? "" : "not ", testnum++); + if (!success) _failed++; - if (format != NULL) { - va_list args; - - va_start(args, format); - print_desc(format, args); - va_end(args); - } + PRINT_DESC(" - ", format); putchar('\n'); } + return success; } @@ -277,16 +477,10 @@ skip_block(unsigned long count, const char *reason, ...) unsigned long i; fflush(stderr); + check_diag_files(); for (i = 0; i < count; i++) { printf("ok %lu # skip", testnum++); - if (reason != NULL) { - va_list args; - - va_start(args, reason); - putchar(' '); - vprintf(reason, args); - va_end(args); - } + PRINT_DESC(" ", reason); putchar('\n'); } } @@ -296,25 +490,25 @@ skip_block(unsigned long count, const char *reason, ...) * Takes an expected integer and a seen integer and assumes the test passes * if those two numbers match. */ -void +int is_int(long wanted, long seen, const char *format, ...) { + int success; + fflush(stderr); - if (wanted == seen) + check_diag_files(); + success = (wanted == seen); + if (success) printf("ok %lu", testnum++); else { - printf("# wanted: %ld\n# seen: %ld\n", wanted, seen); + diag("wanted: %ld", wanted); + diag(" seen: %ld", seen); printf("not ok %lu", testnum++); _failed++; } - if (format != NULL) { - va_list args; - - va_start(args, format); - print_desc(format, args); - va_end(args); - } + PRINT_DESC(" - ", format); putchar('\n'); + return success; } @@ -322,29 +516,29 @@ is_int(long wanted, long seen, const char *format, ...) * Takes a string and what the string should be, and assumes the test passes * if those strings match (using strcmp). */ -void +int is_string(const char *wanted, const char *seen, const char *format, ...) { + int success; + if (wanted == NULL) wanted = "(null)"; if (seen == NULL) seen = "(null)"; fflush(stderr); - if (strcmp(wanted, seen) == 0) + check_diag_files(); + success = (strcmp(wanted, seen) == 0); + if (success) printf("ok %lu", testnum++); else { - printf("# wanted: %s\n# seen: %s\n", wanted, seen); + diag("wanted: %s", wanted); + diag(" seen: %s", seen); printf("not ok %lu", testnum++); _failed++; } - if (format != NULL) { - va_list args; - - va_start(args, format); - print_desc(format, args); - va_end(args); - } + PRINT_DESC(" - ", format); putchar('\n'); + return success; } @@ -352,26 +546,25 @@ is_string(const char *wanted, const char *seen, const char *format, ...) * Takes an expected unsigned long and a seen unsigned long and assumes the * test passes if the two numbers match. Otherwise, reports them in hex. */ -void +int is_hex(unsigned long wanted, unsigned long seen, const char *format, ...) { + int success; + fflush(stderr); - if (wanted == seen) + check_diag_files(); + success = (wanted == seen); + if (success) printf("ok %lu", testnum++); else { - printf("# wanted: %lx\n# seen: %lx\n", (unsigned long) wanted, - (unsigned long) seen); + diag("wanted: %lx", (unsigned long) wanted); + diag(" seen: %lx", (unsigned long) seen); printf("not ok %lu", testnum++); _failed++; } - if (format != NULL) { - va_list args; - - va_start(args, format); - print_desc(format, args); - va_end(args); - } + PRINT_DESC(" - ", format); putchar('\n'); + return success; } @@ -383,14 +576,16 @@ bail(const char *format, ...) { va_list args; + _aborted = 1; fflush(stderr); + check_diag_files(); fflush(stdout); printf("Bail out! "); va_start(args, format); vprintf(format, args); va_end(args); printf("\n"); - exit(1); + exit(255); } @@ -403,51 +598,110 @@ sysbail(const char *format, ...) va_list args; int oerrno = errno; + _aborted = 1; fflush(stderr); + check_diag_files(); fflush(stdout); printf("Bail out! "); va_start(args, format); vprintf(format, args); va_end(args); printf(": %s\n", strerror(oerrno)); - exit(1); + exit(255); } /* - * Report a diagnostic to stderr. + * Report a diagnostic to stderr. Always returns 1 to allow embedding in + * compound statements. */ -void +int diag(const char *format, ...) { va_list args; fflush(stderr); + check_diag_files(); fflush(stdout); printf("# "); va_start(args, format); vprintf(format, args); va_end(args); printf("\n"); + return 1; } /* - * Report a diagnostic to stderr, appending strerror(errno). + * Report a diagnostic to stderr, appending strerror(errno). Always returns 1 + * to allow embedding in compound statements. */ -void +int sysdiag(const char *format, ...) { va_list args; int oerrno = errno; fflush(stderr); + check_diag_files(); fflush(stdout); printf("# "); va_start(args, format); vprintf(format, args); va_end(args); printf(": %s\n", strerror(oerrno)); + return 1; +} + + +/* + * Register a new file for diag_file processing. + */ +void +diag_file_add(const char *name) +{ + struct diag_file *file, *prev; + + file = bcalloc(1, sizeof(struct diag_file)); + file->name = bstrdup(name); + file->file = fopen(file->name, "r"); + if (file->file == NULL) + sysbail("cannot open %s", name); + file->buffer = bmalloc(BUFSIZ); + file->bufsize = BUFSIZ; + if (diag_files == NULL) + diag_files = file; + else { + for (prev = diag_files; prev->next != NULL; prev = prev->next) + ; + prev->next = file; + } +} + + +/* + * Remove a file from diag_file processing. If the file is not found, do + * nothing, since there are some situations where it can be removed twice + * (such as if it's removed from a cleanup function, since cleanup functions + * are called after freeing all the diag_files). + */ +void +diag_file_remove(const char *name) +{ + struct diag_file *file; + struct diag_file **prev = &diag_files; + + for (file = diag_files; file != NULL; file = file->next) { + if (strcmp(file->name, name) == 0) { + *prev = file->next; + fclose(file->file); + free(file->name); + free(file->buffer); + free(file); + return; + } + prev = &file->next; + } } @@ -494,6 +748,32 @@ brealloc(void *p, size_t size) } +/* + * The same as brealloc, but determine the size by multiplying an element + * count by a size, similar to calloc. The multiplication is checked for + * integer overflow. + * + * We should technically use SIZE_MAX here for the overflow check, but + * SIZE_MAX is C99 and we're only assuming C89 + SUSv3, which does not + * guarantee that it exists. They do guarantee that UINT_MAX exists, and we + * can assume that UINT_MAX <= SIZE_MAX. + * + * (In theory, C89 and C99 permit size_t to be smaller than unsigned int, but + * I disbelieve in the existence of such systems and they will have to cope + * without overflow checks.) + */ +void * +breallocarray(void *p, size_t n, size_t size) +{ + if (n > 0 && UINT_MAX / n <= size) + bail("reallocarray too large"); + p = realloc(p, n * size); + if (p == NULL) + sysbail("failed to realloc %lu bytes", (unsigned long) (n * size)); + return p; +} + + /* * Copy a string, reporting a fatal error with bail on failure. */ @@ -542,17 +822,12 @@ bstrndup(const char *s, size_t n) * then SOURCE for the file and return the full path to the file. Returns * NULL if the file doesn't exist. A non-NULL return should be freed with * test_file_path_free(). - * - * This function uses sprintf because it attempts to be independent of all - * other portability layers. The use immediately after a memory allocation - * should be safe without using snprintf or strlcpy/strlcat. */ char * test_file_path(const char *file) { char *base; char *path = NULL; - size_t length; const char *envs[] = { "BUILD", "SOURCE", NULL }; int i; @@ -560,9 +835,7 @@ test_file_path(const char *file) base = getenv(envs[i]); if (base == NULL) continue; - length = strlen(base) + 1 + strlen(file) + 1; - path = bmalloc(length); - sprintf(path, "%s/%s", base, file); + path = concat(base, "/", file, (const char *) 0); if (access(path, R_OK) == 0) break; free(path); @@ -580,8 +853,7 @@ test_file_path(const char *file) void test_file_path_free(char *path) { - if (path != NULL) - free(path); + free(path); } @@ -600,14 +872,11 @@ test_tmpdir(void) { const char *build; char *path = NULL; - size_t length; build = getenv("BUILD"); if (build == NULL) build = "."; - length = strlen(build) + strlen("/tmp") + 1; - path = bmalloc(length); - sprintf(path, "%s/tmp", build); + path = concat(build, "/tmp", (const char *) 0); if (access(path, X_OK) < 0) if (mkdir(path, 0777) < 0) sysbail("error creating temporary directory %s", path); @@ -623,7 +892,26 @@ test_tmpdir(void) void test_tmpdir_free(char *path) { - rmdir(path); if (path != NULL) - free(path); + rmdir(path); + free(path); +} + + +/* + * Register a cleanup function that is called when testing ends. All such + * registered functions will be run by finish. + */ +void +test_cleanup_register(test_cleanup_func func) +{ + struct cleanup_func *cleanup, **last; + + cleanup = bmalloc(sizeof(struct cleanup_func)); + cleanup->func = func; + cleanup->next = NULL; + last = &cleanup_funcs; + while (*last != NULL) + last = &(*last)->next; + *last = cleanup; } diff --git a/tests/tap/basic.h b/tests/tap/basic.h index c55f662..c002df9 100644 --- a/tests/tap/basic.h +++ b/tests/tap/basic.h @@ -4,8 +4,8 @@ * This file is part of C TAP Harness. The current version plus supporting * documentation is at . * - * Copyright 2009, 2010, 2011, 2012 Russ Allbery - * Copyright 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2011, 2012 + * Copyright 2009, 2010, 2011, 2012, 2013, 2014 Russ Allbery + * Copyright 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2011, 2012, 2014 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -32,7 +32,7 @@ #include #include /* va_list */ -#include /* size_t */ +#include /* size_t */ /* * Used for iterating through arrays. ARRAY_SIZE returns the number of @@ -55,7 +55,7 @@ extern unsigned long testnum; void plan(unsigned long count); /* - * Prepare for lazy planning, in which the plan will be printed automatically + * Prepare for lazy planning, in which the plan will be printed automatically * at the end of the test program. */ void plan_lazy(void); @@ -67,26 +67,33 @@ void skip_all(const char *format, ...) /* * Basic reporting functions. The okv() function is the same as ok() but * takes the test description as a va_list to make it easier to reuse the - * reporting infrastructure when writing new tests. + * reporting infrastructure when writing new tests. ok() and okv() return the + * value of the success argument. */ -void ok(int success, const char *format, ...) +int ok(int success, const char *format, ...) __attribute__((__format__(printf, 2, 3))); -void okv(int success, const char *format, va_list args); +int okv(int success, const char *format, va_list args); void skip(const char *reason, ...) __attribute__((__format__(printf, 1, 2))); -/* Report the same status on, or skip, the next count tests. */ -void ok_block(unsigned long count, int success, const char *format, ...) +/* + * Report the same status on, or skip, the next count tests. ok_block() + * returns the value of the success argument. + */ +int ok_block(unsigned long count, int success, const char *format, ...) __attribute__((__format__(printf, 3, 4))); void skip_block(unsigned long count, const char *reason, ...) __attribute__((__format__(printf, 2, 3))); -/* Check an expected value against a seen value. */ -void is_int(long wanted, long seen, const char *format, ...) +/* + * Check an expected value against a seen value. Returns true if the test + * passes and false if it fails. + */ +int is_int(long wanted, long seen, const char *format, ...) __attribute__((__format__(printf, 3, 4))); -void is_string(const char *wanted, const char *seen, const char *format, ...) +int is_string(const char *wanted, const char *seen, const char *format, ...) __attribute__((__format__(printf, 3, 4))); -void is_hex(unsigned long wanted, unsigned long seen, const char *format, ...) +int is_hex(unsigned long wanted, unsigned long seen, const char *format, ...) __attribute__((__format__(printf, 3, 4))); /* Bail out with an error. sysbail appends strerror(errno). */ @@ -96,29 +103,43 @@ void sysbail(const char *format, ...) __attribute__((__noreturn__, __nonnull__, __format__(printf, 1, 2))); /* Report a diagnostic to stderr prefixed with #. */ -void diag(const char *format, ...) +int diag(const char *format, ...) __attribute__((__nonnull__, __format__(printf, 1, 2))); -void sysdiag(const char *format, ...) +int sysdiag(const char *format, ...) __attribute__((__nonnull__, __format__(printf, 1, 2))); +/* + * Register or unregister a file that contains supplementary diagnostics. + * Before any other output, all registered files will be read, line by line, + * and each line will be reported as a diagnostic as if it were passed to + * diag(). Nul characters are not supported in these files and will result in + * truncated output. + */ +void diag_file_add(const char *file) + __attribute__((__nonnull__)); +void diag_file_remove(const char *file) + __attribute__((__nonnull__)); + /* Allocate memory, reporting a fatal error with bail on failure. */ void *bcalloc(size_t, size_t) - __attribute__((__alloc_size__(1, 2), __malloc__)); + __attribute__((__alloc_size__(1, 2), __malloc__, __warn_unused_result__)); void *bmalloc(size_t) - __attribute__((__alloc_size__(1), __malloc__)); + __attribute__((__alloc_size__(1), __malloc__, __warn_unused_result__)); +void *breallocarray(void *, size_t, size_t) + __attribute__((__alloc_size__(2, 3), __malloc__, __warn_unused_result__)); void *brealloc(void *, size_t) - __attribute__((__alloc_size__(2), __malloc__)); + __attribute__((__alloc_size__(2), __malloc__, __warn_unused_result__)); char *bstrdup(const char *) - __attribute__((__malloc__, __nonnull__)); + __attribute__((__malloc__, __nonnull__, __warn_unused_result__)); char *bstrndup(const char *, size_t) - __attribute__((__malloc__, __nonnull__)); + __attribute__((__malloc__, __nonnull__, __warn_unused_result__)); /* * Find a test file under BUILD or SOURCE, returning the full path. The * returned path should be freed with test_file_path_free(). */ char *test_file_path(const char *file) - __attribute__((__malloc__, __nonnull__)); + __attribute__((__malloc__, __nonnull__, __warn_unused_result__)); void test_file_path_free(char *path); /* @@ -126,9 +147,23 @@ void test_file_path_free(char *path); * returned path should be freed with test_tmpdir_free. */ char *test_tmpdir(void) - __attribute__((__malloc__)); + __attribute__((__malloc__, __warn_unused_result__)); void test_tmpdir_free(char *path); +/* + * Register a cleanup function that is called when testing ends. All such + * registered functions will be run during atexit handling (and are therefore + * subject to all the same constraints and caveats as atexit functions). + * + * The function must return void and will be passed two argument, an int that + * will be true if the test completed successfully and false otherwise, and an + * int that will be true if the cleanup function is run in the primary process + * (the one that called plan or plan_lazy) and false otherwise. + */ +typedef void (*test_cleanup_func)(int, int); +void test_cleanup_register(test_cleanup_func) + __attribute__((__nonnull__)); + END_DECLS #endif /* TAP_BASIC_H */ diff --git a/tests/tap/kerberos.c b/tests/tap/kerberos.c index 6f593f8..578a858 100644 --- a/tests/tap/kerberos.c +++ b/tests/tap/kerberos.c @@ -15,7 +15,7 @@ * which can be found at . * * Written by Russ Allbery - * Copyright 2006, 2007, 2009, 2010, 2011, 2012 + * Copyright 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -38,7 +38,7 @@ */ #include -#ifdef HAVE_KERBEROS +#ifdef HAVE_KRB5 # include #endif #include @@ -47,6 +47,7 @@ #include #include +#include #include #include @@ -79,7 +80,7 @@ static char *tmpdir_conf = NULL; * Kerberos libraries available and one if we don't. Uses keytab to obtain * credentials, and fills in the cache member of the provided config struct. */ -#ifdef HAVE_KERBEROS +#ifdef HAVE_KRB5 static void kerberos_kinit(void) @@ -147,7 +148,7 @@ kerberos_kinit(void) free(krbtgt); } -#else /* !HAVE_KERBEROS */ +#else /* !HAVE_KRB5 */ static void kerberos_kinit(void) @@ -197,37 +198,27 @@ kerberos_kinit(void) bail("cannot get Kerberos tickets"); } -#endif /* !HAVE_KERBEROS */ +#endif /* !HAVE_KRB5 */ /* - * Clean up at the end of a test. This removes the ticket cache and resets - * and frees the memory allocated for the environment variables so that - * valgrind output on test suites is cleaner. + * Free all the memory associated with our Kerberos setup, but don't remove + * the ticket cache. This is used when cleaning up on exit from a non-primary + * process so that test programs that fork don't remove the ticket cache still + * used by the main program. */ -void -kerberos_cleanup(void) +static void +kerberos_free(void) { - char *path; - - if (tmpdir_ticket != NULL) { - basprintf(&path, "%s/krb5cc_test", tmpdir_ticket); - unlink(path); - free(path); - test_tmpdir_free(tmpdir_ticket); - tmpdir_ticket = NULL; - } + test_tmpdir_free(tmpdir_ticket); + tmpdir_ticket = NULL; if (config != NULL) { - if (config->keytab != NULL) { - test_file_path_free(config->keytab); - free(config->principal); - free(config->cache); - } - if (config->userprinc != NULL) { - free(config->userprinc); - free(config->username); - free(config->password); - } + test_file_path_free(config->keytab); + free(config->principal); + free(config->cache); + free(config->userprinc); + free(config->username); + free(config->password); free(config); config = NULL; } @@ -244,6 +235,42 @@ kerberos_cleanup(void) } +/* + * Clean up at the end of a test. This removes the ticket cache and resets + * and frees the memory allocated for the environment variables so that + * valgrind output on test suites is cleaner. Most of the work is done by + * kerberos_free, but this function also deletes the ticket cache. + */ +void +kerberos_cleanup(void) +{ + char *path; + + if (tmpdir_ticket != NULL) { + basprintf(&path, "%s/krb5cc_test", tmpdir_ticket); + unlink(path); + free(path); + } + kerberos_free(); +} + + +/* + * The cleanup handler for the TAP framework. Call kerberos_cleanup if we're + * in the primary process and kerberos_free if not. The first argument, which + * indicates whether the test succeeded or not, is ignored, since we need to + * do the same thing either way. + */ +static void +kerberos_cleanup_handler(int success UNUSED, int primary) +{ + if (primary) + kerberos_cleanup(); + else + kerberos_free(); +} + + /* * Obtain Kerberos tickets for the principal specified in config/principal * using the keytab specified in config/keytab, both of which are presumed to @@ -321,15 +348,13 @@ kerberos_setup(enum kerberos_needs needs) *config->realm = '\0'; config->realm++; } - if (path != NULL) - test_file_path_free(path); + test_file_path_free(path); /* - * Register the cleanup function as an atexit handler so that the caller - * doesn't have to worry about cleanup. + * Register the cleanup function so that the caller doesn't have to do + * explicit cleanup. */ - if (atexit(kerberos_cleanup) != 0) - sysdiag("cannot register cleanup function"); + test_cleanup_register(kerberos_cleanup_handler); /* Return the configuration. */ return config; @@ -357,10 +382,8 @@ kerberos_cleanup_conf(void) tmpdir_conf = NULL; } putenv((char *) "KRB5_CONFIG="); - if (krb5_config != NULL) { - free(krb5_config); - krb5_config = NULL; - } + free(krb5_config); + krb5_config = NULL; } @@ -401,7 +424,7 @@ kerberos_generate_conf(const char *realm) * The remaining functions in this file are only available if Kerberos * libraries are available. */ -#ifdef HAVE_KERBEROS +#ifdef HAVE_KRB5 /* @@ -485,4 +508,4 @@ kerberos_keytab_principal(krb5_context ctx, const char *path) return princ; } -#endif /* HAVE_KERBEROS */ +#endif /* HAVE_KRB5 */ diff --git a/tests/tap/kerberos.h b/tests/tap/kerberos.h index 25c44a6..8be0add 100644 --- a/tests/tap/kerberos.h +++ b/tests/tap/kerberos.h @@ -5,7 +5,7 @@ * which can be found at . * * Written by Russ Allbery - * Copyright 2006, 2007, 2009, 2011, 2012 + * Copyright 2006, 2007, 2009, 2011, 2012, 2013, 2014 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -33,7 +33,7 @@ #include #include -#ifdef HAVE_KERBEROS +#ifdef HAVE_KRB5 # include #endif @@ -53,10 +53,10 @@ struct kerberos_config { * certain configuration information isn't available. */ enum kerberos_needs { - TAP_KRB_NEEDS_NONE, - TAP_KRB_NEEDS_KEYTAB, - TAP_KRB_NEEDS_PASSWORD, - TAP_KRB_NEEDS_BOTH + TAP_KRB_NEEDS_NONE = 0x00, + TAP_KRB_NEEDS_KEYTAB = 0x01, + TAP_KRB_NEEDS_PASSWORD = 0x02, + TAP_KRB_NEEDS_BOTH = 0x01 | 0x02 }; BEGIN_DECLS @@ -73,11 +73,11 @@ BEGIN_DECLS * the principal field will be NULL. If the files exist but loading them * fails, or authentication fails, kerberos_setup calls bail. * - * kerberos_cleanup will be set up to run from an atexit handler. This means - * that any child processes that should not remove the Kerberos ticket cache - * should call _exit instead of exit. The principal will be automatically - * freed when kerberos_cleanup is called or if kerberos_setup is called again. - * The caller doesn't need to worry about it. + * kerberos_cleanup will be run as a cleanup function normally, freeing all + * resources and cleaning up temporary files on process exit. It can, + * however, be called directly if for some reason the caller needs to delete + * the Kerberos environment again. However, normally the caller can just call + * kerberos_setup again. */ struct kerberos_config *kerberos_setup(enum kerberos_needs) __attribute__((__malloc__)); @@ -100,7 +100,7 @@ void kerberos_generate_conf(const char *realm); void kerberos_cleanup_conf(void); /* Thes interfaces are only available with native Kerberos support. */ -#ifdef HAVE_KERBEROS +#ifdef HAVE_KRB5 /* Bail out with an error, appending the Kerberos error message. */ void bail_krb5(krb5_context, krb5_error_code, const char *format, ...) @@ -118,7 +118,7 @@ void diag_krb5(krb5_context, krb5_error_code, const char *format, ...) krb5_principal kerberos_keytab_principal(krb5_context, const char *path) __attribute__((__nonnull__)); -#endif /* HAVE_KERBEROS */ +#endif /* HAVE_KRB5 */ END_DECLS diff --git a/tests/tap/libtap.sh b/tests/tap/libtap.sh index 1b02939..9731032 100644 --- a/tests/tap/libtap.sh +++ b/tests/tap/libtap.sh @@ -11,7 +11,7 @@ # # Written by Russ Allbery # Copyright 2009, 2010, 2011, 2012 Russ Allbery -# Copyright 2006, 2007, 2008 +# Copyright 2006, 2007, 2008, 2013 # The Board of Trustees of the Leland Stanford Junior University # # Permission is hereby granted, free of charge, to any person obtaining a copy @@ -204,7 +204,7 @@ strip_colon_error() { # Bail out with an error message. bail () { echo 'Bail out!' "$@" - exit 1 + exit 255 } # Output a diagnostic on standard error, preceded by the required # mark. diff --git a/tests/tap/macros.h b/tests/tap/macros.h index 368f95e..04cc420 100644 --- a/tests/tap/macros.h +++ b/tests/tap/macros.h @@ -8,7 +8,7 @@ * This file is part of C TAP Harness. The current version plus supporting * documentation is at . * - * Copyright 2008, 2012 Russ Allbery + * Copyright 2008, 2012, 2013 Russ Allbery * * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), @@ -58,6 +58,13 @@ # endif #endif +/* Suppress __warn_unused_result__ if gcc is too old. */ +#if !defined(__attribute__) && !defined(__warn_unused_result__) +# if __GNUC__ < 3 || (__GNUC__ == 3 && __GNUC_MINOR__ < 4) +# define __warn_unused_result__ /* empty */ +# endif +#endif + /* * LLVM and Clang pretend to be GCC but don't support all of the __attribute__ * settings that GCC does. For them, suppress warnings about unknown diff --git a/tests/tap/messages.c b/tests/tap/messages.c index 3754d18..45b0566 100644 --- a/tests/tap/messages.c +++ b/tests/tap/messages.c @@ -9,7 +9,7 @@ * which can be found at . * * Copyright 2002, 2004, 2005 Russ Allbery - * Copyright 2006, 2007, 2009, 2012 + * Copyright 2006, 2007, 2009, 2012, 2014 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -75,10 +75,8 @@ message_log_buffer(int len UNUSED, const char *fmt, va_list args, void errors_capture(void) { - if (errors != NULL) { - free(errors); - errors = NULL; - } + free(errors); + errors = NULL; message_handlers_warn(1, message_log_buffer); message_handlers_notice(1, message_log_buffer); } diff --git a/tests/tap/perl/Test/RRA.pm b/tests/tap/perl/Test/RRA.pm index 49c0d06..bb7de7d 100644 --- a/tests/tap/perl/Test/RRA.pm +++ b/tests/tap/perl/Test/RRA.pm @@ -10,7 +10,7 @@ # which can be found at . # # Written by Russ Allbery -# Copyright 2013 +# Copyright 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # Permission is hereby granted, free of charge, to any person obtaining a @@ -51,29 +51,47 @@ our (@EXPORT_OK, @ISA, $VERSION); # consistency is good). BEGIN { @ISA = qw(Exporter); - @EXPORT_OK = qw(skip_unless_maintainer use_prereq); + @EXPORT_OK = qw(skip_unless_author skip_unless_automated use_prereq); # This version should match the corresponding rra-c-util release, but with # two digits for the minor version, including a leading zero if necessary, # so that it will sort properly. - $VERSION = '5.00'; + $VERSION = '5.05'; } -# Skip this test unless maintainer tests are requested. Takes a short -# description of what tests this script would perform, which is used in the -# skip message. Calls plan skip_all, which will terminate the program. +# Skip this test unless author tests are requested. Takes a short description +# of what tests this script would perform, which is used in the skip message. +# Calls plan skip_all, which will terminate the program. # # $description - Short description of the tests # # Returns: undef -sub skip_unless_maintainer { +sub skip_unless_author { my ($description) = @_; - if (!$ENV{RRA_MAINTAINER_TESTS}) { - plan skip_all => "$description only run for maintainer"; + if (!$ENV{AUTHOR_TESTING}) { + plan skip_all => "$description only run for author"; } return; } +# Skip this test unless doing automated testing or release testing. This is +# used for tests that should be run by CPAN smoke testing or during releases, +# but not for manual installs by end users. Takes a short description of what +# tests this script would perform, which is used in the skip message. Calls +# plan skip_all, which will terminate the program. +# +# $description - Short description of the tests +# +# Returns: undef +sub skip_unless_automated { + my ($description) = @_; + for my $env (qw(AUTOMATED_TESTING RELEASE_TESTING AUTHOR_TESTING)) { + return if $ENV{$env}; + } + plan skip_all => "$description normally skipped"; + return; +} + # Attempt to load a module and skip the test if the module could not be # loaded. If the module could be loaded, call its import function manually. # If the module could not be loaded, calls plan skip_all, which will terminate @@ -143,10 +161,14 @@ Test::RRA - Support functions for Perl tests =head1 SYNOPSIS - use Test::RRA qw(skip_unless_maintainer use_prereq); + use Test::RRA + qw(skip_unless_author skip_unless_automated use_prereq); - # Skip this test unless maintainer tests are requested. - skip_unless_maintainer('Coding style tests'); + # Skip this test unless author tests are requested. + skip_unless_author('Coding style tests'); + + # Skip this test unless doing automated or release testing. + skip_unless_automated('POD syntax tests'); # Load modules, skipping the test if they're not available. use_prereq('Perl6::Slurp', 'slurp'); @@ -166,12 +188,23 @@ script should be explicitly imported. =over 4 -=item skip_unless_maintainer(DESC) +=item skip_unless_author(DESC) -Checks whether RRA_MAINTAINER_TESTS is set in the environment and skips -the whole test (by calling C from Test::More) if it is not. +Checks whether AUTHOR_TESTING is set in the environment and skips the +whole test (by calling C from Test::More) if it is not. DESC is a description of the tests being skipped. A space and C will be appended to it and used as the skip reason. +for author> will be appended to it and used as the skip reason. + +=item skip_unless_automated(DESC) + +Checks whether AUTHOR_TESTING, AUTOMATED_TESTING, or RELEASE_TESTING are +set in the environment and skips the whole test (by calling C from Test::More) if they are not. This should be used by tests +that should not run during end-user installs of the module, but which +should run as part of CPAN smoke testing and release testing. + +DESC is a description of the tests being skipped. A space and C will be appended to it and used as the skip reason. =item use_prereq(MODULE[, VERSION][, IMPORT ...]) @@ -192,7 +225,7 @@ Russ Allbery =head1 COPYRIGHT AND LICENSE -Copyright 2013 The Board of Trustees of the Leland Stanford Junior +Copyright 2013, 2014 The Board of Trustees of the Leland Stanford Junior University Permission is hereby granted, free of charge, to any person obtaining a @@ -220,4 +253,8 @@ Test::More(3), Test::RRA::Automake(3), Test::RRA::Config(3) This module is maintained in the rra-c-util package. The current version is available from L. +The functions to control when tests are run use environment variables +defined by the L. + =cut diff --git a/tests/tap/perl/Test/RRA/Automake.pm b/tests/tap/perl/Test/RRA/Automake.pm index b80a8fe..a064ed9 100644 --- a/tests/tap/perl/Test/RRA/Automake.pm +++ b/tests/tap/perl/Test/RRA/Automake.pm @@ -87,7 +87,7 @@ BEGIN { # This version should match the corresponding rra-c-util release, but with # two digits for the minor version, including a leading zero if necessary, # so that it will sort properly. - $VERSION = '5.00'; + $VERSION = '5.05'; } # Perl directories to skip globally for perl_dirs. We ignore the perl diff --git a/tests/tap/perl/Test/RRA/Config.pm b/tests/tap/perl/Test/RRA/Config.pm index 5c3df7b..3e77650 100644 --- a/tests/tap/perl/Test/RRA/Config.pm +++ b/tests/tap/perl/Test/RRA/Config.pm @@ -31,12 +31,13 @@ BEGIN { @EXPORT_OK = qw( $COVERAGE_LEVEL @COVERAGE_SKIP_TESTS @CRITIC_IGNORE $LIBRARY_PATH $MINIMUM_VERSION %MINIMUM_VERSION @POD_COVERAGE_EXCLUDE @STRICT_IGNORE + @STRICT_PREREQ ); # This version should match the corresponding rra-c-util release, but with # two digits for the minor version, including a leading zero if necessary, # so that it will sort properly. - $VERSION = '5.00'; + $VERSION = '5.05'; } # If BUILD or SOURCE are set in the environment, look for data/perl.conf under @@ -65,6 +66,7 @@ our $MINIMUM_VERSION = '5.008'; our %MINIMUM_VERSION; our @POD_COVERAGE_EXCLUDE; our @STRICT_IGNORE; +our @STRICT_PREREQ; # Load the configuration. if (!do($PATH)) { @@ -163,6 +165,13 @@ for C and C. The contents of this directory must be either top-level directory names or directory names starting with F. +=item @STRICT_PREREQ + +A list of Perl modules that have to be available in order to do meaningful +Test::Strict testing. If any of the modules cannot be loaded via C, +Test::Strict checking will be skipped. There is currently no way to +require specific versions of the modules. + =back No variables are exported by default, but the variables can be imported @@ -174,7 +183,7 @@ Russ Allbery =head1 COPYRIGHT AND LICENSE -Copyright 2013 The Board of Trustees of the Leland Stanford Junior +Copyright 2013, 2014 The Board of Trustees of the Leland Stanford Junior University Permission is hereby granted, free of charge, to any person obtaining a diff --git a/tests/tap/process.c b/tests/tap/process.c index ac60aae..6461fb4 100644 --- a/tests/tap/process.c +++ b/tests/tap/process.c @@ -7,12 +7,15 @@ * runs a function in a subprocess and checks its output and exit status * against expected values. * + * Requires an Autoconf probe for sys/select.h and a replacement for a missing + * mkstemp. + * * The canonical version of this file is maintained in the rra-c-util package, * which can be found at . * * Written by Russ Allbery - * Copyright 2002, 2004, 2005 Russ Allbery - * Copyright 2009, 2010, 2011 + * Copyright 2002, 2004, 2005, 2013 Russ Allbery + * Copyright 2009, 2010, 2011, 2013, 2014 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -37,12 +40,48 @@ #include #include +#include +#include +#include +#ifdef HAVE_SYS_SELECT_H +# include +#endif +#include +#include #include #include #include #include +/* May be defined by the build system. */ +#ifndef PATH_FAKEROOT +# define PATH_FAKEROOT "" +#endif + +/* How long to wait for the process to start in seconds. */ +#define PROCESS_WAIT 10 + +/* + * Used to store information about a background process. This contains + * everything required to stop the process and clean up after it. + */ +struct process { + pid_t pid; /* PID of child process */ + char *pidfile; /* PID file to delete on process stop */ + char *tmpdir; /* Temporary directory for log file */ + char *logfile; /* Log file of process output */ + bool is_child; /* Whether we can waitpid for process */ + struct process *next; /* Next process in global list */ +}; + +/* + * Global list of started processes, which will be cleaned up automatically on + * program exit if they haven't been explicitly stopped with process_stop + * prior to that point. + */ +static struct process *processes = NULL; + /* * Given a function, an expected exit status, and expected output, runs that @@ -171,7 +210,312 @@ run_setup(const char *const argv[]) p = strchr(output, '\n'); if (p != NULL) *p = '\0'; - bail("%s", output); + if (output[0] != '\0') + bail("%s", output); + else + bail("setup command failed with no output"); } free(output); } + + +/* + * Free the resources associated with tracking a process, without doing + * anything to the process. This is kept separate so that we can free + * resources during shutdown in a non-primary process. + */ +static void +process_free(struct process *process) +{ + struct process **prev; + + /* Remove the process from the global list. */ + prev = &processes; + while (*prev != NULL && *prev != process) + prev = &(*prev)->next; + if (*prev == process) + *prev = process->next; + + /* Free resources. */ + free(process->pidfile); + free(process->logfile); + test_tmpdir_free(process->tmpdir); + free(process); +} + + +/* + * Kill a process and wait for it to exit. Returns the status of the process. + * Calls bail on a system failure or a failure of the process to exit. + * + * We are quite aggressive with error reporting here because child processes + * that don't exit or that don't exist often indicate some form of test + * failure. + */ +static int +process_kill(struct process *process) +{ + int result, i; + int status = -1; + struct timeval tv; + unsigned long pid = process->pid; + + /* If the process is not a child, just kill it and hope. */ + if (!process->is_child) { + if (kill(process->pid, SIGTERM) < 0 && errno != ESRCH) + sysbail("cannot send SIGTERM to process %lu", pid); + return 0; + } + + /* Check if the process has already exited. */ + result = waitpid(process->pid, &status, WNOHANG); + if (result < 0) + sysbail("cannot wait for child process %lu", pid); + else if (result > 0) + return status; + + /* + * Kill the process and wait for it to exit. I don't want to go to the + * work of setting up a SIGCHLD handler or a full event loop here, so we + * effectively poll every tenth of a second for process exit (and + * hopefully faster when it does since the SIGCHLD may interrupt our + * select, although we're racing with it. + */ + if (kill(process->pid, SIGTERM) < 0 && errno != ESRCH) + sysbail("cannot send SIGTERM to child process %lu", pid); + for (i = 0; i < PROCESS_WAIT * 10; i++) { + tv.tv_sec = 0; + tv.tv_usec = 100000; + select(0, NULL, NULL, NULL, &tv); + result = waitpid(process->pid, &status, WNOHANG); + if (result < 0) + sysbail("cannot wait for child process %lu", pid); + else if (result > 0) + return status; + } + + /* The process still hasn't exited. Bail. */ + bail("child process %lu did not exit on SIGTERM", pid); + + /* Not reached, but some compilers may get confused. */ + return status; +} + + +/* + * Stop a particular process given its process struct. This kills the + * process, waits for it to exit if possible (giving it at most five seconds), + * and then removes it from the global processes struct so that it isn't + * stopped again during global shutdown. + */ +void +process_stop(struct process *process) +{ + int status; + unsigned long pid = process->pid; + + /* Stop the process. */ + status = process_kill(process); + + /* Call diag to flush logs as well as provide exit status. */ + if (process->is_child) + diag("stopped process %lu (exit status %d)", pid, status); + else + diag("stopped process %lu", pid); + + /* Remove the log and PID file. */ + diag_file_remove(process->logfile); + unlink(process->pidfile); + unlink(process->logfile); + + /* Free resources. */ + process_free(process); +} + + +/* + * Stop all running processes. This is called as a cleanup handler during + * process shutdown. The first argument, which says whether the test was + * successful, is ignored, since the same actions should be performed + * regardless. The second argument says whether this is the primary process, + * in which case we do the full shutdown. Otherwise, we only free resources + * but don't stop the process. + */ +static void +process_stop_all(int success UNUSED, int primary) +{ + while (processes != NULL) { + if (primary) + process_stop(processes); + else + process_free(processes); + } +} + + +/* + * Read the PID of a process from a file. This is necessary when running + * under fakeroot to get the actual PID of the remctld process. + */ +static long +read_pidfile(const char *path) +{ + FILE *file; + char buffer[BUFSIZ]; + long pid; + + file = fopen(path, "r"); + if (file == NULL) + sysbail("cannot open %s", path); + if (fgets(buffer, sizeof(buffer), file) == NULL) + sysbail("cannot read from %s", path); + fclose(file); + pid = strtol(buffer, NULL, 10); + if (pid <= 0) + bail("cannot read PID from %s", path); + return pid; +} + + +/* + * Start a process and return its status information. The status information + * is also stored in the global processes linked list so that it can be + * stopped automatically on program exit. + * + * The boolean argument says whether to start the process under fakeroot. If + * true, PATH_FAKEROOT must be defined, generally by Autoconf. If it's not + * found, call skip_all. + * + * This is a helper function for process_start and process_start_fakeroot. + */ +static struct process * +process_start_internal(const char *const argv[], const char *pidfile, + bool fakeroot) +{ + size_t i; + int log_fd; + const char *name; + struct timeval tv; + struct process *process; + const char **fakeroot_argv = NULL; + const char *path_fakeroot = PATH_FAKEROOT; + + /* Check prerequisites. */ + if (fakeroot && path_fakeroot[0] == '\0') + skip_all("fakeroot not found"); + + /* Create the process struct and log file. */ + process = bcalloc(1, sizeof(struct process)); + process->pidfile = bstrdup(pidfile); + process->tmpdir = test_tmpdir(); + name = strrchr(argv[0], '/'); + if (name != NULL) + name++; + else + name = argv[0]; + basprintf(&process->logfile, "%s/%s.log.XXXXXX", process->tmpdir, name); + log_fd = mkstemp(process->logfile); + if (log_fd < 0) + sysbail("cannot create log file for %s", argv[0]); + + /* If using fakeroot, rewrite argv accordingly. */ + if (fakeroot) { + for (i = 0; argv[i] != NULL; i++) + ; + fakeroot_argv = bcalloc(2 + i + 1, sizeof(const char *)); + fakeroot_argv[0] = path_fakeroot; + fakeroot_argv[1] = "--"; + for (i = 0; argv[i] != NULL; i++) + fakeroot_argv[i + 2] = argv[i]; + fakeroot_argv[i + 2] = NULL; + argv = fakeroot_argv; + } + + /* + * Fork off the child process, redirect its standard output and standard + * error to the log file, and then exec the program. + */ + process->pid = fork(); + if (process->pid < 0) + sysbail("fork failed"); + else if (process->pid == 0) { + if (dup2(log_fd, STDOUT_FILENO) < 0) + sysbail("cannot redirect standard output"); + if (dup2(log_fd, STDERR_FILENO) < 0) + sysbail("cannot redirect standard error"); + close(log_fd); + if (execv(argv[0], (char *const *) argv) < 0) + sysbail("exec of %s failed", argv[0]); + } + close(log_fd); + free(fakeroot_argv); + + /* + * In the parent. Wait for the child to start by watching for the PID + * file to appear in 100ms intervals. + */ + for (i = 0; i < PROCESS_WAIT * 10 && access(pidfile, F_OK) != 0; i++) { + tv.tv_sec = 0; + tv.tv_usec = 100000; + select(0, NULL, NULL, NULL, &tv); + } + + /* + * If the PID file still hasn't appeared after ten seconds, attempt to + * kill the process and then bail. + */ + if (access(pidfile, F_OK) != 0) { + kill(process->pid, SIGTERM); + alarm(5); + waitpid(process->pid, NULL, 0); + alarm(0); + bail("cannot start %s", argv[0]); + } + + /* + * Read the PID back from the PID file. This usually isn't necessary for + * non-forking daemons, but always doing this makes this function general, + * and it's required when running under fakeroot. + */ + if (fakeroot) + process->pid = read_pidfile(pidfile); + process->is_child = !fakeroot; + + /* Register the log file as a source of diag messages. */ + diag_file_add(process->logfile); + + /* + * Add the process to our global list and set our cleanup handler if this + * is the first process we started. + */ + if (processes == NULL) + test_cleanup_register(process_stop_all); + process->next = processes; + processes = process; + + /* All done. */ + return process; +} + + +/* + * Start a process and return the opaque process struct. The process must + * create pidfile with its PID when startup is complete. + */ +struct process * +process_start(const char *const argv[], const char *pidfile) +{ + return process_start_internal(argv, pidfile, false); +} + + +/* + * Start a process under fakeroot and return the opaque process struct. If + * fakeroot is not available, calls skip_all. The process must create pidfile + * with its PID when startup is complete. + */ +struct process * +process_start_fakeroot(const char *const argv[], const char *pidfile) +{ + return process_start_internal(argv, pidfile, true); +} diff --git a/tests/tap/process.h b/tests/tap/process.h index ed90345..8137d5d 100644 --- a/tests/tap/process.h +++ b/tests/tap/process.h @@ -5,7 +5,7 @@ * which can be found at . * * Written by Russ Allbery - * Copyright 2009, 2010 + * Copyright 2009, 2010, 2013 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -33,6 +33,9 @@ #include #include +/* Opaque data type for process_start and friends. */ +struct process; + BEGIN_DECLS /* @@ -60,6 +63,32 @@ void is_function_output(test_function_type, void *data, int status, void run_setup(const char *const argv[]) __attribute__((__nonnull__)); +/* + * process_start starts a process in the background, returning an opaque data + * struct that can be used to stop the process later. The standard output and + * standard error of the process will be sent to a log file registered with + * diag_file_add, so its output will be properly interleaved with the test + * case output. + * + * The process should create a PID file in the path given as the second + * argument when it's finished initialization. + * + * process_start_fakeroot is the same but starts the process under fakeroot. + * PATH_FAKEROOT must be defined (generally by Autoconf). If fakeroot is not + * found, process_start_fakeroot will call skip_all, so be sure to call this + * function before plan. + * + * process_stop can be called to explicitly stop the process. If it isn't + * called by the test program, it will be called automatically when the + * program exits. + */ +struct process *process_start(const char *const argv[], const char *pidfile) + __attribute__((__nonnull__)); +struct process *process_start_fakeroot(const char *const argv[], + const char *pidfile) + __attribute__((__nonnull__)); +void process_stop(struct process *); + END_DECLS #endif /* TAP_PROCESS_H */ diff --git a/tests/util/messages-krb5-t.c b/tests/util/messages-krb5-t.c index 8e9daf1..c6de5a5 100644 --- a/tests/util/messages-krb5-t.c +++ b/tests/util/messages-krb5-t.c @@ -5,7 +5,7 @@ * which can be found at . * * Written by Russ Allbery - * Copyright 2010, 2011 + * Copyright 2010, 2011, 2013, 2014 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -28,17 +28,31 @@ */ #include -#include +#ifdef HAVE_KRB5 +# include +#endif #include #include #include #include -#include +#ifdef HAVE_KRB5 +# include +#endif #include #include +/* Skip the whole test if not built with Kerberos support. */ +#ifndef HAVE_KRB5 +int +main(void) +{ + skip_all("not built with Kerberos support"); + return 0; +} +#else + /* * Test functions. */ @@ -116,5 +130,9 @@ main(void) message_handlers_die(0); is_function_output(test_die, NULL, 1, "", "warn_krb5 with no handlers"); + krb5_free_error_message(ctx, message); + krb5_free_context(ctx); return 0; } + +#endif /* HAVE_KRB5 */ diff --git a/tests/util/xmalloc-t b/tests/util/xmalloc-t index 74e4bbd..d52c448 100755 --- a/tests/util/xmalloc-t +++ b/tests/util/xmalloc-t @@ -6,7 +6,7 @@ # which can be found at . # # Written by Russ Allbery -# Copyright 2000, 2001, 2006 Russ Allbery +# Copyright 2000, 2001, 2006, 2014 Russ Allbery # Copyright 2008, 2009, 2010, 2012 # The Board of Trustees of the Leland Stanford Junior University # @@ -59,31 +59,33 @@ ok_xmalloc () { # failures in automated testing have been problems with the assumptions around # memory allocation or problems with the test suite, not problems with the # underlying xmalloc code. -if [ -z "$RRA_MAINTAINER_TESTS" ] ; then - skip_all 'xmalloc tests only run for maintainer' +if [ -z "$AUTHOR_TESTING" ] ; then + skip_all 'xmalloc tests only run for author' fi # Total tests. -plan 36 +plan 41 # First run the tests expected to succeed. -ok_xmalloc "malloc small" 0 "" "m" "21" "0" -ok_xmalloc "malloc large" 0 "" "m" "5500000" "0" -ok_xmalloc "malloc zero" 0 "" "m" "0" "0" -ok_xmalloc "realloc small" 0 "" "r" "21" "0" -ok_xmalloc "realloc large" 0 "" "r" "5500000" "0" -ok_xmalloc "strdup small" 0 "" "s" "21" "0" -ok_xmalloc "strdup large" 0 "" "s" "5500000" "0" -ok_xmalloc "strndup small" 0 "" "n" "21" "0" -ok_xmalloc "strndup large" 0 "" "n" "5500000" "0" -ok_xmalloc "calloc small" 0 "" "c" "24" "0" -ok_xmalloc "calloc large" 0 "" "c" "5500000" "0" -ok_xmalloc "asprintf small" 0 "" "a" "24" "0" -ok_xmalloc "asprintf large" 0 "" "a" "5500000" "0" -ok_xmalloc "vasprintf small" 0 "" "v" "24" "0" -ok_xmalloc "vasprintf large" 0 "" "v" "5500000" "0" +ok_xmalloc "malloc small" 0 "" "m" "21" "0" +ok_xmalloc "malloc large" 0 "" "m" "30000000" "0" +ok_xmalloc "malloc zero" 0 "" "m" "0" "0" +ok_xmalloc "realloc small" 0 "" "r" "21" "0" +ok_xmalloc "realloc large" 0 "" "r" "30000000" "0" +ok_xmalloc "reallocarray small" 0 "" "y" "20" "0" +ok_xmalloc "reallocarray large" 0 "" "y" "30000000" "0" +ok_xmalloc "strdup small" 0 "" "s" "21" "0" +ok_xmalloc "strdup large" 0 "" "s" "30000000" "0" +ok_xmalloc "strndup small" 0 "" "n" "21" "0" +ok_xmalloc "strndup large" 0 "" "n" "30000000" "0" +ok_xmalloc "calloc small" 0 "" "c" "24" "0" +ok_xmalloc "calloc large" 0 "" "c" "30000000" "0" +ok_xmalloc "asprintf small" 0 "" "a" "24" "0" +ok_xmalloc "asprintf large" 0 "" "a" "30000000" "0" +ok_xmalloc "vasprintf small" 0 "" "v" "24" "0" +ok_xmalloc "vasprintf large" 0 "" "v" "30000000" "0" -# Now limit our memory to 5.5MB and then try the large ones again, all of +# Now limit our memory to 30MB and then try the large ones again, all of # which should fail. # # The exact memory limits used here are essentially black magic. They need to @@ -91,53 +93,60 @@ ok_xmalloc "vasprintf large" 0 "" "v" "5500000" "0" # but not so large that we can't reasonably expect to allocate that much # memory normally. The amount of memory required varies a lot based on what # shared libraries are loaded, and if it's too small, all memory allocations -# fail. 5.5MB seems to work reasonably well on both Solaris and Linux. +# fail. 30MB seems to work reasonably well on both Solaris and Linux, even +# when the program is linked with additional libraries. # # We assume that there are enough miscellaneous allocations that an allocation # exactly as large as the limit will always fail. ok_xmalloc "malloc fail" 1 \ - "failed to malloc 5500000 bytes at xmalloc.c line 38" \ - "m" "5500000" "5500000" + "failed to malloc 30000000 bytes at xmalloc.c line 38" \ + "m" "30000000" "30000000" ok_xmalloc "realloc fail" 1 \ - "failed to realloc 5500000 bytes at xmalloc.c line 66" \ - "r" "5500000" "5500000" + "failed to realloc 30000000 bytes at xmalloc.c line 66" \ + "r" "30000000" "30000000" +ok_xmalloc "reallocarray fail" 1 \ + "failed to reallocarray 30000000 bytes at xmalloc.c line 96" \ + "y" "30000000" "30000000" ok_xmalloc "strdup fail" 1 \ - "failed to strdup 5500000 bytes at xmalloc.c line 97" \ - "s" "5500000" "5500000" + "failed to strdup 30000000 bytes at xmalloc.c line 127" \ + "s" "30000000" "30000000" ok_xmalloc "strndup fail" 1 \ - "failed to strndup 5500000 bytes at xmalloc.c line 143" \ - "n" "5500000" "5500000" + "failed to strndup 30000000 bytes at xmalloc.c line 173" \ + "n" "30000000" "30000000" ok_xmalloc "calloc fail" 1 \ - "failed to calloc 5500000 bytes at xmalloc.c line 167" \ - "c" "5500000" "5500000" + "failed to calloc 30000000 bytes at xmalloc.c line 197" \ + "c" "30000000" "30000000" ok_xmalloc "asprintf fail" 1 \ - "failed to asprintf 5500000 bytes at xmalloc.c line 191" \ - "a" "5500000" "5500000" + "failed to asprintf 30000000 bytes at xmalloc.c line 221" \ + "a" "30000000" "30000000" ok_xmalloc "vasprintf fail" 1 \ - "failed to vasprintf 5500000 bytes at xmalloc.c line 210" \ - "v" "5500000" "5500000" + "failed to vasprintf 30000000 bytes at xmalloc.c line 240" \ + "v" "30000000" "30000000" # Check our custom error handler. -ok_xmalloc "malloc custom" 1 "malloc 5500000 xmalloc.c 38" \ - "M" "5500000" "5500000" -ok_xmalloc "realloc custom" 1 "realloc 5500000 xmalloc.c 66" \ - "R" "5500000" "5500000" -ok_xmalloc "strdup custom" 1 "strdup 5500000 xmalloc.c 97" \ - "S" "5500000" "5500000" -ok_xmalloc "strndup custom" 1 "strndup 5500000 xmalloc.c 143" \ - "N" "5500000" "5500000" -ok_xmalloc "calloc custom" 1 "calloc 5500000 xmalloc.c 167" \ - "C" "5500000" "5500000" -ok_xmalloc "asprintf custom" 1 "asprintf 5500000 xmalloc.c 191" \ - "A" "5500000" "5500000" -ok_xmalloc "vasprintf custom" 1 "vasprintf 5500000 xmalloc.c 210" \ - "V" "5500000" "5500000" +ok_xmalloc "malloc custom" 1 "malloc 30000000 xmalloc.c 38" \ + "M" "30000000" "30000000" +ok_xmalloc "realloc custom" 1 "realloc 30000000 xmalloc.c 66" \ + "R" "30000000" "30000000" +ok_xmalloc "reallocarray custom" 1 "reallocarray 30000000 xmalloc.c 96" \ + "Y" "30000000" "30000000" +ok_xmalloc "strdup custom" 1 "strdup 30000000 xmalloc.c 127" \ + "S" "30000000" "30000000" +ok_xmalloc "strndup custom" 1 "strndup 30000000 xmalloc.c 173" \ + "N" "30000000" "30000000" +ok_xmalloc "calloc custom" 1 "calloc 30000000 xmalloc.c 197" \ + "C" "30000000" "30000000" +ok_xmalloc "asprintf custom" 1 "asprintf 30000000 xmalloc.c 221" \ + "A" "30000000" "30000000" +ok_xmalloc "vasprintf custom" 1 "vasprintf 30000000 xmalloc.c 240" \ + "V" "30000000" "30000000" # Check the smaller ones again just for grins. -ok_xmalloc "malloc retry" 0 "" "m" "21" "5500000" -ok_xmalloc "realloc retry" 0 "" "r" "32" "5500000" -ok_xmalloc "strdup retry" 0 "" "s" "64" "5500000" -ok_xmalloc "strndup retry" 0 "" "n" "20" "5500000" -ok_xmalloc "calloc retry" 0 "" "c" "24" "5500000" -ok_xmalloc "asprintf retry" 0 "" "a" "30" "5500000" -ok_xmalloc "vasprintf retry" 0 "" "v" "35" "5500000" +ok_xmalloc "malloc retry" 0 "" "m" "21" "30000000" +ok_xmalloc "realloc retry" 0 "" "r" "32" "30000000" +ok_xmalloc "reallocarray retry" 0 "" "y" "32" "30000000" +ok_xmalloc "strdup retry" 0 "" "s" "64" "30000000" +ok_xmalloc "strndup retry" 0 "" "n" "20" "30000000" +ok_xmalloc "calloc retry" 0 "" "c" "24" "30000000" +ok_xmalloc "asprintf retry" 0 "" "a" "30" "30000000" +ok_xmalloc "vasprintf retry" 0 "" "v" "35" "30000000" diff --git a/tests/util/xmalloc.c b/tests/util/xmalloc.c index 6614586..e222612 100644 --- a/tests/util/xmalloc.c +++ b/tests/util/xmalloc.c @@ -5,7 +5,7 @@ * which can be found at . * * Copyright 2000, 2001, 2006 Russ Allbery - * Copyright 2008, 2012 + * Copyright 2008, 2012, 2013, 2014 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -109,6 +109,36 @@ test_realloc(size_t size) } +/* + * Like test_realloc, but test allocating an array instead. Returns true on + * success, false on any failure. + */ +static int +test_reallocarray(size_t n, size_t size) +{ + char *buffer; + size_t i; + + buffer = xmalloc(10); + if (buffer == NULL) + return 0; + memset(buffer, 1, 10); + buffer = xreallocarray(buffer, n, size); + if (buffer == NULL) + return 0; + if (n > 0 && size > 0) + memset(buffer + 10, 2, (n * size) - 10); + for (i = 0; i < 10; i++) + if (buffer[i] != 1) + return 0; + for (i = 10; i < n * size; i++) + if (buffer[i] != 2) + return 0; + free(buffer); + return 1; +} + + /* * Generate a string of the size indicated, call xstrdup on it, and then * ensure the result matches. Returns true on success, false on any failure. @@ -322,6 +352,7 @@ main(int argc, char *argv[]) #if HAVE_SETRLIMIT && defined(RLIMIT_AS) struct rlimit rl; void *tmp; + size_t test_size; rl.rlim_cur = limit; rl.rlim_max = limit; @@ -329,11 +360,14 @@ main(int argc, char *argv[]) syswarn("Can't set data limit to %lu", (unsigned long) limit); exit(2); } - if (size < limit || code == 'r') { - tmp = malloc(code == 'r' ? 10 : size); + if (size < limit || code == 'r' || code == 'y') { + test_size = (code == 'r' || code == 'y') ? 10 : size; + if (test_size == 0) + test_size = 1; + tmp = malloc(test_size); if (tmp == NULL) { syswarn("Can't allocate initial memory of %lu (limit %lu)", - (unsigned long) size, (unsigned long) limit); + (unsigned long) test_size, (unsigned long) limit); exit(2); } free(tmp); @@ -348,6 +382,7 @@ main(int argc, char *argv[]) case 'c': exit(test_calloc(size) ? willfail : 1); case 'm': exit(test_malloc(size) ? willfail : 1); case 'r': exit(test_realloc(size) ? willfail : 1); + case 'y': exit(test_reallocarray(4, size / 4) ? willfail : 1); case 's': exit(test_strdup(size) ? willfail : 1); case 'n': exit(test_strndup(size) ? willfail : 1); case 'a': exit(test_asprintf(size) ? willfail : 1); diff --git a/util/messages-krb5.c b/util/messages-krb5.c index b058586..961ea1d 100644 --- a/util/messages-krb5.c +++ b/util/messages-krb5.c @@ -9,7 +9,7 @@ * which can be found at . * * Written by Russ Allbery - * Copyright 2006, 2007, 2008, 2009, 2010 + * Copyright 2006, 2007, 2008, 2009, 2010, 2013 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -35,7 +35,6 @@ #include #include -#include #include #include #include diff --git a/util/messages-krb5.h b/util/messages-krb5.h index a9072bf..3fc0862 100644 --- a/util/messages-krb5.h +++ b/util/messages-krb5.h @@ -5,7 +5,7 @@ * which can be found at . * * Written by Russ Allbery - * Copyright 2006, 2007, 2008, 2009, 2010 + * Copyright 2006, 2007, 2008, 2009, 2010, 2013 * The Board of Trustees of the Leland Stanford Junior University * * Permission is hereby granted, free of charge, to any person obtaining a @@ -31,11 +31,9 @@ #define UTIL_MESSAGES_KRB5_H 1 #include +#include #include -#include -#include - BEGIN_DECLS /* Default to a hidden visibility for all util functions. */ diff --git a/util/messages.c b/util/messages.c index 9ec3ba8..a43d962 100644 --- a/util/messages.c +++ b/util/messages.c @@ -54,7 +54,7 @@ * which can be found at . * * Written by Russ Allbery - * Copyright 2008, 2009, 2010 + * Copyright 2008, 2009, 2010, 2013 * The Board of Trustees of the Leland Stanford Junior University * Copyright (c) 2004, 2005, 2006 * by Internet Systems Consortium, Inc. ("ISC") @@ -131,7 +131,7 @@ message_handlers(message_handler_func **list, unsigned int count, va_list args) if (*list != stdout_handlers && *list != stderr_handlers) free(*list); - *list = xmalloc(sizeof(message_handler_func) * (count + 1)); + *list = xcalloc(count + 1, sizeof(message_handler_func)); for (i = 0; i < count; i++) (*list)[i] = (message_handler_func) va_arg(args, message_handler_func); (*list)[count] = NULL; @@ -159,6 +159,31 @@ HANDLER_FUNCTION(warn) HANDLER_FUNCTION(die) +/* + * Reset all handlers back to the defaults and free all allocated memory. + * This is primarily useful for programs that undergo comprehensive memory + * allocation analysis. + */ +void +message_handlers_reset(void) +{ + free(debug_handlers); + debug_handlers = NULL; + if (notice_handlers != stdout_handlers) { + free(notice_handlers); + notice_handlers = stdout_handlers; + } + if (warn_handlers != stderr_handlers) { + free(warn_handlers); + warn_handlers = stderr_handlers; + } + if (die_handlers != stderr_handlers) { + free(die_handlers); + die_handlers = stderr_handlers; + } +} + + /* * Print a message to stdout, supporting message_program_name. */ @@ -204,6 +229,7 @@ static void message_log_syslog(int pri, size_t len, const char *fmt, va_list args, int err) { char *buffer; + int status; buffer = malloc(len + 1); if (buffer == NULL) { @@ -211,7 +237,12 @@ message_log_syslog(int pri, size_t len, const char *fmt, va_list args, int err) (unsigned long) len + 1, __FILE__, __LINE__, strerror(errno)); exit(message_fatal_cleanup ? (*message_fatal_cleanup)() : 1); } - vsnprintf(buffer, len + 1, fmt, args); + status = vsnprintf(buffer, len + 1, fmt, args); + if (status < 0) { + warn("failed to format output with vsnprintf in syslog handler"); + free(buffer); + return; + } #ifdef _WIN32 { HANDLE eventlog; diff --git a/util/messages.h b/util/messages.h index 463137c..8c731b7 100644 --- a/util/messages.h +++ b/util/messages.h @@ -4,7 +4,7 @@ * The canonical version of this file is maintained in the rra-c-util package, * which can be found at . * - * Copyright 2008, 2010 + * Copyright 2008, 2010, 2013, 2014 * The Board of Trustees of the Leland Stanford Junior University * Copyright (c) 2004, 2005, 2006 * by Internet Systems Consortium, Inc. ("ISC") @@ -34,6 +34,7 @@ #include #include +#include BEGIN_DECLS @@ -71,6 +72,12 @@ void message_handlers_notice(unsigned int count, ...); void message_handlers_warn(unsigned int count, ...); void message_handlers_die(unsigned int count, ...); +/* + * Reset all message handlers back to the defaults and free any memory that + * was allocated by the other message_handlers_* functions. + */ +void message_handlers_reset(void); + /* * Some useful handlers, intended to be passed to message_handlers_*. All * handlers take the length of the formatted message, the format, a variadic diff --git a/util/xmalloc.c b/util/xmalloc.c index a78e31a..721447a 100644 --- a/util/xmalloc.c +++ b/util/xmalloc.c @@ -33,6 +33,10 @@ * allocation function will try its allocation again (calling the handler * again if it still fails). * + * xreallocarray behaves the same as the OpenBSD reallocarray function but for + * the same error checking, which in turn is the same as realloc but with + * calloc-style arguments and size overflow checking. + * * xstrndup behaves like xstrdup but only copies the given number of * characters. It allocates an additional byte over its second argument and * always nul-terminates the string. @@ -58,7 +62,7 @@ * The canonical version of this file is maintained in the rra-c-util package, * which can be found at . * - * Copyright 2012 + * Copyright 2012, 2013, 2014 * The Board of Trustees of the Leland Stanford Junior University * Copyright (c) 2004, 2005, 2006 * by Internet Systems Consortium, Inc. ("ISC") @@ -84,8 +88,6 @@ #include #include -#include - #include #include @@ -96,8 +98,12 @@ void xmalloc_fail(const char *function, size_t size, const char *file, int line) { - sysdie("failed to %s %lu bytes at %s line %d", function, - (unsigned long) size, file, line); + if (size == 0) + sysdie("failed to format output with %s at %s line %d", function, + file, line); + else + sysdie("failed to %s %lu bytes at %s line %d", function, + (unsigned long) size, file, line); } /* Assign to this variable to choose a handler other than the default. */ @@ -150,6 +156,20 @@ x_realloc(void *p, size_t size, const char *file, int line) } +void * +x_reallocarray(void *p, size_t n, size_t size, const char *file, int line) +{ + void *newp; + + newp = reallocarray(p, n, size); + while (newp == NULL && size > 0 && n > 0) { + (*xmalloc_error_handler)("reallocarray", n * size, file, line); + newp = reallocarray(p, n, size); + } + return newp; +} + + char * x_strdup(const char *s, const char *file, int line) { @@ -208,7 +228,8 @@ x_vasprintf(char **strp, const char *fmt, va_list args, const char *file, va_copy(args_copy, args); status = vsnprintf(NULL, 0, fmt, args_copy); va_end(args_copy); - (*xmalloc_error_handler)("vasprintf", status + 1, file, line); + status = (status < 0) ? 0 : status + 1; + (*xmalloc_error_handler)("vasprintf", status, file, line); va_copy(args_copy, args); status = vasprintf(strp, fmt, args_copy); va_end(args_copy); @@ -231,7 +252,8 @@ x_asprintf(char **strp, const char *file, int line, const char *fmt, ...) va_copy(args_copy, args); status = vsnprintf(NULL, 0, fmt, args_copy); va_end(args_copy); - (*xmalloc_error_handler)("asprintf", status + 1, file, line); + status = (status < 0) ? 0 : status + 1; + (*xmalloc_error_handler)("asprintf", status, file, line); va_copy(args_copy, args); status = vasprintf(strp, fmt, args_copy); va_end(args_copy); @@ -252,7 +274,8 @@ x_asprintf(char **strp, const char *fmt, ...) va_copy(args_copy, args); status = vsnprintf(NULL, 0, fmt, args_copy); va_end(args_copy); - (*xmalloc_error_handler)("asprintf", status + 1, __FILE__, __LINE__); + status = (status < 0) ? 0 : status + 1; + (*xmalloc_error_handler)("asprintf", status, __FILE__, __LINE__); va_copy(args_copy, args); status = vasprintf(strp, fmt, args_copy); va_end(args_copy); diff --git a/util/xmalloc.h b/util/xmalloc.h index 55a0b91..a4b4686 100644 --- a/util/xmalloc.h +++ b/util/xmalloc.h @@ -4,7 +4,7 @@ * The canonical version of this file is maintained in the rra-c-util package, * which can be found at . * - * Copyright 2010, 2012 + * Copyright 2010, 2012, 2013, 2014 * The Board of Trustees of the Leland Stanford Junior University * Copyright (c) 2004, 2005, 2006 * by Internet Systems Consortium, Inc. ("ISC") @@ -33,7 +33,8 @@ #include #include -#include +#include +#include /* * The functions are actually macros so that we can pick up the file and line @@ -46,6 +47,8 @@ #define xstrdup(p) x_strdup((p), __FILE__, __LINE__) #define xstrndup(p, size) x_strndup((p), (size), __FILE__, __LINE__) #define xvasprintf(p, f, a) x_vasprintf((p), (f), (a), __FILE__, __LINE__) +#define xreallocarray(p, n, size) \ + x_reallocarray((p), (n), (size), __FILE__, __LINE__) /* * asprintf is a special case since it takes variable arguments. If we have @@ -80,6 +83,8 @@ void *x_malloc(size_t, const char *, int) __attribute__((__alloc_size__(1), __malloc__, __nonnull__)); void *x_realloc(void *, size_t, const char *, int) __attribute__((__alloc_size__(2), __malloc__, __nonnull__(3))); +void *x_reallocarray(void *, size_t, size_t, const char *, int) + __attribute__((__alloc_size__(2, 3), __malloc__, __nonnull__(4))); char *x_strdup(const char *, const char *, int) __attribute__((__malloc__, __nonnull__)); char *x_strndup(const char *, size_t, const char *, int) @@ -96,7 +101,11 @@ void x_asprintf(char **, const char *, ...) __attribute__((__nonnull__, __format__(printf, 2, 3))); #endif -/* Failure handler takes the function, the size, the file, and the line. */ +/* + * Failure handler takes the function, the size, the file, and the line. The + * size will be zero if the failure was due to some failure in snprintf + * instead of a memory allocation failure. + */ typedef void (*xmalloc_handler_type)(const char *, size_t, const char *, int); /* The default error handler. */ -- cgit v1.2.3 From 1575d5c34a2c6235bbf6a5010f8a8c142fe47079 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 11 Jul 2014 21:39:23 -0700 Subject: Switch to Module::Build for the Perl module The wallet server now requires Perl 5.8 or later (instead of 5.006 in previous versions) and is now built with Module::Build instead of ExtUtils::MakeMaker. This should be transparent to anyone not working with the source code, since Perl 5.8 was released in 2002, but Module::Build is now required to build the wallet server. It is included in some versions of Perl, or can be installed separately from CPAN, distribution packages, or other sources. Also reorganize the test suite to use subdirectories. Change-Id: Id06120ba2bad1ebbfee3d8a48ca2f25869463165 Reviewed-on: https://gerrit.stanford.edu/1530 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- .gitignore | 6 +- Makefile.am | 153 ++-- NEWS | 8 + README | 15 +- configure.ac | 2 +- perl/Build.PL | 46 + perl/MANIFEST | 84 ++ perl/MANIFEST.SKIP | 41 + perl/Makefile.PL.in | 18 - perl/Wallet/ACL.pm | 657 -------------- perl/Wallet/ACL/Base.pm | 125 --- perl/Wallet/ACL/Krb5.pm | 125 --- perl/Wallet/ACL/Krb5/Regex.pm | 133 --- perl/Wallet/ACL/LDAP/Attribute.pm | 263 ------ perl/Wallet/ACL/NetDB.pm | 267 ------ perl/Wallet/ACL/NetDB/Root.pm | 128 --- perl/Wallet/Admin.pm | 379 -------- perl/Wallet/Config.pm | 826 ------------------ perl/Wallet/Database.pm | 123 --- perl/Wallet/Kadmin.pm | 240 ------ perl/Wallet/Kadmin/Heimdal.pm | 314 ------- perl/Wallet/Kadmin/MIT.pm | 323 ------- perl/Wallet/Object/Base.pm | 1015 ---------------------- perl/Wallet/Object/Duo.pm | 331 ------- perl/Wallet/Object/File.pm | 242 ------ perl/Wallet/Object/Keytab.pm | 513 ----------- perl/Wallet/Object/WAKeyring.pm | 370 -------- perl/Wallet/Policy/Stanford.pm | 422 --------- perl/Wallet/Report.pm | 680 --------------- perl/Wallet/Schema.pm | 354 -------- perl/Wallet/Schema/Result/Acl.pm | 110 --- perl/Wallet/Schema/Result/AclEntry.pm | 74 -- perl/Wallet/Schema/Result/AclHistory.pm | 113 --- perl/Wallet/Schema/Result/AclScheme.pm | 84 -- perl/Wallet/Schema/Result/Duo.pm | 53 -- perl/Wallet/Schema/Result/Enctype.pm | 45 - perl/Wallet/Schema/Result/Flag.pm | 62 -- perl/Wallet/Schema/Result/KeytabEnctype.pm | 53 -- perl/Wallet/Schema/Result/KeytabSync.pm | 53 -- perl/Wallet/Schema/Result/Object.pm | 266 ------ perl/Wallet/Schema/Result/ObjectHistory.pm | 135 --- perl/Wallet/Schema/Result/SyncTarget.pm | 48 -- perl/Wallet/Schema/Result/Type.pm | 75 -- perl/Wallet/Server.pm | 1095 ------------------------ perl/lib/Wallet/ACL.pm | 657 ++++++++++++++ perl/lib/Wallet/ACL/Base.pm | 125 +++ perl/lib/Wallet/ACL/Krb5.pm | 125 +++ perl/lib/Wallet/ACL/Krb5/Regex.pm | 133 +++ perl/lib/Wallet/ACL/LDAP/Attribute.pm | 263 ++++++ perl/lib/Wallet/ACL/NetDB.pm | 267 ++++++ perl/lib/Wallet/ACL/NetDB/Root.pm | 128 +++ perl/lib/Wallet/Admin.pm | 379 ++++++++ perl/lib/Wallet/Config.pm | 826 ++++++++++++++++++ perl/lib/Wallet/Database.pm | 123 +++ perl/lib/Wallet/Kadmin.pm | 240 ++++++ perl/lib/Wallet/Kadmin/Heimdal.pm | 314 +++++++ perl/lib/Wallet/Kadmin/MIT.pm | 323 +++++++ perl/lib/Wallet/Object/Base.pm | 1015 ++++++++++++++++++++++ perl/lib/Wallet/Object/Duo.pm | 331 +++++++ perl/lib/Wallet/Object/File.pm | 242 ++++++ perl/lib/Wallet/Object/Keytab.pm | 513 +++++++++++ perl/lib/Wallet/Object/WAKeyring.pm | 370 ++++++++ perl/lib/Wallet/Policy/Stanford.pm | 422 +++++++++ perl/lib/Wallet/Report.pm | 680 +++++++++++++++ perl/lib/Wallet/Schema.pm | 354 ++++++++ perl/lib/Wallet/Schema/Result/Acl.pm | 110 +++ perl/lib/Wallet/Schema/Result/AclEntry.pm | 74 ++ perl/lib/Wallet/Schema/Result/AclHistory.pm | 113 +++ perl/lib/Wallet/Schema/Result/AclScheme.pm | 84 ++ perl/lib/Wallet/Schema/Result/Duo.pm | 53 ++ perl/lib/Wallet/Schema/Result/Enctype.pm | 45 + perl/lib/Wallet/Schema/Result/Flag.pm | 62 ++ perl/lib/Wallet/Schema/Result/KeytabEnctype.pm | 53 ++ perl/lib/Wallet/Schema/Result/KeytabSync.pm | 53 ++ perl/lib/Wallet/Schema/Result/Object.pm | 266 ++++++ perl/lib/Wallet/Schema/Result/ObjectHistory.pm | 135 +++ perl/lib/Wallet/Schema/Result/SyncTarget.pm | 48 ++ perl/lib/Wallet/Schema/Result/Type.pm | 75 ++ perl/lib/Wallet/Server.pm | 1095 ++++++++++++++++++++++++ perl/t/acl.t | 232 ----- perl/t/admin.t | 106 --- perl/t/config.t | 44 - perl/t/docs/pod-spelling.t | 74 ++ perl/t/docs/pod.t | 15 + perl/t/duo.t | 157 ---- perl/t/file.t | 150 ---- perl/t/general/acl.t | 232 +++++ perl/t/general/admin.t | 106 +++ perl/t/general/config.t | 44 + perl/t/general/init.t | 58 ++ perl/t/general/report.t | 330 +++++++ perl/t/general/server.t | 1040 ++++++++++++++++++++++ perl/t/init.t | 58 -- perl/t/kadmin.t | 117 --- perl/t/keytab.t | 771 ----------------- perl/t/object.t | 353 -------- perl/t/object/base.t | 353 ++++++++ perl/t/object/duo.t | 157 ++++ perl/t/object/file.t | 150 ++++ perl/t/object/keytab.t | 771 +++++++++++++++++ perl/t/object/wa-keyring.t | 184 ++++ perl/t/pod-spelling.t | 74 -- perl/t/pod.t | 15 - perl/t/policy/stanford.t | 260 ++++++ perl/t/report.t | 330 ------- perl/t/server.t | 1040 ---------------------- perl/t/stanford-naming.t | 260 ------ perl/t/util/kadmin.t | 117 +++ perl/t/verifier-ldap-attr.t | 73 -- perl/t/verifier-netdb.t | 45 - perl/t/verifier.t | 155 ---- perl/t/verifier/basic.t | 155 ++++ perl/t/verifier/ldap-attr.t | 73 ++ perl/t/verifier/netdb.t | 45 + perl/t/wa-keyring.t | 184 ---- tests/client/full-t.in | 2 +- tests/client/prompt-t.in | 4 +- tests/data/cmd-wrapper | 2 +- 118 files changed, 14548 insertions(+), 14353 deletions(-) create mode 100644 perl/Build.PL create mode 100644 perl/MANIFEST create mode 100644 perl/MANIFEST.SKIP delete mode 100644 perl/Makefile.PL.in delete mode 100644 perl/Wallet/ACL.pm delete mode 100644 perl/Wallet/ACL/Base.pm delete mode 100644 perl/Wallet/ACL/Krb5.pm delete mode 100644 perl/Wallet/ACL/Krb5/Regex.pm delete mode 100644 perl/Wallet/ACL/LDAP/Attribute.pm delete mode 100644 perl/Wallet/ACL/NetDB.pm delete mode 100644 perl/Wallet/ACL/NetDB/Root.pm delete mode 100644 perl/Wallet/Admin.pm delete mode 100644 perl/Wallet/Config.pm delete mode 100644 perl/Wallet/Database.pm delete mode 100644 perl/Wallet/Kadmin.pm delete mode 100644 perl/Wallet/Kadmin/Heimdal.pm delete mode 100644 perl/Wallet/Kadmin/MIT.pm delete mode 100644 perl/Wallet/Object/Base.pm delete mode 100644 perl/Wallet/Object/Duo.pm delete mode 100644 perl/Wallet/Object/File.pm delete mode 100644 perl/Wallet/Object/Keytab.pm delete mode 100644 perl/Wallet/Object/WAKeyring.pm delete mode 100644 perl/Wallet/Policy/Stanford.pm delete mode 100644 perl/Wallet/Report.pm delete mode 100644 perl/Wallet/Schema.pm delete mode 100644 perl/Wallet/Schema/Result/Acl.pm delete mode 100644 perl/Wallet/Schema/Result/AclEntry.pm delete mode 100644 perl/Wallet/Schema/Result/AclHistory.pm delete mode 100644 perl/Wallet/Schema/Result/AclScheme.pm delete mode 100644 perl/Wallet/Schema/Result/Duo.pm delete mode 100644 perl/Wallet/Schema/Result/Enctype.pm delete mode 100644 perl/Wallet/Schema/Result/Flag.pm delete mode 100644 perl/Wallet/Schema/Result/KeytabEnctype.pm delete mode 100644 perl/Wallet/Schema/Result/KeytabSync.pm delete mode 100644 perl/Wallet/Schema/Result/Object.pm delete mode 100644 perl/Wallet/Schema/Result/ObjectHistory.pm delete mode 100644 perl/Wallet/Schema/Result/SyncTarget.pm delete mode 100644 perl/Wallet/Schema/Result/Type.pm delete mode 100644 perl/Wallet/Server.pm create mode 100644 perl/lib/Wallet/ACL.pm create mode 100644 perl/lib/Wallet/ACL/Base.pm create mode 100644 perl/lib/Wallet/ACL/Krb5.pm create mode 100644 perl/lib/Wallet/ACL/Krb5/Regex.pm create mode 100644 perl/lib/Wallet/ACL/LDAP/Attribute.pm create mode 100644 perl/lib/Wallet/ACL/NetDB.pm create mode 100644 perl/lib/Wallet/ACL/NetDB/Root.pm create mode 100644 perl/lib/Wallet/Admin.pm create mode 100644 perl/lib/Wallet/Config.pm create mode 100644 perl/lib/Wallet/Database.pm create mode 100644 perl/lib/Wallet/Kadmin.pm create mode 100644 perl/lib/Wallet/Kadmin/Heimdal.pm create mode 100644 perl/lib/Wallet/Kadmin/MIT.pm create mode 100644 perl/lib/Wallet/Object/Base.pm create mode 100644 perl/lib/Wallet/Object/Duo.pm create mode 100644 perl/lib/Wallet/Object/File.pm create mode 100644 perl/lib/Wallet/Object/Keytab.pm create mode 100644 perl/lib/Wallet/Object/WAKeyring.pm create mode 100644 perl/lib/Wallet/Policy/Stanford.pm create mode 100644 perl/lib/Wallet/Report.pm create mode 100644 perl/lib/Wallet/Schema.pm create mode 100644 perl/lib/Wallet/Schema/Result/Acl.pm create mode 100644 perl/lib/Wallet/Schema/Result/AclEntry.pm create mode 100644 perl/lib/Wallet/Schema/Result/AclHistory.pm create mode 100644 perl/lib/Wallet/Schema/Result/AclScheme.pm create mode 100644 perl/lib/Wallet/Schema/Result/Duo.pm create mode 100644 perl/lib/Wallet/Schema/Result/Enctype.pm create mode 100644 perl/lib/Wallet/Schema/Result/Flag.pm create mode 100644 perl/lib/Wallet/Schema/Result/KeytabEnctype.pm create mode 100644 perl/lib/Wallet/Schema/Result/KeytabSync.pm create mode 100644 perl/lib/Wallet/Schema/Result/Object.pm create mode 100644 perl/lib/Wallet/Schema/Result/ObjectHistory.pm create mode 100644 perl/lib/Wallet/Schema/Result/SyncTarget.pm create mode 100644 perl/lib/Wallet/Schema/Result/Type.pm create mode 100644 perl/lib/Wallet/Server.pm delete mode 100755 perl/t/acl.t delete mode 100755 perl/t/admin.t delete mode 100755 perl/t/config.t create mode 100755 perl/t/docs/pod-spelling.t create mode 100755 perl/t/docs/pod.t delete mode 100755 perl/t/duo.t delete mode 100755 perl/t/file.t create mode 100755 perl/t/general/acl.t create mode 100755 perl/t/general/admin.t create mode 100755 perl/t/general/config.t create mode 100755 perl/t/general/init.t create mode 100755 perl/t/general/report.t create mode 100755 perl/t/general/server.t delete mode 100755 perl/t/init.t delete mode 100755 perl/t/kadmin.t delete mode 100755 perl/t/keytab.t delete mode 100755 perl/t/object.t create mode 100755 perl/t/object/base.t create mode 100755 perl/t/object/duo.t create mode 100755 perl/t/object/file.t create mode 100755 perl/t/object/keytab.t create mode 100755 perl/t/object/wa-keyring.t delete mode 100755 perl/t/pod-spelling.t delete mode 100755 perl/t/pod.t create mode 100755 perl/t/policy/stanford.t delete mode 100755 perl/t/report.t delete mode 100755 perl/t/server.t delete mode 100755 perl/t/stanford-naming.t create mode 100755 perl/t/util/kadmin.t delete mode 100755 perl/t/verifier-ldap-attr.t delete mode 100755 perl/t/verifier-netdb.t delete mode 100755 perl/t/verifier.t create mode 100755 perl/t/verifier/basic.t create mode 100755 perl/t/verifier/ldap-attr.t create mode 100755 perl/t/verifier/netdb.t delete mode 100755 perl/t/wa-keyring.t (limited to 'Makefile.am') diff --git a/.gitignore b/.gitignore index fdba4a0..86f4a1c 100644 --- a/.gitignore +++ b/.gitignore @@ -9,16 +9,18 @@ /config.log /config.status /configure +/perl/Build /perl/MYMETA.json /perl/MYMETA.yml -/perl/Makefile.PL -/perl/Makefile.old +/perl/_build/ /perl/blib/ /perl/pm_to_blib /perl/t/data/test.keytab /perl/t/data/test.principal /perl/t/data/test.realm /perl/t/data/test.krbtype +/perl/t/lib/Test/RRA.pm +/perl/t/lib/Test/RRA/ /tests/client/basic-t /tests/client/full-t /tests/client/prompt-t diff --git a/Makefile.am b/Makefile.am index 82b84f7..19dbe11 100644 --- a/Makefile.am +++ b/Makefile.am @@ -6,54 +6,78 @@ # # See LICENSE for licensing terms. +# These variables exist only for the use of the Debian packaging and similar +# situations and aren't normally set. We want to honor them if they're set +# in the environment, as well as via make arguments. +# +# WALLET_PERL_FLAGS are additional flags to pass to Build.PL when building +# the Makefile. +WALLET_PERL_FLAGS ?= + # These two lists of files are needed for Perl builds and for the test suite # and are not generated or touched by configure. They're listed here to be # added to EXTRA_DIST and so that they can be copied over properly for # builddir != srcdir builds. -PERL_FILES = perl/Wallet/ACL.pm perl/Wallet/ACL/Base.pm \ - perl/Wallet/ACL/Krb5.pm perl/Wallet/ACL/Krb5/Regex.pm \ - perl/Wallet/ACL/LDAP/Attribute.pm perl/Wallet/ACL/NetDB.pm \ - perl/Wallet/ACL/NetDB/Root.pm perl/Wallet/Admin.pm \ - perl/Wallet/Config.pm perl/Wallet/Database.pm perl/Wallet/Kadmin.pm \ - perl/Wallet/Kadmin/Heimdal.pm perl/Wallet/Kadmin/MIT.pm \ - perl/Wallet/Object/Base.pm perl/Wallet/Object/Duo.pm \ - perl/Wallet/Object/File.pm perl/Wallet/Object/Keytab.pm \ - perl/Wallet/Object/WAKeyring.pm perl/Wallet/Policy/Stanford.pm \ - perl/Wallet/Report.pm perl/Wallet/Schema.pm perl/Wallet/Server.pm \ - perl/Wallet/Schema/Result/Acl.pm \ - perl/Wallet/Schema/Result/AclEntry.pm \ - perl/Wallet/Schema/Result/AclHistory.pm \ - perl/Wallet/Schema/Result/AclScheme.pm \ - perl/Wallet/Schema/Result/Duo.pm \ - perl/Wallet/Schema/Result/Enctype.pm \ - perl/Wallet/Schema/Result/Flag.pm \ - perl/Wallet/Schema/Result/KeytabEnctype.pm \ - perl/Wallet/Schema/Result/KeytabSync.pm \ - perl/Wallet/Schema/Result/Object.pm \ - perl/Wallet/Schema/Result/ObjectHistory.pm \ - perl/Wallet/Schema/Result/SyncTarget.pm \ - perl/Wallet/Schema/Result/Type.pm \ - perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql \ - perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql \ - perl/sql/Wallet-Schema-0.07-MySQL.sql \ - perl/sql/Wallet-Schema-0.07-SQLite.sql \ - perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql \ - perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql \ - perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql \ - perl/sql/Wallet-Schema-0.08-MySQL.sql \ - perl/sql/Wallet-Schema-0.08-PostgreSQL.sql \ - perl/sql/Wallet-Schema-0.08-SQLite.sql \ - perl/sql/Wallet-Schema-0.09-MySQL.sql \ - perl/sql/Wallet-Schema-0.09-PostgreSQL.sql \ - perl/sql/Wallet-Schema-0.09-SQLite.sql perl/t/acl.t perl/t/admin.t \ - perl/t/config.t perl/t/data/README perl/t/data/duo/integration.json \ - perl/t/data/duo/keys.json perl/t/data/keytab-fake \ - perl/t/data/keytab.conf perl/t/data/netdb.conf \ - perl/t/data/netdb-fake perl/t/duo.t perl/t/file.t perl/t/init.t \ - perl/t/kadmin.t perl/t/keytab.t perl/t/lib/Util.pm perl/t/object.t \ - perl/t/pod-spelling.t perl/t/pod.t perl/t/report.t perl/t/server.t \ - perl/t/stanford-naming.t perl/t/verifier-ldap-attr.t \ - perl/t/verifier-netdb.t perl/t/verifier.t perl/t/wa-keyring.t +PERL_FILES = perl/Build.PL perl/MANIFEST perl/MANIFEST.SKIP \ + perl/lib/Wallet/ACL.pm perl/lib/Wallet/ACL/Base.pm \ + perl/lib/Wallet/ACL/Krb5.pm perl/lib/Wallet/ACL/Krb5/Regex.pm \ + perl/lib/Wallet/ACL/LDAP/Attribute.pm perl/lib/Wallet/ACL/NetDB.pm \ + perl/lib/Wallet/ACL/NetDB/Root.pm perl/lib/Wallet/Admin.pm \ + perl/lib/Wallet/Config.pm perl/lib/Wallet/Database.pm \ + perl/lib/Wallet/Kadmin.pm perl/lib/Wallet/Kadmin/Heimdal.pm \ + perl/lib/Wallet/Kadmin/MIT.pm perl/lib/Wallet/Object/Base.pm \ + perl/lib/Wallet/Object/Duo.pm perl/lib/Wallet/Object/File.pm \ + perl/lib/Wallet/Object/Keytab.pm \ + perl/lib/Wallet/Object/WAKeyring.pm \ + perl/lib/Wallet/Policy/Stanford.pm perl/lib/Wallet/Report.pm \ + perl/lib/Wallet/Schema.pm perl/lib/Wallet/Server.pm \ + perl/lib/Wallet/Schema/Result/Acl.pm \ + perl/lib/Wallet/Schema/Result/AclEntry.pm \ + perl/lib/Wallet/Schema/Result/AclHistory.pm \ + perl/lib/Wallet/Schema/Result/AclScheme.pm \ + perl/lib/Wallet/Schema/Result/Duo.pm \ + perl/lib/Wallet/Schema/Result/Enctype.pm \ + perl/lib/Wallet/Schema/Result/Flag.pm \ + perl/lib/Wallet/Schema/Result/KeytabEnctype.pm \ + perl/lib/Wallet/Schema/Result/KeytabSync.pm \ + perl/lib/Wallet/Schema/Result/Object.pm \ + perl/lib/Wallet/Schema/Result/ObjectHistory.pm \ + perl/lib/Wallet/Schema/Result/SyncTarget.pm \ + perl/lib/Wallet/Schema/Result/Type.pm \ + perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql \ + perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql \ + perl/sql/Wallet-Schema-0.07-MySQL.sql \ + perl/sql/Wallet-Schema-0.07-SQLite.sql \ + perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql \ + perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql \ + perl/sql/Wallet-Schema-0.08-MySQL.sql \ + perl/sql/Wallet-Schema-0.08-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.08-SQLite.sql \ + perl/sql/Wallet-Schema-0.09-MySQL.sql \ + perl/sql/Wallet-Schema-0.09-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.09-SQLite.sql perl/t/data/README \ + perl/t/data/duo/integration.json perl/t/data/duo/keys.json \ + perl/t/data/keytab-fake perl/t/data/keytab.conf \ + perl/t/data/netdb.conf perl/t/data/netdb-fake \ + perl/t/docs/pod-spelling.t perl/t/docs/pod.t perl/t/general/acl.t \ + perl/t/general/admin.t perl/t/general/config.t \ + perl/t/general/init.t perl/t/general/report.t \ + perl/t/general/server.t perl/t/lib/Util.pm perl/t/object/base.t \ + perl/t/object/duo.t perl/t/object/file.t perl/t/object/keytab.t \ + perl/t/object/wa-keyring.t perl/t/policy/stanford.t \ + perl/t/util/kadmin.t perl/t/verifier/basic.t \ + perl/t/verifier/ldap-attr.t perl/t/verifier/netdb.t + +# Directories that have to be created in builddir != srcdir builds before +# copying PERL_FILES over. +PERL_DIRECTORIES = perl perl/lib perl/lib/Wallet perl/lib/Wallet/ACL \ + perl/lib/Wallet/ACL/Krb5 perl/lib/Wallet/ACL/LDAP \ + perl/lib/Wallet/ACL/NetDB perl/lib/Wallet/Kadmin \ + perl/lib/Wallet/Object perl/lib/Wallet/Policy \ + perl/lib/Wallet/Schema perl/lib/Wallet/Schema/Result perl/sql \ + perl/t perl/t/data perl/t/docs perl/t/general perl/t/lib \ + perl/t/object perl/t/policy perl/t/util perl/t/verifier ACLOCAL_AMFLAGS = -I m4 EXTRA_DIST = .gitignore LICENSE autogen client/wallet.pod \ @@ -82,6 +106,7 @@ EXTRA_DIST = .gitignore LICENSE autogen client/wallet.pod \ tests/tap/perl/Test/RRA/Config.pm tests/tap/remctl.sh \ tests/util/xmalloc-t $(PERL_FILES) +# Supporting convenience libraries used by other targets. noinst_LIBRARIES = portable/libportable.a util/libutil.a portable_libportable_a_SOURCES = portable/dummy.c portable/krb5-extra.c \ portable/krb5.h portable/macros.h portable/stdbool.h \ @@ -93,11 +118,13 @@ util_libutil_a_SOURCES = util/macros.h util/messages-krb5.c \ util/xmalloc.h util_libutil_a_CPPFLAGS = $(KRB5_CPPFLAGS) +# The private library used by both wallet and wallet-rekey. noinst_LIBRARIES += client/libwallet.a client_libwallet_a_SOURCES = client/file.c client/internal.h client/keytab.c \ client/krb5.c client/options.c client/remctl.c client/srvtab.c client_libwallet_a_CPPFLAGS = $(REMCTL_CPPFLAGS) $(KRB5_CPPFLAGS) +# The client and server programs. bin_PROGRAMS = client/wallet client/wallet-rekey dist_sbin_SCRIPTS = server/keytab-backend server/wallet-admin \ server/wallet-backend server/wallet-report @@ -110,6 +137,7 @@ client_wallet_rekey_LDFLAGS = $(REMCTL_LDFLAGS) $(KRB5_LDFLAGS) client_wallet_rekey_LDADD = client/libwallet.a util/libutil.a \ portable/libportable.a $(REMCTL_LIBS) $(KRB5_LIBS) +# The manual pages. dist_man_MANS = client/wallet.1 client/wallet-rekey.1 server/keytab-backend.8 \ server/wallet-admin.8 server/wallet-backend.8 server/wallet-report.8 @@ -151,7 +179,8 @@ warnings: KRB5_CPPFLAGS='$(KRB5_CPPFLAGS_GCC)' $(check_PROGRAMS) # Remove some additional files. -DISTCLEANFILES = perl/Makefile +CLEANFILES = perl/t/lib/Test/RRA.pm perl/t/lib/Test/RRA/Automake.pm \ + perl/t/lib/Test/RRA/Config.pm MAINTAINERCLEANFILES = Makefile.in aclocal.m4 build-aux/compile \ build-aux/depcomp build-aux/install-sh build-aux/missing \ client/wallet.1 config.h.in config.h.in~ configure \ @@ -164,19 +193,18 @@ MAINTAINERCLEANFILES = Makefile.in aclocal.m4 build-aux/compile \ # packaging. all-local: perl/blib/lib/Wallet/Config.pm -perl/blib/lib/Wallet/Config.pm: - set -e; if [ x"$(builddir)" != x"$(srcdir)" ] ; then \ - mkdir perl/Wallet perl/Wallet/ACL perl/Wallet/ACL/Krb5 \ - perl/Wallet/ACL/LDAP perl/Wallet/ACL/NetDB \ - perl/Wallet/Kadmin perl/Wallet/Object perl/Wallet/Policy \ - perl/Wallet/Schema perl/Wallet/Schema/Result perl/sql perl/t \ - perl/t/data perl/t/lib 2>/dev/null || true ; \ - for f in $(PERL_FILES) ; do \ - cp "$(srcdir)/$$f" "$(builddir)/$$f" ; \ - done \ +perl/blib/lib/Wallet/Config.pm: $(srcdir)/perl/lib/Wallet/Config.pm + set -e; if [ x"$(builddir)" != x"$(srcdir)" ] ; then \ + for d in $(PERL_DIRECTORIES) ; do \ + [ -d "$(builddir)/$$d" ] || mkdir "$(builddir)/$$d" ; \ + done ; \ + for f in $(PERL_FILES) ; do \ + cp "$(srcdir)/$$f" "$(builddir)/$$f" ; \ + done ; \ fi - cd perl && perl Makefile.PL - cd perl && $(MAKE) + cp -R $(srcdir)/tests/tap/perl/* perl/t/lib/ + cd perl && perl Build.PL $(WALLET_PERL_FLAGS) + cd perl && ./Build install-data-local: if [ x"$(DESTDIR)" != x ] ; then \ @@ -187,13 +215,16 @@ install-data-local: # ExtUtils::MakeMaker really likes moving the Makefile aside. clean-local: - [ ! -f perl/Makefile ] || ( set -e; cd perl && $(MAKE) clean ) - cd perl && ( [ ! -f Makefile.old ] || mv Makefile.old Makefile ) + set -e; if [ -f "perl/Build" ] ; then \ + cd perl && ./Build realclean ; \ + fi # Remove the files that we copy over if and only if builddir != srcdir. distclean-local: set -e; if [ x"$(builddir)" != x"$(srcdir)" ] ; then \ - rm -f $(PERL_FILES) ; \ + for f in $(PERL_FILES) ; do \ + rm -f "$(builddir)/$$f" ; \ + done ; \ fi # The bits below are for the test suite, not for the main package. @@ -241,7 +272,7 @@ tests_util_xmalloc_LDADD = util/libutil.a portable/libportable.a check-local: $(check_PROGRAMS) cd tests && ./runtests -l $(abs_top_srcdir)/tests/TESTS @echo '' - cd perl && $(MAKE) test + cd perl && ./Build test # Alas, we have to disable this check because there's no way to do an # uninstall from Perl. diff --git a/NEWS b/NEWS index 76ddfd1..e40b80d 100644 --- a/NEWS +++ b/NEWS @@ -39,6 +39,14 @@ wallet 1.1 (unreleased) and an incorrect linkage in the schema for the ACL history, and add indices for the object type, name, and ACL instead. + The wallet server now requires Perl 5.8 or later (instead of 5.006 in + previous versions) and is now built with Module::Build instead of + ExtUtils::MakeMaker. This should be transparent to anyone not working + with the source code, since Perl 5.8 was released in 2002, but + Module::Build is now required to build the wallet server. It is + included in some versions of Perl, or can be installed separately from + CPAN, distribution packages, or other sources. + Update to rra-c-util 5.5: * Use Lancaster Consensus environment variables to control tests. diff --git a/README b/README index 85a6299..e72bc80 100644 --- a/README +++ b/README @@ -64,13 +64,14 @@ REQUIREMENTS The wallet client will build with either MIT Kerberos or Heimdal. - The wallet server is written in Perl and requires Perl 5.6.0 or later. - It uses DBIx::Class and DBI to talk to a database, and therefore the - DBIx::Class and DBI modules (and their dependencies) and a DBD module - for the database it will use must be installed. The SQL::Translator - Perl module is also required for schema deployment and database - upgrades. If the wallet server is used with a SQLite 3 database, the - Perl module DateTime::Format::SQLite should also be installed. + The wallet server is written in Perl and requires Perl 5.6.0 or later + plus Module::Build to build. It uses DBIx::Class and DBI to talk to a + database, and therefore the DBIx::Class and DBI modules (and their + dependencies) and a DBD module for the database it will use must be + installed. The SQL::Translator Perl module is also required for schema + deployment and database upgrades. If the wallet server is used with a + SQLite 3 database, the Perl module DateTime::Format::SQLite should also + be installed. Currently, the server has only been tested against SQLite 3, MySQL 5, and PostgreSQL, and prebuilt SQL files (for database upgrades) are only diff --git a/configure.ac b/configure.ac index b1b335d..d49c7b5 100644 --- a/configure.ac +++ b/configure.ac @@ -75,7 +75,7 @@ AS_IF([test x"$REMCTLD" != x], dnl Output section. AC_CONFIG_HEADER([config.h]) -AC_CONFIG_FILES([Makefile perl/Makefile.PL]) +AC_CONFIG_FILES([Makefile]) AC_CONFIG_FILES([tests/client/basic-t], [chmod +x tests/client/basic-t]) AC_CONFIG_FILES([tests/client/full-t], [chmod +x tests/client/full-t]) AC_CONFIG_FILES([tests/client/prompt-t], [chmod +x tests/client/prompt-t]) diff --git a/perl/Build.PL b/perl/Build.PL new file mode 100644 index 0000000..3d3bcdc --- /dev/null +++ b/perl/Build.PL @@ -0,0 +1,46 @@ +#!/usr/bin/perl +# +# Build script for the wallet distribution. +# +# Written by Russ Allbery +# Copyright 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use 5.006; +use strict; +use warnings; + +use Module::Build; + +# Basic package configuration. +my $build = Module::Build->new( + dist_abstract => 'Secure credential management system', + dist_author => 'Russ Allbery ', + dist_name => 'Wallet', + dist_version => '1.01', + license => 'mit', + recursive_test_files => 1, + + # Other package relationships. + configure_requires => { 'Module::Build' => 0.28 }, + requires => { + 'DBIx::Class' => 0, + DBI => 0, + 'Digest::MD5' => 0, + 'SQL::Translator' => 0, + perl => '5.006', + }, + recommends => { + 'Authen::SASL' => 0, + 'Heimdal::Kadm5' => 0, + 'Net::Duo' => 0, + 'Net::LDAP' => 0, + 'Net::Remctl' => 0, + WebAuth => 0, + }, +); + +# Generate the build script. +$build->create_build_script; diff --git a/perl/MANIFEST b/perl/MANIFEST new file mode 100644 index 0000000..7f67987 --- /dev/null +++ b/perl/MANIFEST @@ -0,0 +1,84 @@ +Build.PL +create-ddl +lib/Wallet/ACL.pm +lib/Wallet/ACL/Base.pm +lib/Wallet/ACL/Krb5.pm +lib/Wallet/ACL/Krb5/Regex.pm +lib/Wallet/ACL/LDAP/Attribute.pm +lib/Wallet/ACL/NetDB.pm +lib/Wallet/ACL/NetDB/Root.pm +lib/Wallet/Admin.pm +lib/Wallet/Config.pm +lib/Wallet/Database.pm +lib/Wallet/Kadmin.pm +lib/Wallet/Kadmin/Heimdal.pm +lib/Wallet/Kadmin/MIT.pm +lib/Wallet/Object/Base.pm +lib/Wallet/Object/Duo.pm +lib/Wallet/Object/File.pm +lib/Wallet/Object/Keytab.pm +lib/Wallet/Object/WAKeyring.pm +lib/Wallet/Policy/Stanford.pm +lib/Wallet/Report.pm +lib/Wallet/Schema.pm +lib/Wallet/Schema/Result/Acl.pm +lib/Wallet/Schema/Result/AclEntry.pm +lib/Wallet/Schema/Result/AclHistory.pm +lib/Wallet/Schema/Result/AclScheme.pm +lib/Wallet/Schema/Result/Duo.pm +lib/Wallet/Schema/Result/Enctype.pm +lib/Wallet/Schema/Result/Flag.pm +lib/Wallet/Schema/Result/KeytabEnctype.pm +lib/Wallet/Schema/Result/KeytabSync.pm +lib/Wallet/Schema/Result/Object.pm +lib/Wallet/Schema/Result/ObjectHistory.pm +lib/Wallet/Schema/Result/SyncTarget.pm +lib/Wallet/Schema/Result/Type.pm +lib/Wallet/Server.pm +MANIFEST This list of files +MANIFEST.SKIP +sql/Wallet-Schema-0.07-0.08-MySQL.sql +sql/Wallet-Schema-0.07-0.08-SQLite.sql +sql/Wallet-Schema-0.07-MySQL.sql +sql/Wallet-Schema-0.07-SQLite.sql +sql/Wallet-Schema-0.08-0.09-MySQL.sql +sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql +sql/Wallet-Schema-0.08-0.09-SQLite.sql +sql/Wallet-Schema-0.08-MySQL.sql +sql/Wallet-Schema-0.08-PostgreSQL.sql +sql/Wallet-Schema-0.08-SQLite.sql +sql/Wallet-Schema-0.09-MySQL.sql +sql/Wallet-Schema-0.09-PostgreSQL.sql +sql/Wallet-Schema-0.09-SQLite.sql +t/acl.t +t/admin.t +t/data/duo/integration.json +t/data/duo/keys.json +t/data/keytab-fake +t/data/keytab.conf +t/data/netdb-fake +t/data/netdb.conf +t/data/README +t/data/test.keytab +t/data/test.krbtype +t/data/test.principal +t/data/test.realm +t/duo.t +t/file.t +t/init.t +t/kadmin.t +t/keytab.t +t/lib/Test/RRA.pm +t/lib/Test/RRA/Automake.pm +t/lib/Test/RRA/Config.pm +t/lib/Util.pm +t/object.t +t/pod-spelling.t +t/pod.t +t/report.t +t/server.t +t/stanford-naming.t +t/verifier-ldap-attr.t +t/verifier-netdb.t +t/verifier.t +t/wa-keyring.t diff --git a/perl/MANIFEST.SKIP b/perl/MANIFEST.SKIP new file mode 100644 index 0000000..82fa711 --- /dev/null +++ b/perl/MANIFEST.SKIP @@ -0,0 +1,41 @@ +# -*- conf -*- + +# Avoid generated build files. +\bblib/ + +# Avoid Module::Build generated and utility files. +\bBuild$ +\b_build/ +\bBuild.bat$ +\bBuild.COM$ +\bBUILD.COM$ +\bbuild.com$ + +# Avoid temp and backup files. +~$ +\.old$ +\#$ +\b\.# +\.bak$ +\.tmp$ +\.# +\.rej$ + +# Avoid OS-specific files/dirs +# Mac OSX metadata +\B\.DS_Store +# Mac OSX SMB mount metadata files +\B\._ + +# Avoid Devel::Cover and Devel::CoverX::Covered files. +\bcover_db\b +\bcovered\b + +# Avoid MYMETA files +^MYMETA\. + +# Avoid archives of this distribution +\bWallet-[\d\.\_]+ + +# Avoid local test configuration files. +^t/config diff --git a/perl/Makefile.PL.in b/perl/Makefile.PL.in deleted file mode 100644 index a3038ae..0000000 --- a/perl/Makefile.PL.in +++ /dev/null @@ -1,18 +0,0 @@ -# Makefile.PL for the Wallet Perl library. -*- perl -*- - -use ExtUtils::MakeMaker; - -my $version = '@PACKAGE_VERSION@'; -$version =~ s/\.(\d)$/.0$1/; - -# Set a prefix for ExtUtils::MakeMaker if we were given one for configure. -my $prefix = "@prefix@"; - -WriteMakefile( - NAME => 'Wallet', - VERSION => $version, - ABSTRACT => 'Wallet: a secure credential management system', - AUTHOR => 'Russ Allbery (eagle@eyrie.org)', - (($prefix ne '/usr' && $prefix ne '/usr/local') ? - (PREFIX => $prefix) : ()) -); diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm deleted file mode 100644 index 808be3c..0000000 --- a/perl/Wallet/ACL.pm +++ /dev/null @@ -1,657 +0,0 @@ -# Wallet::ACL -- Implementation of ACLs in the wallet system. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::ACL; -require 5.006; - -use strict; -use vars qw($VERSION); - -use DBI; -use POSIX qw(strftime); - -# 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.07'; - -############################################################################## -# Constructors -############################################################################## - -# Initialize a new ACL from the database. Verify that the ACL already exists -# in the database and, if so, return a new blessed object. Stores the ACL ID -# and the database handle to use for future operations. If the object -# doesn't exist, throws an exception. -sub new { - my ($class, $id, $schema) = @_; - my (%search, $data, $name); - if ($id =~ /^\d+\z/) { - $search{ac_id} = $id; - } else { - $search{ac_name} = $id; - } - eval { - $data = $schema->resultset('Acl')->find (\%search); - }; - if ($@) { - die "cannot search for ACL $id: $@\n"; - } elsif (not defined $data) { - die "ACL $id not found\n"; - } - my $self = { - schema => $schema, - id => $data->ac_id, - name => $data->ac_name, - }; - bless ($self, $class); - return $self; -} - -# Create a new ACL in the database with the given name and return a new -# blessed ACL object for it. Stores the database handle to use and the ID of -# the newly created ACL in the object. On failure, throws an exception. -sub create { - my ($class, $name, $schema, $user, $host, $time) = @_; - if ($name =~ /^\d+\z/) { - die "ACL name may not be all numbers\n"; - } - $time ||= time; - my $id; - eval { - my $guard = $schema->txn_scope_guard; - - # Create the new record. - my %record = (ac_name => $name); - my $acl = $schema->resultset('Acl')->create (\%record); - $id = $acl->ac_id; - die "unable to retrieve new ACL ID" unless defined $id; - - # Add to the history table. - my $date = strftime ('%Y-%m-%d %T', localtime $time); - %record = (ah_acl => $id, - ah_action => 'create', - ah_by => $user, - ah_from => $host, - ah_on => $date); - my $history = $schema->resultset('AclHistory')->create (\%record); - die "unable to create new history entry" unless defined $history; - - $guard->commit; - }; - if ($@) { - die "cannot create ACL $name: $@\n"; - } - my $self = { - schema => $schema, - id => $id, - name => $name, - }; - bless ($self, $class); - return $self; -} - -############################################################################## -# Utility functions -############################################################################## - -# Set or return the error stashed in the object. -sub error { - my ($self, @error) = @_; - if (@error) { - my $error = join ('', @error); - chomp $error; - 1 while ($error =~ s/ at \S+ line \d+\.?\z//); - $self->{error} = $error; - } - return $self->{error}; -} - -# Returns the ID of an ACL. -sub id { - my ($self) = @_; - return $self->{id}; -} - -# Returns the name of the ACL. -sub name { - my ($self)= @_; - return $self->{name}; -} - -# Given an ACL scheme, return the mapping to a class by querying the -# database, or undef if no mapping exists. Also load the relevant module. -sub scheme_mapping { - my ($self, $scheme) = @_; - my $class; - eval { - my %search = (as_name => $scheme); - my $scheme_rec = $self->{schema}->resultset('AclScheme') - ->find (\%search); - $class = $scheme_rec->as_class; - }; - if ($@) { - $self->error ($@); - return; - } - if (defined $class) { - eval "require $class"; - if ($@) { - $self->error ($@); - return; - } - } - return $class; -} - -# Record a change to an ACL. Takes the type of change, the scheme and -# identifier of the entry, and the trace information (user, host, and time). -# This function does not commit and does not catch exceptions. It should -# normally be called as part of a larger transaction that implements the -# change and should be committed with that change. -sub log_acl { - my ($self, $action, $scheme, $identifier, $user, $host, $time) = @_; - unless ($action =~ /^(add|remove)\z/) { - die "invalid history action $action"; - } - my %record = (ah_acl => $self->{id}, - ah_action => $action, - ah_scheme => $scheme, - ah_identifier => $identifier, - ah_by => $user, - ah_from => $host, - ah_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{schema}->resultset('AclHistory')->create (\%record); -} - -############################################################################## -# ACL manipulation -############################################################################## - -# Changes the human-readable name of the ACL. Note that this operation is not -# logged since it isn't a change to any of the data stored in the wallet. -# Returns true on success, false on failure. -sub rename { - my ($self, $name) = @_; - if ($name =~ /^\d+\z/) { - $self->error ("ACL name may not be all numbers"); - return; - } - eval { - my $guard = $self->{schema}->txn_scope_guard; - my %search = (ac_id => $self->{id}); - my $acls = $self->{schema}->resultset('Acl')->find (\%search); - $acls->ac_name ($name); - $acls->update; - $guard->commit; - }; - if ($@) { - $self->error ("cannot rename ACL $self->{id} to $name: $@"); - return; - } - $self->{name} = $name; - return 1; -} - -# Destroy the ACL, deleting it out of the database. Returns true on success, -# false on failure. -# -# Checks to ensure that the ACL is not referenced anywhere in the database, -# since we may not have referential integrity enforcement. It's not clear -# that this is the right place to do this; it's a bit of an abstraction -# violation, since it's a query against the object table. -sub destroy { - my ($self, $user, $host, $time) = @_; - $time ||= time; - eval { - my $guard = $self->{schema}->txn_scope_guard; - - # Make certain no one is using the ACL. - my @search = ({ ob_owner => $self->{id} }, - { ob_acl_get => $self->{id} }, - { ob_acl_store => $self->{id} }, - { ob_acl_show => $self->{id} }, - { ob_acl_destroy => $self->{id} }, - { ob_acl_flags => $self->{id} }); - my @entries = $self->{schema}->resultset('Object')->search (\@search); - if (@entries) { - my ($entry) = @entries; - die "ACL in use by ".$entry->ob_type.":".$entry->ob_name; - } - - # Delete any entries (there may or may not be any). - my %search = (ae_id => $self->{id}); - @entries = $self->{schema}->resultset('AclEntry')->search(\%search); - for my $entry (@entries) { - $entry->delete; - } - - # There should definitely be an ACL record to delete. - %search = (ac_id => $self->{id}); - my $entry = $self->{schema}->resultset('Acl')->find(\%search); - $entry->delete if defined $entry; - - # Create new history line for the deletion. - my %record = (ah_acl => $self->{id}, - ah_action => 'destroy', - ah_by => $user, - ah_from => $host, - ah_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{schema}->resultset('AclHistory')->create (\%record); - $guard->commit; - }; - if ($@) { - $self->error ("cannot destroy ACL $self->{id}: $@"); - return; - } - return 1; -} - -############################################################################## -# ACL entry manipulation -############################################################################## - -# Add an ACL entry to this ACL. Returns true on success and false on failure. -sub add { - my ($self, $scheme, $identifier, $user, $host, $time) = @_; - $time ||= time; - unless ($self->scheme_mapping ($scheme)) { - $self->error ("unknown ACL scheme $scheme"); - return; - } - eval { - my $guard = $self->{schema}->txn_scope_guard; - my %record = (ae_id => $self->{id}, - ae_scheme => $scheme, - ae_identifier => $identifier); - my $entry = $self->{schema}->resultset('AclEntry')->create (\%record); - $self->log_acl ('add', $scheme, $identifier, $user, $host, $time); - $guard->commit; - }; - if ($@) { - $self->error ("cannot add $scheme:$identifier to $self->{id}: $@"); - return; - } - return 1; -} - -# Remove an ACL entry to this ACL. Returns true on success and false on -# failure. Detect the case where no such row exists before doing the delete -# so that we can provide a good error message. -sub remove { - my ($self, $scheme, $identifier, $user, $host, $time) = @_; - $time ||= time; - eval { - my $guard = $self->{schema}->txn_scope_guard; - my %search = (ae_id => $self->{id}, - ae_scheme => $scheme, - ae_identifier => $identifier); - my $entry = $self->{schema}->resultset('AclEntry')->find (\%search); - unless (defined $entry) { - die "entry not found in ACL\n"; - } - $entry->delete; - $self->log_acl ('remove', $scheme, $identifier, $user, $host, $time); - $guard->commit; - }; - if ($@) { - my $entry = "$scheme:$identifier"; - $self->error ("cannot remove $entry from $self->{id}: $@"); - return; - } - return 1; -} - -############################################################################## -# ACL checking -############################################################################## - -# List all of the entries in an ACL. Returns an array of tuples, each of -# which contains a scheme and identifier, or an array containing undef on -# error. Sets the internal error string on error. -sub list { - my ($self) = @_; - undef $self->{error}; - my @entries; - eval { - my $guard = $self->{schema}->txn_scope_guard; - my %search = (ae_id => $self->{id}); - my @entry_recs = $self->{schema}->resultset('AclEntry') - ->search (\%search); - for my $entry (@entry_recs) { - push (@entries, [ $entry->ae_scheme, $entry->ae_identifier ]); - } - $guard->commit; - }; - if ($@) { - $self->error ("cannot retrieve ACL $self->{id}: $@"); - return; - } else { - return @entries; - } -} - -# Return as a string a human-readable description of an ACL, including its -# membership. This method is only for human-readable output; use the list() -# method if you are using the results in other code. Returns undef on -# failure. -sub show { - my ($self) = @_; - my @entries = $self->list; - if (not @entries and $self->error) { - return; - } - my $name = $self->name; - my $id = $self->id; - my $output = "Members of ACL $name (id: $id) are:\n"; - for my $entry (sort { $$a[0] cmp $$b[0] or $$a[1] cmp $$b[1] } @entries) { - my ($scheme, $identifier) = @$entry; - $output .= " $scheme $identifier\n"; - } - return $output; -} - -# Return as a string the history of an ACL. Returns undef on failure. -sub history { - my ($self) = @_; - my $output = ''; - eval { - my $guard = $self->{schema}->txn_scope_guard; - my %search = (ah_acl => $self->{id}); - my %options = (order_by => 'ah_on'); - my @data = $self->{schema}->resultset('AclHistory') - ->search (\%search, \%options); - for my $data (@data) { - $output .= sprintf ("%s %s ", $data->ah_on->ymd, - $data->ah_on->hms); - if ($data->ah_action eq 'add' || $data->ah_action eq 'remove') { - $output .= sprintf ("%s %s %s", $data->ah_action, - $data->ah_scheme, $data->ah_identifier); - } else { - $output .= $data->ah_action; - } - $output .= sprintf ("\n by %s from %s\n", $data->ah_by, - $data->ah_from); - } - $guard->commit; - }; - if ($@) { - $self->error ("cannot read history for $self->{id}: $@"); - return; - } - return $output; -} - -# Given a principal, a scheme, and an identifier, check whether that ACL -# scheme and identifier grant access to that principal. Return 1 if access -# was granted, 0 if access was deined, and undef on some error. On error, the -# error message is also added to the check_errors variable. This method is -# internal to the class. -# -# Maintain ACL verifiers for all schemes we've seen in the local %verifier -# hash so that we can optimize repeated ACL checks. -{ - my %verifier; - sub check_line { - my ($self, $principal, $scheme, $identifier) = @_; - unless ($verifier{$scheme}) { - my $class = $self->scheme_mapping ($scheme); - unless ($class) { - push (@{ $self->{check_errors} }, "unknown scheme $scheme"); - return; - } - $verifier{$scheme} = $class->new; - unless (defined $verifier{$scheme}) { - push (@{ $self->{check_errors} }, "cannot verify $scheme"); - return; - } - } - my $result = ($verifier{$scheme})->check ($principal, $identifier); - if (not defined $result) { - push (@{ $self->{check_errors} }, ($verifier{$scheme})->error); - return; - } else { - return $result; - } - } -} - -# Given a principal, check whether it should be granted access according to -# this ACL. Returns 1 if access was granted, 0 if access was denied, and -# undef on some error. Errors from ACL verifiers do not cause an error -# return, but are instead accumulated in the check_errors variable returned by -# the check_errors() method. -sub check { - my ($self, $principal) = @_; - unless ($principal) { - $self->error ('no principal specified'); - return; - } - my @entries = $self->list; - return if (not @entries and $self->error); - my %verifier; - $self->{check_errors} = []; - for my $entry (@entries) { - my ($scheme, $identifier) = @$entry; - my $result = $self->check_line ($principal, $scheme, $identifier); - return 1 if $result; - } - return 0; -} - -# Returns the errors from the last ACL verification as an array in array -# context or as a string with newlines after each error in a scalar context. -sub check_errors { - my ($self) = @_; - my @errors; - if ($self->{check_errors}) { - @errors = @{ $self->{check_errors} }; - } - return wantarray ? @errors : join ("\n", @errors, ''); -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=head1 NAME - -Wallet::ACL - Implementation of ACLs in the wallet system - -=for stopwords -ACL DBH metadata HOSTNAME DATETIME timestamp Allbery verifier verifiers - -=head1 SYNOPSIS - - my $acl = Wallet::ACL->create ('group:sysadmin'); - $acl->rename ('group:unix'); - $acl->add ('krb5', 'alice@EXAMPLE.COM', $admin, $host); - $acl->add ('krb5', 'bob@EXAMPLE.COM', $admin, $host); - if ($acl->check ($user)) { - print "Permission granted\n"; - warn scalar ($acl->check_errors) if $acl->check_errors; - } - $acl->remove ('krb5', 'bob@EXAMPLE.COM', $admin, $host); - my @entries = $acl->list; - my $summary = $acl->show; - my $history = $acl->history; - $acl->destroy ($admin, $host); - -=head1 DESCRIPTION - -Wallet::ACL implements the ACL system for the wallet: the methods to -create, find, rename, and destroy ACLs; the methods to add and remove -entries from an ACL; and the methods to list the contents of an ACL and -check a principal against it. - -An ACL is a list of zero or more ACL entries, each of which consists of a -scheme and an identifier. Each scheme is associated with a verifier -module that checks Kerberos principals against identifiers for that scheme -and returns whether the principal should be permitted access by that -identifier. The interpretation of the identifier is entirely left to the -scheme. This module maintains the ACLs and dispatches check operations to -the appropriate verifier module. - -Each ACL is identified by a human-readable name and a persistent unique -numeric identifier. The numeric identifier (ID) should be used to refer -to the ACL so that it can be renamed as needed without breaking external -references. - -=head1 CLASS METHODS - -=over 4 - -=item new(ACL, SCHEMA) - -Instantiate a new ACL object with the given ACL ID or name. Takes the -Wallet::Schema object to use for retrieving metadata from the wallet -database. Returns a new ACL object if the ACL was found and throws an -exception if it wasn't or on any other error. - -=item create(NAME, SCHEMA, PRINCIPAL, HOSTNAME [, DATETIME]) - -Similar to new() in that it instantiates a new ACL object, but instead of -finding an existing one, creates a new ACL record in the database with the -given NAME. NAME must not be all-numeric, since that would conflict with -the automatically assigned IDs. Returns the new object on success and -throws an exception on failure. PRINCIPAL, HOSTNAME, and DATETIME are -stored as history information. PRINCIPAL should be the user who is -creating the ACL. If DATETIME isn't given, the current time is used. - -=back - -=head1 INSTANCE METHODS - -=over 4 - -=item add(SCHEME, INSTANCE, PRINCIPAL, HOSTNAME [, DATETIME]) - -Add the given ACL entry (given by SCHEME and INSTANCE) to this ACL. -Returns true on success and false on failure. On failure, the caller -should call error() to get the error message. PRINCIPAL, HOSTNAME, and -DATETIME are stored as history information. PRINCIPAL should be the user -who is adding the ACL entry. If DATETIME isn't given, the current time is -used. - -=item check(PRINCIPAL) - -Checks whether the given PRINCIPAL should be allowed access given ACL. -Returns 1 if access was granted, 0 if access is declined, and undef on -error. On error, the caller should call error() to get the error text. -Any errors found by the individual ACL verifiers can be retrieved by -calling check_errors(). Errors from individual ACL verifiers will not -result in an error return from check(); instead, the check will continue -with the next entry in the ACL. - -check() returns success as soon as an entry in the ACL grants access to -PRINCIPAL. There is no provision for negative ACLs or exceptions. - -=item check_errors() - -Return (as a list in array context and a string with newlines between -errors and at the end of the last error in scalar context) the errors, if -any, returned by ACL verifiers for the last check operation. If there -were no errors from the last check() operation, returns the empty list in -array context and undef in scalar context. - -=item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) - -Destroys this ACL from the database. Note that this will fail if the ACL -is still referenced by any object; the ACL must be removed from all -objects first. Returns true on success and false on failure. On failure, -the caller should call error() to get the error message. PRINCIPAL, -HOSTNAME, and DATETIME are stored as history information. PRINCIPAL -should be the user who is destroying the ACL. If DATETIME isn't given, -the current time is used. - -=item 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. - -=item history() - -Returns the human-readable history of this ACL. Each action that changes -the ACL (not including changes to the name of the ACL) will be represented -by two lines. The first line will have a timestamp of the change followed -by a description of the change, and the second line will give the user who -made the change and the host from which the change was made. On failure, -returns undef, and the caller should call error() to get the error -message. - -=item id() - -Returns the numeric system-generated ID of this ACL. - -=item list() - -Returns all the entries of this ACL. The return value will be a list of -references to pairs of scheme and identifier. For example, for an ACL -containing two entries, both of scheme C and with values -C and C, list() would return: - - ([ 'krb5', 'alice@EXAMPLE.COM' ], [ 'krb5', 'bob@EXAMPLE.COM' ]) - -Returns the empty list on failure. To distinguish between this and the -ACL containing no entries, 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 name() - -Returns the human-readable name of this ACL. - -=item remove(SCHEME, INSTANCE, PRINCIPAL, HOSTNAME [, DATETIME]) - -Remove the given ACL line (given by SCHEME and INSTANCE) from this ACL. -Returns true on success and false on failure. On failure, the caller -should call error() to get the error message. PRINCIPAL, HOSTNAME, and -DATETIME are stored as history information. PRINCIPAL should be the user -who is removing the ACL entry. If DATETIME isn't given, the current time -is used. - -=item rename(NAME) - -Rename this ACL. This changes the name used for human convenience but not -the system-generated ACL ID that is used to reference this ACL. The new -NAME must not be all-numeric, since that would conflict with -system-generated ACL IDs. Returns true on success and false on failure. -On failure, the caller should call error() to get the error message. - -Note that rename() operations are not logged in the ACL history. - -=item show() - -Returns a human-readable description of this ACL, including its -membership. This method should only be used for display of the ACL to -humans. Use the list(), name(), and id() methods instead to get ACL -information for use in other code. On failure, returns undef, and the -caller should call error() to get the error message. - -=back - -=head1 SEE ALSO - -Wallet::ACL::Base(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/ACL/Base.pm b/perl/Wallet/ACL/Base.pm deleted file mode 100644 index b6e4ce3..0000000 --- a/perl/Wallet/ACL/Base.pm +++ /dev/null @@ -1,125 +0,0 @@ -# Wallet::ACL::Base -- Parent class for wallet ACL verifiers. -# -# Written by Russ Allbery -# Copyright 2007, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::ACL::Base; -require 5.006; - -use strict; -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'; - -############################################################################## -# Interface -############################################################################## - -# Creates a new persistant verifier, taking a database handle. This parent -# class just creates an empty object and ignores the handle. Child classes -# should override if there are necessary initialization tasks or if the handle -# will be used by the verifier. -sub new { - my $type = shift; - my $self = {}; - bless ($self, $type); - return $self; -} - -# The default check method denies all access. -sub check { - return 0; -} - -# Set or return the error stashed in the object. -sub error { - my ($self, @error) = @_; - if (@error) { - my $error = join ('', @error); - chomp $error; - 1 while ($error =~ s/ at \S+ line \d+\.?\z//); - $self->{error} = $error; - } - return $self->{error}; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -ACL Allbery verifier verifiers - -=head1 NAME - -Wallet::ACL::Base - Generic parent class for wallet ACL verifiers - -=head1 SYNOPSIS - - package Wallet::ACL::Simple - @ISA = qw(Wallet::ACL::Base); - sub check { - my ($self, $principal, $acl) = @_; - return ($principal eq $acl) ? 1 : 0; - } - -=head1 DESCRIPTION - -Wallet::ACL::Base is the generic parent class for wallet ACL verifiers. -It provides default functions and behavior and all ACL verifiers should -inherit from it. It is not used directly. - -=head1 METHODS - -=over 4 - -=item new() - -Creates a new ACL verifier. The generic function provided here just -creates and blesses an object. - -=item check(PRINCIPAL, ACL) - -This method should always be overridden by child classes. The default -implementation just declines all access. - -=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. - -For the convenience of child classes, this method can also be called with -one or more error strings. If so, those strings are concatenated -together, trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is -stored as the error. Only child classes should call this method with an -error string. - -=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. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/ACL/Krb5.pm b/perl/Wallet/ACL/Krb5.pm deleted file mode 100644 index ed0b7df..0000000 --- a/perl/Wallet/ACL/Krb5.pm +++ /dev/null @@ -1,125 +0,0 @@ -# Wallet::ACL::Krb5 -- Wallet Kerberos v5 principal ACL verifier. -# -# Written by Russ Allbery -# Copyright 2007, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::ACL::Krb5; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Wallet::ACL::Base; - -@ISA = qw(Wallet::ACL::Base); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.02'; - -############################################################################## -# Interface -############################################################################## - -# The most trivial ACL verifier. Returns true if the provided principal -# matches the ACL. -sub check { - my ($self, $principal, $acl) = @_; - unless ($principal) { - $self->error ('no principal specified'); - return; - } - unless ($acl) { - $self->error ('malformed krb5 ACL'); - return; - } - return ($principal eq $acl) ? 1 : 0; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -ACL krb5 Allbery verifier - -=head1 NAME - -Wallet::ACL::Krb5 - Simple wallet ACL verifier for Kerberos principals - -=head1 SYNOPSIS - - my $verifier = Wallet::ACL::Krb5->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::Krb5 is the simplest wallet ACL verifier, used to verify ACL -lines of type C. The value of such an ACL is a simple Kerberos -principal in its text display form, and the ACL grants access to a given -principal if and only if the principal exactly matches the ACL. - -=head1 METHODS - -=over 4 - -=item new() - -Creates a new ACL verifier. For this verifier, there is no setup work. - -=item check(PRINCIPAL, ACL) - -Returns true if PRINCIPAL matches ACL, false if not, and undef on an error -(see L<"DIAGNOSTICS"> below). - -=item error() - -Returns the error if check() returned undef. - -=back - -=head1 DIAGNOSTICS - -=over 4 - -=item malformed krb5 ACL - -The ACL parameter to check() was malformed. Currently, this error is only -given if ACL is undefined or the empty string. - -=item no principal specified - -The PRINCIPAL parameter to check() was undefined or the empty string. - -=back - -=head1 SEE ALSO - -Wallet::ACL(3), Wallet::ACL::Base(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/ACL/Krb5/Regex.pm b/perl/Wallet/ACL/Krb5/Regex.pm deleted file mode 100644 index 30f5527..0000000 --- a/perl/Wallet/ACL/Krb5/Regex.pm +++ /dev/null @@ -1,133 +0,0 @@ -# Wallet::ACL::Krb5::Regex -- Wallet Kerberos v5 principal regex ACL verifier -# -# Written by Russ Allbery -# Copyright 2007, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::ACL::Krb5::Regex; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Wallet::ACL::Krb5; - -@ISA = qw(Wallet::ACL::Krb5); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.01'; - -############################################################################## -# Interface -############################################################################## - -# Returns true if the Perl regular expression specified by the ACL matches -# the provided Kerberos principal. -sub check { - my ($self, $principal, $acl) = @_; - unless ($principal) { - $self->error ('no principal specified'); - return; - } - unless ($acl) { - $self->error ('no ACL specified'); - return; - } - my $regex = eval { qr/$acl/ }; - if ($@) { - $self->error ('malformed krb5-regex ACL'); - return; - } - return ($principal =~ m/$regex/) ? 1 : 0; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -ACL krb5-regex Durkacz Allbery verifier - -=head1 NAME - -Wallet::ACL::Krb5::Regex - Regex wallet ACL verifier for Kerberos principals - -=head1 SYNOPSIS - - my $verifier = Wallet::ACL::Krb5::Regex->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::Krb5::Regex is the wallet ACL verifier used to verify ACL -lines of type C. The value of such an ACL is a Perl regular -expression, and the ACL grants access to a given Kerberos principal if and -only if the regular expression matches that principal. - -=head1 METHODS - -=over 4 - -=item new() - -Creates a new ACL verifier. For this verifier, there is no setup work. - -=item check(PRINCIPAL, ACL) - -Returns true if the Perl regular expression specified by the ACL matches the -PRINCIPAL, false if not, and undef on an error (see L<"DIAGNOSTICS"> below). - -=item error() - -Returns the error if check() returned undef. - -=back - -=head1 DIAGNOSTICS - -=over 4 - -=item malformed krb5-regex ACL - -The ACL parameter to check() was a malformed Perl regular expression. - -=item no principal specified - -The PRINCIPAL parameter to check() was undefined or the empty string. - -=item no ACL specified - -The ACL parameter to check() was undefined or the empty string. - -=back - -=head1 SEE ALSO - -Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::ACL::Krb5(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Ian Durkacz - -=cut diff --git a/perl/Wallet/ACL/LDAP/Attribute.pm b/perl/Wallet/ACL/LDAP/Attribute.pm deleted file mode 100644 index aea8a72..0000000 --- a/perl/Wallet/ACL/LDAP/Attribute.pm +++ /dev/null @@ -1,263 +0,0 @@ -# Wallet::ACL::LDAP::Attribute -- Wallet LDAP attribute ACL verifier. -# -# Written by Russ Allbery -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::ACL::LDAP::Attribute; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Authen::SASL (); -use Net::LDAP qw(LDAP_COMPARE_TRUE); -use Wallet::ACL::Base; -use Wallet::Config; - -@ISA = qw(Wallet::ACL::Base); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.01'; - -############################################################################## -# Interface -############################################################################## - -# Create a new persistant verifier. Load the Net::LDAP module and open a -# persistant LDAP server connection that we'll use for later calls. -sub new { - my $type = shift; - my $host = $Wallet::Config::LDAP_HOST; - my $base = $Wallet::Config::LDAP_BASE; - unless ($host and defined ($base) and $Wallet::Config::LDAP_CACHE) { - die "LDAP attribute ACL support not configured\n"; - } - - # Ensure the required Perl modules are available and bind to the directory - # server. Catch any errors with a try/catch block. - my $ldap; - eval { - local $ENV{KRB5CCNAME} = $Wallet::Config::LDAP_CACHE; - my $sasl = Authen::SASL->new (mechanism => 'GSSAPI'); - $ldap = Net::LDAP->new ($host, onerror => 'die'); - my $mesg = eval { $ldap->bind (undef, sasl => $sasl) }; - }; - if ($@) { - my $error = $@; - chomp $error; - 1 while ($error =~ s/ at \S+ line \d+\.?\z//); - die "LDAP attribute ACL support not available: $error\n"; - } - - # We successfully bound, so create our object and return it. - my $self = { ldap => $ldap }; - bless ($self, $type); - return $self; -} - -# Check whether a given principal has the required LDAP attribute. We first -# map the principal to a DN by doing a search for that principal (and bailing -# if we get more than one entry). Then, we do a compare to see if that DN has -# the desired attribute and value. -# -# If the ldap_map_principal sub is defined in Wallet::Config, call it on the -# principal first to map it to the value for which we'll search. -# -# The connection is configured to die on any error, so we do all the work in a -# try/catch block to report errors. -sub check { - my ($self, $principal, $acl) = @_; - undef $self->{error}; - unless ($principal) { - $self->error ('no principal specified'); - return; - } - my ($attr, $value); - if ($acl) { - ($attr, $value) = split ('=', $acl, 2); - } - unless (defined ($attr) and defined ($value)) { - $self->error ('malformed ldap-attr ACL'); - return; - } - my $ldap = $self->{ldap}; - - # Map the principal name to an attribute value for our search if we're - # doing a custom mapping. - if (defined &Wallet::Config::ldap_map_principal) { - eval { $principal = Wallet::Config::ldap_map_principal ($principal) }; - if ($@) { - $self->error ("mapping principal to LDAP failed: $@"); - return; - } - } - - # Now, map the user to a DN by doing a search. - my $entry; - eval { - my $fattr = $Wallet::Config::LDAP_FILTER_ATTR || 'krb5PrincipalName'; - my $filter = "($fattr=$principal)"; - my $base = $Wallet::Config::LDAP_BASE; - my @options = (base => $base, filter => $filter, attrs => [ 'dn' ]); - my $search = $ldap->search (@options); - if ($search->count == 1) { - $entry = $search->pop_entry; - } elsif ($search->count > 1) { - die $search->count . " LDAP entries found for $principal"; - } - }; - if ($@) { - $self->error ("cannot search for $principal in LDAP: $@"); - return; - } - return 0 unless $entry; - - # We have a user entry. We can now check whether that user has the - # desired attribute and value. - my $result; - eval { - my $mesg = $ldap->compare ($entry, attr => $attr, value => $value); - $result = $mesg->code; - }; - if ($@) { - $self->error ("cannot check LDAP attribute $attr for $principal: $@"); - return; - } - return ($result == LDAP_COMPARE_TRUE) ? 1 : 0; -} - -1; - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -ACL Allbery verifier LDAP PRINCIPAL's DN ldap-attr - -=head1 NAME - -Wallet::ACL::LDAP::Attribute - Wallet ACL verifier for LDAP attribute compares - -=head1 SYNOPSIS - - my $verifier = Wallet::ACL::LDAP::Attribute->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 checks whether the LDAP record for the entry -corresponding to a principal contains an attribute with a particular -value. It is used to verify ACL lines of type C. The value of -such an 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 has that attribute set to that value. - -To use this object, several configuration parameters must be set. See -L for details on those configuration parameters and -information about how to set wallet configuration. - -=head1 METHODS - -=over 4 - -=item new() - -Creates a new ACL verifier. Opens and binds the connection to the LDAP -server. - -=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 its LDAP entry contains -that attribute with that value. - -=item error() - -Returns the error if check() returned undef. - -=back - -=head1 DIAGNOSTICS - -The new() method may fail with one of the following exceptions: - -=over 4 - -=item LDAP attribute ACL support not available: %s - -Attempting to connect or bind to the LDAP server failed. - -=item LDAP attribute ACL support not configured - -The required configuration parameters were not set. See Wallet::Config(3) -for the required configuration parameters and how to set them. - -=back - -Verifying an LDAP attribute ACL may fail with the following errors -(returned by the error() method): - -=over 4 - -=item cannot check LDAP attribute %s for %s: %s - -The LDAP compare to check for the required attribute failed. The -attribute may have been misspelled, or there may be LDAP directory -permission issues. This error indicates that PRINCIPAL's entry was -located in LDAP, but the check failed during the compare to verify the -attribute value. - -=item cannot search for %s in LDAP: %s - -Searching for PRINCIPAL (possibly after ldap_map_principal() mapping) -failed. This is often due to LDAP directory permissions issues. This -indicates a failure during the mapping of PRINCIPAL to an LDAP DN. - -=item malformed ldap-attr ACL - -The ACL parameter to check() was malformed. Usually this means that -either the attribute or the value were empty or the required C<=> sign -separating them was missing. - -=item mapping principal to LDAP failed: %s - -There was an ldap_map_principal() function defined in the wallet -configuration, but calling it for the PRINCIPAL argument failed. - -=item no principal specified - -The PRINCIPAL parameter to check() was undefined or the empty string. - -=back - -=head1 SEE ALSO - -Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::Config(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/ACL/NetDB.pm b/perl/Wallet/ACL/NetDB.pm deleted file mode 100644 index b76d4ed..0000000 --- a/perl/Wallet/ACL/NetDB.pm +++ /dev/null @@ -1,267 +0,0 @@ -# Wallet::ACL::NetDB -- Wallet NetDB role ACL verifier. -# -# Written by Russ Allbery -# Copyright 2007, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::ACL::NetDB; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Wallet::ACL::Base; -use Wallet::Config; - -@ISA = qw(Wallet::ACL::Base); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.05'; - -############################################################################## -# Interface -############################################################################## - -# Creates a new persistant verifier. Load the Net::Remctl module and open a -# persistant remctl connection that we'll use for later calls. -sub new { - my $type = shift; - my $host = $Wallet::Config::NETDB_REMCTL_HOST; - unless ($host and $Wallet::Config::NETDB_REMCTL_CACHE) { - die "NetDB ACL support not configured\n"; - } - eval { require Net::Remctl }; - if ($@) { - my $error = $@; - chomp $error; - 1 while ($error =~ s/ at \S+ line \d+\.?\z//); - die "NetDB ACL support not available: $error\n"; - } - local $ENV{KRB5CCNAME} = $Wallet::Config::NETDB_REMCTL_CACHE; - my $remctl = Net::Remctl->new; - - # Net::Remctl 2.12 and later will support passing in an empty string for - # the principal. Until then, be careful not to pass principal unless it - # was specified. - my $port = $Wallet::Config::NETDB_REMCTL_PORT || 0; - my $principal = $Wallet::Config::NETDB_REMCTL_PRINCIPAL; - my $status; - if (defined $principal) { - $status = $remctl->open ($host, $port, $principal); - } else { - $status = $remctl->open ($host, $port); - } - unless ($status) { - die "cannot connect to NetDB remctl interface: ", $remctl->error, "\n"; - } - my $self = { remctl => $remctl }; - bless ($self, $type); - return $self; -} - -# Check whether the given principal has one of the user, administrator, or -# admin team roles in NetDB for the given host. Returns 1 if it does, 0 if it -# doesn't, and undef, setting the error, if there's some failure in making the -# remctl call. -sub check { - my ($self, $principal, $acl) = @_; - unless ($principal) { - $self->error ('no principal specified'); - return; - } - unless ($acl) { - $self->error ('malformed netdb ACL'); - return; - } - my $remctl = $self->{remctl}; - if ($Wallet::Config::NETDB_REALM) { - $principal =~ s/\@\Q$Wallet::Config::NETDB_REALM\E\z//; - } - unless ($remctl->command ('netdb', 'node-roles', $principal, $acl)) { - $self->error ('cannot check NetDB ACL: ' . $remctl->error); - return; - } - my ($roles, $output, $status, $error); - do { - $output = $remctl->output; - if ($output->type eq 'output') { - if ($output->stream == 1) { - $roles .= $output->data; - } else { - $error .= $output->data; - } - } elsif ($output->type eq 'error') { - $self->error ('cannot check NetDB ACL: ' . $output->data); - return; - } elsif ($output->type eq 'status') { - $status = $output->status; - } else { - $self->error ('malformed NetDB remctl token: ' . $output->type); - return; - } - } while ($output->type eq 'output'); - if ($status == 0) { - $roles ||= ''; - my @roles = split (' ', $roles); - for my $role (@roles) { - return 1 if $role eq 'admin'; - return 1 if $role eq 'team'; - return 1 if $role eq 'user'; - } - return 0; - } else { - if ($error) { - chomp $error; - $error =~ s/\n/ /g; - $self->error ("error checking NetDB ACL: $error"); - } else { - $self->error ("error checking NetDB ACL"); - } - return; - } -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -ACL NetDB remctl DNS DHCP Allbery netdb verifier - -=head1 NAME - -Wallet::ACL::NetDB - Wallet ACL verifier for NetDB roles - -=head1 SYNOPSIS - - my $verifier = Wallet::ACL::NetDB->new; - my $status = $verifier->check ($principal, $node); - 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::NetDB checks a principal against the NetDB roles for a given -host. It is used to verify ACL lines of type C. The value of such -an ACL is a node, and the ACL grants access to a given principal if and -only if that principal has one of the roles user, admin, or team for that -node. - -To use this object, several configuration parameters must be set. See -L for details on those configuration parameters and -information about how to set wallet configuration. - -=head1 METHODS - -=over 4 - -=item new() - -Creates a new ACL verifier. Opens the remctl connection to the NetDB -server and authenticates. - -=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 is a node, -and PRINCIPAL will be granted access if it (with the realm stripped off if -configured) has the user, admin, or team role for that node. - -=item error() - -Returns the error if check() returned undef. - -=back - -=head1 DIAGNOSTICS - -The new() method may fail with one of the following exceptions: - -=over 4 - -=item NetDB ACL support not available: %s - -The Net::Remctl Perl module, required for NetDB ACL support, could not be -loaded. - -=item NetDB ACL support not configured - -The required configuration parameters were not set. See Wallet::Config(3) -for the required configuration parameters and how to set them. - -=item cannot connect to NetDB remctl interface: %s - -Connecting to the NetDB remctl interface failed with the given error -message. - -=back - -Verifying a NetDB ACL may fail with the following errors (returned by the -error() method): - -=over 4 - -=item cannot check NetDB ACL: %s - -Issuing the remctl command to get the roles for the given principal failed -or returned an error. - -=item error checking NetDB ACL: %s - -The NetDB remctl interface that returns the roles for a user returned an -error message or otherwise returned failure. - -=item malformed netdb ACL - -The ACL parameter to check() was malformed. Currently, this error is only -given if ACL is undefined or the empty string. - -=item malformed NetDB remctl token: %s - -The Net::Remctl Perl library returned a malformed token. This should -never happen and indicates a bug in Net::Remctl. - -=item no principal specified - -The PRINCIPAL parameter to check() was undefined or the empty string. - -=back - -=head1 CAVEATS - -The list of possible NetDB roles that should be considered sufficient to -grant access is not currently configurable. - -=head1 SEE ALSO - -Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::Config(3), -wallet-backend(8) - -NetDB is a free software system for managing DNS, DHCP, and related -machine information for large organizations. For more information on -NetDB, see L. - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/ACL/NetDB/Root.pm b/perl/Wallet/ACL/NetDB/Root.pm deleted file mode 100644 index 6c95c6e..0000000 --- a/perl/Wallet/ACL/NetDB/Root.pm +++ /dev/null @@ -1,128 +0,0 @@ -# Wallet::ACL::NetDB::Root -- Wallet NetDB role ACL verifier (root instances). -# -# Written by Russ Allbery -# Copyright 2007, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::ACL::NetDB::Root; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Wallet::ACL::NetDB; -use Wallet::Config; - -@ISA = qw(Wallet::ACL::NetDB); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.02'; - -############################################################################## -# Interface -############################################################################## - -# Override the check method of Wallet::ACL::NetDB 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) = @_; - 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 NetDB DNS DHCP Allbery verifier - -=head1 NAME - -Wallet::ACL::NetDB::Root - Wallet ACL verifier for NetDB roles (root instances) - -=head1 SYNOPSIS - - my $verifier = Wallet::ACL::NetDB::Root->new; - my $status = $verifier->check ($principal, $node); - 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::NetDB::Root works identically to Wallet::ACL::NetDB except -that it requires the principal to be a root instance (in other words, to -be in the form /root@) and strips the C portion -from the principal before checking against NetDB roles. As with the base -NetDB ACL verifier, the value of a C ACL is a node, and the -ACL grants access to a given principal if and only if the that principal -(with C stripped) has one of the roles user, admin, or team for -that node. - -To use this object, the same configuration parameters must be set as for -Wallet::ACL::NetDB. 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 is a node, -and PRINCIPAL will be granted access if it has an instance of C and -if (with C stripped off and the realm stripped off if configured) -has the user, admin, or team role for that node. - -=back - -=head1 DIAGNOSTICS - -Same as for Wallet::ACL::NetDB. - -=head1 CAVEATS - -The instance to strip is not currently configurable. - -The list of possible NetDB roles that should be considered sufficient to -grant access is not currently configurable. - -=head1 SEE ALSO - -Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3), -Wallet::ACL::NetDB(3), Wallet::Config(3), wallet-backend(8) - -NetDB is a free software system for managing DNS, DHCP, and related -machine information for large organizations. For more information on -NetDB, see L. - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm deleted file mode 100644 index 3a05284..0000000 --- a/perl/Wallet/Admin.pm +++ /dev/null @@ -1,379 +0,0 @@ -# Wallet::Admin -- Wallet system administrative interface. -# -# Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2011, 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Admin; -require 5.006; - -use strict; -use vars qw($VERSION); - -use Wallet::ACL; -use Wallet::Schema; - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.07'; - -# The last non-DBIx::Class version of Wallet::Schema. If a database has no -# DBIx::Class versioning, we artificially install this version number before -# starting the upgrade process so that the automated DBIx::Class upgrade will -# work properly. -our $BASE_VERSION = '0.07'; - -############################################################################## -# Constructor, destructor, and accessors -############################################################################## - -# Create a new wallet administrator object. Opens a connection to the -# database that will be used for all of the wallet configuration information. -# Throw an exception if anything goes wrong. -sub new { - my ($class) = @_; - my $schema = Wallet::Schema->connect; - my $self = { schema => $schema }; - bless ($self, $class); - return $self; -} - -# Returns the database handle (used mostly for testing). -sub dbh { - my ($self) = @_; - return $self->{schema}->storage->dbh; -} - -# Returns the DBIx::Class-based database schema object. -sub schema { - my ($self) = @_; - return $self->{schema}; -} - -# Set or return the error stashed in the object. -sub error { - my ($self, @error) = @_; - if (@error) { - my $error = join ('', @error); - chomp $error; - 1 while ($error =~ s/ at \S+ line \d+\.?\z//); - $self->{error} = $error; - } - return $self->{error}; -} - -# Disconnect the database handle on object destruction to avoid warnings. -sub DESTROY { - my ($self) = @_; - $self->{schema}->storage->dbh->disconnect; -} - -############################################################################## -# Database initialization -############################################################################## - -# Initializes the database by populating it with our schema and then creates -# and returns a new wallet server object. This is used only for initial -# database creation. Takes the Kerberos principal who will be the default -# administrator so that we can create an initial administrator ACL. Returns -# true on success and false on failure, setting the object error. -sub initialize { - my ($self, $user) = @_; - - # Deploy the database schema from DDL files, if they exist. If not then - # we automatically get the database from the Schema modules. - $self->{schema}->deploy ({}, $Wallet::Config::DB_DDL_DIRECTORY); - if ($@) { - $self->error ($@); - return; - } - $self->default_data; - - # Create a default admin ACL. - my $acl = Wallet::ACL->create ('ADMIN', $self->{schema}, $user, - 'localhost'); - unless ($acl->add ('krb5', $user, $user, 'localhost')) { - $self->error ($acl->error); - return; - } - - return 1; -} - -# Load default data into various tables. We'd like to do this more directly -# in the schema definitions, but not yet seeing a good way to do that. -sub default_data { - my ($self) = @_; - - # 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' ], - ]); - warn "default AclScheme not installed" unless defined $r1; - - # types default rows. - my @record = ([ qw/ty_name ty_class/ ], - [ 'file', 'Wallet::Object::File' ], - [ 'keytab', 'Wallet::Object::Keytab' ], - [ 'wa-keyring', 'Wallet::Object::WAKeyring' ]); - ($r1) = $self->{schema}->resultset('Type')->populate (\@record); - warn "default Type not installed" unless defined $r1; - - # enctypes default rows. - @record = ([ qw/en_name/ ], - [ 'aes128-cts-hmac-sha1-96' ], - [ 'aes256-cts-hmac-sha1-96' ], - [ 'arcfour-hmac-md5' ], - [ 'des-cbc-crc' ], - [ 'des3-cbc-sha1' ]); - ($r1) = $self->{schema}->resultset('Enctype')->populate (\@record); - warn "default Enctype not installed" unless defined $r1; - - return 1; -} - -# The same as initialize, but also drops any existing tables first before -# creating the schema. Takes the same arguments. Returns true on success and -# false on failure. -sub reinitialize { - my ($self, $user) = @_; - return unless $self->destroy; - return $self->initialize ($user); -} - -# Drop the database, including all of its data. Returns true on success and -# false on failure. -sub destroy { - my ($self) = @_; - - # Get an actual DBI handle and use it to delete all tables. - my $dbh = $self->dbh; - my @tables = qw/acls acl_entries acl_history acl_schemes enctypes - flags keytab_enctypes keytab_sync objects object_history - sync_targets types dbix_class_schema_versions/; - for my $table (@tables) { - my $sql = "DROP TABLE IF EXISTS $table"; - $dbh->do ($sql); - } - - return 1; -} - -# Save a DDL of the database in every supported database server. Returns -# true on success and false on failure. -sub backup { - my ($self, $oldversion) = @_; - - my @dbs = qw/MySQL SQLite PostgreSQL/; - my $version = $Wallet::Schema::VERSION; - $self->{schema}->create_ddl_dir (\@dbs, $version, - $Wallet::Config::DB_DDL_DIRECTORY, - $oldversion); - - return 1; -} - -# Upgrade the database to the latest schema version. Returns true on success -# and false on failure. -sub upgrade { - my ($self) = @_; - - # Check to see if the database is versioned. If not, install the - # versioning table and default version. - if (!$self->{schema}->get_db_version) { - $self->{schema}->install ($BASE_VERSION); - } - - # Suppress warnings that actually are just informational messages. - local $SIG{__WARN__} = sub { - my ($warn) = @_; - return if $warn =~ m{Upgrade not necessary}; - return if $warn =~ m{Attempting upgrade}; - warn $warn; - }; - - # Perform the actual upgrade. - if ($self->{schema}->get_db_version) { - $self->{schema}->upgrade_directory ($Wallet::Config::DB_DDL_DIRECTORY); - eval { $self->{schema}->upgrade; }; - } - if ($@) { - $self->error ($@); - return; - } - - return 1; -} - -############################################################################## -# Object registration -############################################################################## - -# Given an object type and class name, add a new class mapping to that -# database for the given object type. This is used to register new object -# types. Returns true on success, false on failure, and sets the internal -# error on failure. -sub register_object { - my ($self, $type, $class) = @_; - eval { - my $guard = $self->{schema}->txn_scope_guard; - my %record = (ty_name => $type, - ty_class => $class); - $self->{schema}->resultset('Type')->create (\%record); - $guard->commit; - }; - if ($@) { - $self->error ("cannot register $class for $type: $@"); - return; - } - return 1; -} - -# Given an ACL verifier scheme and class name, add a new class mapping to that -# database for the given ACL verifier scheme. This is used to register new -# ACL schemes. Returns true on success, false on failure, and sets the -# internal error on failure. -sub register_verifier { - my ($self, $scheme, $class) = @_; - eval { - my $guard = $self->{schema}->txn_scope_guard; - my %record = (as_name => $scheme, - as_class => $class); - $self->{schema}->resultset('AclScheme')->create (\%record); - $guard->commit; - }; - if ($@) { - $self->error ("cannot register $class for $scheme: $@"); - return; - } - return 1; -} - -1; -__DATA__ - -############################################################################## -# Documentation -############################################################################## - -=head1 NAME - -Wallet::Admin - Wallet system administrative interface - -=for stopwords -ACL hostname Allbery verifier - -=head1 SYNOPSIS - - use Wallet::Admin; - my $admin = Wallet::Admin->new; - unless ($admin->initialize ('user/admin@EXAMPLE.COM')) { - die $admin->error; - } - -=head1 DESCRIPTION - -Wallet::Admin implements the administrative interface to the wallet server -and database. It is normally instantiated and used by B, a -thin wrapper around this object that provides a command-line interface to -its actions. - -To use this object, several configuration variables must be set (at least -the database configuration). For information on those variables and how -to set them, see L. For more information on the normal -user interface to the wallet server, see L. - -=head1 CLASS METHODS - -=over 4 - -=item new() - -Creates a new wallet administrative object and connects to the database. -On any error, this method throws an exception. - -=back - -=head1 INSTANCE METHODS - -For all methods that can fail, the caller should call error() after a -failure to get the error message. - -=over 4 - -=item destroy () - -Destroys the database, deleting all of its data and all of the tables used -by the wallet server. Returns true on success and false on failure. - -=item 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. - -=item initialize(PRINCIPAL) - -Initializes the database as configured in Wallet::Config and loads the -wallet database schema. Then, creates an ACL with the name ADMIN and adds -an ACL entry of scheme C and instance PRINCIPAL to that ACL. This -bootstraps the authorization system and lets that Kerberos identity make -further changes to the ADMIN ACL and the rest of the wallet database. -Returns true on success and false on failure. - -initialize() uses C as the hostname and PRINCIPAL as the user -when logging the history of the ADMIN ACL creation and for any subsequent -actions on the object it returns. - -=item register_object (TYPE, CLASS) - -Register in the database a mapping from the object type TYPE to the class -CLASS. Returns true on success and false on failure (including when the -verifier is already registered). - -=item register_verifier (SCHEME, CLASS) - -Register in the database a mapping from the ACL scheme SCHEME to the class -CLASS. Returns true on success and false on failure (including when the -verifier is already registered). - -=item reinitialize (PRINCIPAL) - -Performs the same actions as initialize(), but first drops any existing -wallet database tables from the database, allowing this function to be -called on a prior wallet database. All data stored in the database will -be deleted and a fresh set of wallet database tables will be created. -This method is equivalent to calling destroy() followed by initialize(). -Returns true on success and false on failure. - -=item upgrade () - -Upgrades the database to the latest schema version, preserving data as -much as possible. Returns true on success and false on failure. - -=back - -=head1 SEE ALSO - -wallet-admin(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm deleted file mode 100644 index 5b0ab1c..0000000 --- a/perl/Wallet/Config.pm +++ /dev/null @@ -1,826 +0,0 @@ -# Wallet::Config -- Configuration handling for the wallet server. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Config; -require 5.006; - -use strict; -use vars qw($PATH $VERSION); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.05'; - -# Path to the config file to load. -$PATH = $ENV{WALLET_CONFIG} || '/etc/wallet/wallet.conf'; - -=head1 NAME - -Wallet::Config - Configuration handling for the wallet server - -=for stopwords -DBI DSN SQLite subdirectories KEYTAB keytab kadmind KDC add-ons kadmin DNS -SRV kadmin keytabs remctl backend lowercased NETDB ACL NetDB unscoped -usernames rekey hostnames Allbery wallet-backend keytab-backend Heimdal -rekeys WebAuth WEBAUTH keyring LDAP DN GSS-API integrations - -=head1 SYNOPSIS - - use Wallet::Config; - my $driver = $Wallet::Config::DB_DRIVER; - my $info; - if (defined $Wallet::Config::DB_INFO) { - $info = $Wallet::Config::DB_INFO; - } else { - $info = "database=$Wallet::Config::DB_NAME"; - $info .= ";host=$Wallet::Config::DB_HOST" - if $Wallet::Config::DB_HOST; - $info .= ";port=$Wallet::Config::DB_PORT" - if $Wallet::Config::DB_PORT; - } - my $dsn = "dbi:$driver:$info"; - my $user = $Wallet::Config::DB_USER; - my $password = $Wallet::Config::DB_PASSWORD; - my $dbh = DBI->connect ($dsn, $user, $password); - -=head1 DESCRIPTION - -Wallet::Config encapsulates all of the site-specific configuration for the -wallet server. It is implemented as a Perl class that declares and sets -the defaults for various configuration variables and then, if it exists, -loads the file specified by the WALLET_CONFIG environment variable or -F if that environment variable isn't set. That -file should contain any site-specific overrides to the defaults, and at -least some parameters must be set. - -This file must be valid Perl. To set a variable, use the syntax: - - $VARIABLE = ; - -where VARIABLE is the variable name (always in all-capital letters) and - is the value. If setting a variable to a string and not a number, -you should normally enclose in C<''>. For example, to set the -variable DB_DRIVER to C, use: - - $DB_DRIVER = 'MySQL'; - -Always remember the initial dollar sign (C<$>) and ending semicolon -(C<;>). Those familiar with Perl syntax can of course use the full range -of Perl expressions. - -This configuration file should end with the line: - - 1; - -This ensures that Perl doesn't think there is an error when loading the -file. - -=head1 DATABASE CONFIGURATION - -=over 4 - -=item DB_DDL_DIRECTORY - -Specifies the directory used to dump the database schema in formats for -each possible database server. This also includes diffs between schema -versions, for upgrades. The default value is F, -which matches the default installation location. - -=cut - -our $DB_DDL_DIRECTORY = '/usr/local/share/wallet'; - -=item DB_DRIVER - -Sets the Perl database driver to use for the wallet database. Common -values would be C or C. Less common values would be -C, C, or C. The appropriate DBD::* Perl module for -the chosen driver must be installed and will be dynamically loaded by the -wallet. For more information, see L. - -This variable must be set. - -=cut - -our $DB_DRIVER; - -=item DB_INFO - -Sets the remaining contents for the DBI DSN (everything after the driver). -Using this variable provides full control over the connect string passed -to DBI. When using SQLite, set this variable to the path to the SQLite -database. If this variable is set, DB_NAME, DB_HOST, and DB_PORT are -ignored. For more information, see L and the documentation for the -database driver you're using. - -Either DB_INFO or DB_NAME must be set. If you don't need to pass any -additional information to DBI, set DB_INFO to the empty string (C<''>). - -=cut - -our $DB_INFO; - -=item DB_NAME - -If DB_INFO is not set, specifies the database name. The third part of the -DBI connect string will be set to C, possibly with a -host and port appended if DB_HOST and DB_PORT are set. For more -information, see L and the documentation for the database driver -you're using. - -Either DB_INFO or DB_NAME must be set. - -=cut - -our $DB_NAME; - -=item DB_HOST - -If DB_INFO is not set, specifies the database host. C<;host=DB_HOST> will -be appended to the DBI connect string. For more information, see L -and the documentation for the database driver you're using. - -=cut - -our $DB_HOST; - -=item DB_PORT - -If DB_PORT is not set, specifies the database port. C<;port=DB_PORT> will -be appended to the DBI connect string. If this variable is set, DB_HOST -should also be set. For more information, see L and the -documentation for the database driver you're using. - -=cut - -our $DB_PORT; - -=item DB_USER - -Specifies the user for database authentication. Some database backends, -particularly SQLite, do not need this. - -=cut - -our $DB_USER; - -=item DB_PASSWORD - -Specifies the password for database authentication. Some database -backends, particularly SQLite, do not need this. - -=cut - -our $DB_PASSWORD; - -=back - -=head1 DUO OBJECT CONFIGURATION - -These configuration variables only need to be set if you intend to use the -C object type (the Wallet::Object::Duo class). - -=over 4 - -=item DUO_AGENT - -If this configuration variable is set, its value should be an object that -is call-compatible with LWP::UserAgent. This object will be used instead -of LWP::UserAgent to make API calls to Duo. This is primarily useful for -testing, allowing replacement of the user agent with a mock implementation -so that a test can run without needing a Duo account. - -=cut - -our $DUO_AGENT; - -=item DUO_KEY_FILE - -The path to a file in JSON format that contains the key and hostname data -for the Duo Admin API integration used to manage integrations via wallet. -This file should be in the format expected by the C parameter -to the Net::Duo::Admin constructor. See L for more -information. - -DUO_KEY_FILE must be set to use Duo objects. - -=cut - -our $DUO_KEY_FILE; - -=item DUO_TYPE - -The type of integration to create. Currently, only one type of integration -can be created by one wallet configuration. This restriction may be relaxed -in the future. The default value is C to create UNIX integrations. - -=cut - -our $DUO_TYPE = 'unix'; - -=back - -=head1 FILE OBJECT CONFIGURATION - -These configuration variables only need to be set if you intend to use the -C object type (the Wallet::Object::File class). - -=over 4 - -=item FILE_BUCKET - -The directory into which to store file objects. File objects will be -stored in subdirectories of this directory. See L -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. - -FILE_BUCKET must be set to use file objects. - -=cut - -our $FILE_BUCKET; - -=item FILE_MAX_SIZE - -The maximum size of data that can be stored in a file object in bytes. If -this configuration variable is set, an attempt to store data larger than -this limit will be rejected. - -=cut - -our $FILE_MAX_SIZE; - -=back - -=head1 KEYTAB OBJECT CONFIGURATION - -These configuration variables only need to be set if you intend to use the -C object type (the Wallet::Object::Keytab class). - -=over 4 - -=item KEYTAB_FILE - -Specifies the keytab to use to authenticate to B. The principal -whose key is stored in this keytab must have the ability to create, -modify, inspect, and delete any principals that should be managed by the -wallet. (In MIT Kerberos F parlance, this is C -privileges.) - -KEYTAB_FILE must be set to use keytab objects. - -=cut - -our $KEYTAB_FILE; - -=item KEYTAB_FLAGS - -These flags, if any, are passed to the C command when creating a -new principal in the Kerberos KDC. To not pass any flags, set -KEYTAB_FLAGS to the empty string. The default value is C<-clearpolicy>, -which clears any password strength policy from principals created by the -wallet. (Since the wallet randomizes the keys, password strength checking -is generally pointless and may interact poorly with the way C works when third-party add-ons for password strength checking -are used.) - -=cut - -our $KEYTAB_FLAGS = '-clearpolicy'; - -=item KEYTAB_HOST - -Specifies the host on which the kadmin service is running. This setting -overrides the C setting in the [realms] section of -F and any DNS SRV records and allows the wallet to run on a -system that doesn't have a Kerberos configuration for the wallet's realm. - -=cut - -our $KEYTAB_HOST; - -=item KEYTAB_KADMIN - -The path to the B command-line client. The default value is -C, which will cause the wallet to search for B on its -default PATH. - -=cut - -our $KEYTAB_KADMIN = 'kadmin'; - -=item KEYTAB_KRBTYPE - -The Kerberos KDC implementation type, either C or C -(case-insensitive). KEYTAB_KRBTYPE must be set to use keytab objects. - -=cut - -our $KEYTAB_KRBTYPE; - -=item KEYTAB_PRINCIPAL - -The principal whose key is stored in KEYTAB_FILE. The wallet will -authenticate as this principal to the kadmin service. - -KEYTAB_PRINCIPAL must be set to use keytab objects, at least until -B is smart enough to use the first principal found in the keytab -it's using for authentication. - -=cut - -our $KEYTAB_PRINCIPAL; - -=item KEYTAB_REALM - -Specifies the realm in which to create Kerberos principals. The keytab -object implementation can only work in a single realm for a given wallet -installation and the keytab object names are stored without realm. -KEYTAB_REALM is added when talking to the KDC via B. - -KEYTAB_REALM must be set to use keytab objects. C doesn't always -default to the local realm. - -=cut - -our $KEYTAB_REALM; - -=item KEYTAB_TMP - -A directory into which the wallet can write keytabs temporarily while -processing C commands from clients. The keytabs are written into -this directory with predictable names, so this should not be a system -temporary directory such as F or F. It's best to create a -directory solely for this purpose that's owned by the user the wallet -server will run as. - -KEYTAB_TMP must be set to use keytab objects. - -=cut - -our $KEYTAB_TMP; - -=back - -=head2 Retrieving Existing Keytabs - -Heimdal provides the choice, over the network protocol, of either -downloading the existing keys for a principal or generating new random -keys. MIT Kerberos does not; downloading a keytab over the kadmin -protocol always rekeys the principal. - -For MIT Kerberos, the keytab object backend therefore optionally supports -retrieving existing keys, and hence keytabs, for Kerberos principals by -contacting the KDC via remctl and talking to B. This is -enabled by setting the C flag on keytab objects. To configure -that support, set the following variables. - -This is not required for Heimdal; for Heimdal, setting the C -flag is all that's needed. - -=over 4 - -=item KEYTAB_REMCTL_CACHE - -Specifies the ticket cache to use when retrieving existing keytabs from -the KDC. This is only used to implement support for the C -flag. The ticket cache must be for a principal with access to run -C via remctl on KEYTAB_REMCTL_HOST. - -=cut - -our $KEYTAB_REMCTL_CACHE; - -=item KEYTAB_REMCTL_HOST - -The host to which to connect with remctl to retrieve existing keytabs. -This is only used to implement support for the C flag. This -host must provide the C command and KEYTAB_REMCTL_CACHE -must also be set to a ticket cache for a principal with access to run that -command. - -=cut - -our $KEYTAB_REMCTL_HOST; - -=item KEYTAB_REMCTL_PRINCIPAL - -The service principal to which to authenticate when retrieving existing -keytabs. This is only used to implement support for the C -flag. If this variable is not set, the default is formed by prepending -C to KEYTAB_REMCTL_HOST. (Note that KEYTAB_REMCTL_HOST is not -lowercased first.) - -=cut - -our $KEYTAB_REMCTL_PRINCIPAL; - -=item KEYTAB_REMCTL_PORT - -The port on KEYTAB_REMCTL_HOST to which to connect with remctl to retrieve -existing keytabs. This is only used to implement support for the -C flag. If this variable is not set, the default remctl port -will be used. - -=cut - -our $KEYTAB_REMCTL_PORT; - -=back - -=head1 WEBAUTH KEYRING OBJECT CONFIGURATION - -These configuration variables only need to be set if you intend to use the -C object type (the Wallet::Object::WAKeyring class). - -=over 4 - -=item WAKEYRING_BUCKET - -The directory into which to store WebAuth keyring objects. WebAuth -keyring objects will be stored in subdirectories of this directory. See -L 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. - -WAKEYRING_BUCKET must be set to use WebAuth keyring objects. - -=cut - -our $WAKEYRING_BUCKET; - -=item WAKEYRING_REKEY_INTERVAL - -The interval, in seconds, at which new keys are generated in a keyring. -The object implementation will try to arrange for there to be keys added -to the keyring separated by this interval. - -It's useful to provide some interval to install the keyring everywhere -that it's used before the key becomes inactive. Every keyring will -therefore normally have at least three keys: one that's currently active, -one that becomes valid in the future but less than -WAKEYRING_REKEY_INTERVAL from now, and one that becomes valid between one -and two of those intervals into the future. This means that one has twice -this interval to distribute the keyring everywhere it is used. - -Internally, this is implemented by adding a new key that becomes valid in -twice this interval from the current time if the newest key becomes valid -at or less than this interval in the future. - -The default value is 60 * 60 * 24 (one day). - -=cut - -our $WAKEYRING_REKEY_INTERVAL = 60 * 60 * 24; - -=item WAKEYRING_PURGE_INTERVAL - -The interval, in seconds, from the key creation date after which keys are -removed from the keyring. This is used to clean up old keys and finish -key rotation. Keys won't be removed unless there are more than three keys -in the keyring to try to keep a misconfiguration from removing all valid -keys. - -The default value is 60 * 60 * 24 * 90 (90 days). - -=cut - -our $WAKEYRING_PURGE_INTERVAL = 60 * 60 * 24 * 90; - -=back - -=head1 LDAP ACL CONFIGURATION - -These configuration variables are only needed if you intend to use the -C ACL type (the Wallet::ACL::LDAP::Attribute class). They -specify the LDAP server and additional connection and data model -information required for the wallet to check for the existence of -attributes. - -=over 4 - -=item LDAP_HOST - -The LDAP server name to use to verify LDAP ACLs. This variable must be -set to use LDAP ACLs. - -=cut - -our $LDAP_HOST; - -=item LDAP_BASE - -The base DN under which to search for the entry corresponding to a -principal. Currently, the wallet always does a full subtree search under -this base DN. This variable must be set to use LDAP ACLs. - -=cut - -our $LDAP_BASE; - -=item LDAP_FILTER_ATTR - -The attribute used to find the entry corresponding to a principal. The -LDAP entry containing this attribute with a value equal to the principal -will be found and checked for the required attribute and value. If this -variable is not set, the default is C. - -=cut - -our $LDAP_FILTER_ATTR; - -=item LDAP_CACHE - -Specifies the Kerberos ticket cache to use when connecting to the LDAP -server. GSS-API authentication is always used; there is currently no -support for any other type of bind. The ticket cache must be for a -principal with access to verify the values of attributes that will be used -with this ACL type. This variable must be set to use LDAP ACLs. - -=cut - -our $LDAP_CACHE; - -=back - -Finally, depending on the structure of the LDAP directory being queried, -there may not be any attribute in the directory whose value exactly -matches the Kerberos principal. The attribute designated by -LDAP_FILTER_ATTR may instead hold a transformation of the principal name -(such as the principal with the local realm stripped off, or rewritten -into an LDAP DN form). If this is the case, define a Perl function named -ldap_map_principal. This function will be called whenever an LDAP -attribute ACL is being verified. It will take one argument, the -principal, and is expected to return the value to search for in the LDAP -directory server. - -For example, if the principal name without the local realm is stored in -the C attribute in the directory, set LDAP_FILTER_ATTR to C and -then define ldap_map_attribute as follows: - - sub ldap_map_principal { - my ($principal) = @_; - $principal =~ s/\@EXAMPLE\.COM$//; - return $principal; - } - -Note that this example only removes the local realm (here, EXAMPLE.COM). -Any principal from some other realm will be left fully qualified, and then -presumably will not be found in the directory. - -=head1 NETDB ACL CONFIGURATION - -These configuration variables are only needed if you intend to use the -C ACL type (the Wallet::ACL::NetDB class). They specify the remctl -connection information for retrieving user roles from NetDB and the local -realm to remove from principals (since NetDB normally expects unscoped -local usernames). - -=over 4 - -=item NETDB_REALM - -The wallet uses fully-qualified principal names (including the realm), but -NetDB normally expects local usernames without the realm. If this -variable is set, the given realm will be stripped from any principal names -before passing them to NetDB. Principals in other realms will be passed -to NetDB without modification. - -=cut - -our $NETDB_REALM; - -=item NETDB_REMCTL_CACHE - -Specifies the ticket cache to use when querying the NetDB remctl interface -for user roles. The ticket cache must be for a principal with access to -run C via remctl on KEYTAB_REMCTL_HOST. This variable -must be set to use NetDB ACLs. - -=cut - -our $NETDB_REMCTL_CACHE; - -=item NETDB_REMCTL_HOST - -The host to which to connect with remctl to query NetDB for user roles. -This host must provide the C command and -NETDB_REMCTL_CACHE must also be set to a ticket cache for a principal with -access to run that command. This variable must be set to use NetDB ACLs. - -=cut - -our $NETDB_REMCTL_HOST; - -=item NETDB_REMCTL_PRINCIPAL - -The service principal to which to authenticate when querying NetDB for -user roles. If this variable is not set, the default is formed by -prepending C to NETDB_REMCTL_HOST. (Note that NETDB_REMCTL_HOST is -not lowercased first.) - -=cut - -our $NETDB_REMCTL_PRINCIPAL; - -=item NETDB_REMCTL_PORT - -The port on NETDB_REMCTL_HOST to which to connect with remctl to query -NetDB for user roles. If this variable is not set, the default remctl -port will be used. - -=cut - -our $NETDB_REMCTL_PORT; - -=back - -=head1 DEFAULT OWNERS - -By default, only users in the ADMIN ACL can create new objects in the -wallet. To allow other users to create new objects, define a Perl -function named default_owner. This function will be called whenever a -non-ADMIN user tries to create a new object and will be passed the type -and name of the object. It should return undef if there is no default -owner for that object. If there is, it should return a list containing -the name to use for the ACL and then zero or more anonymous arrays of two -elements each giving the type and identifier for each ACL entry. - -For example, the following simple function says to use a default owner -named C with one entry of type C and identifier -C for the object with type C and name -C: - - sub default_owner { - my ($type, $name) = @_; - if ($type eq 'keytab' and $name eq 'host/example.com') { - return ('default', [ 'krb5', 'rra@example.com' ]); - } else { - return; - } - } - -Of course, normally this function is used for more complex mappings. Here -is a more complete example. For objects of type keytab corresponding to -various types of per-machine principals, return a default owner that sets -as owner anyone with a NetDB role for that system and the system's host -principal. This permits authorization management using NetDB while also -allowing the system to bootstrap itself once the host principal has been -downloaded and rekey itself using the old host principal. - - sub default_owner { - my ($type, $name) = @_; - my %allowed = map { $_ => 1 } - qw(HTTP cifs host imap ldap nfs pop sieve smtp webauth); - my $realm = 'example.com'; - return unless $type eq 'keytab'; - return unless $name =~ m%/%; - my ($service, $instance) = split ('/', $name, 2); - return unless $allowed{$service}; - my $acl_name = "host/$instance"; - my @acl = ([ 'netdb', $instance ], - [ 'krb5', "host/$instance\@$realm" ]); - return ($acl_name, @acl); - } - -The auto-created ACL used for the owner of the new object will, in the -above example, be named C> where I is the -fully-qualified name of the system as derived from the keytab being -requested. - -If the name of the ACL returned by the default_owner function matches an -ACL that already exists in the wallet database, the existing ACL will be -compared to the default ACL returned by the default_owner function. If -the existing ACL has the same entries as the one returned by -default_owner, creation continues if the user is authorized by that ACL. -If they don't match, creation of the object is rejected, since the -presence of an existing ACL may indicate that something different is being -done with this object. - -=head1 NAMING ENFORCEMENT - -By default, wallet permits administrators to create objects of any name -(unless the object backend rejects the name). However, naming standards -for objects can be enforced, even for administrators, by defining a Perl -function in the configuration file named verify_name. If such a function -exists, it will be called for any object creation and will be passed the -type of object, the object name, and the identity of the person doing the -creation. If it returns undef or the empty string, object creation will -be allowed. If it returns anything else, object creation is rejected and -the return value is used as the error message. - -This function is also called for naming audits done via Wallet::Report -to find any existing objects that violate a (possibly updated) naming -policy. In this case, the third argument (the identity of the person -creating the object) will be undef. As a general rule, if the third -argument is undef, the function should apply the most liberal accepted -naming policy so that the audit returns only objects that violate all -naming policies, but some sites may wish different results for their audit -reports. - -Please note that this return status is backwards from what one would -normally expect. A false value is success; a true value is failure with -an error message. - -For example, the following verify_name function would ensure that any -keytab objects for particular principals have fully-qualified hostnames: - - sub verify_name { - my ($type, $name, $user) = @_; - my %host_based = map { $_ => 1 } - qw(HTTP cifs host imap ldap nfs pop sieve smtp webauth); - return unless $type eq 'keytab'; - return unless $name =~ m%/%; - my ($service, $instance) = split ('/', $name, 2); - return unless $host_based{$service}; - return "host name $instance must be fully qualified" - unless $instance =~ /\./; - return; - } - -Objects that aren't of type C or which aren't for a host-based key -have no naming requirements enforced by this example. - -=head1 ACL NAMING ENFORCEMENT - -Similar to object names, by default wallet permits administrators to -create ACLs with any name. However, naming standards for ACLs can be -enforced by defining a Perl function in the configuration file named -verify_acl_name. If such a function exists, it will be called for any ACL -creation or rename and will be passed given the new ACL name and the -identity of the person doing the creation. If it returns undef or the -empty string, object creation will be allowed. If it returns anything -else, object creation is rejected and the return value is used as the -error message. - -This function is also called for naming audits done via Wallet::Report to -find any existing objects that violate a (possibly updated) naming policy. -In this case, the second argument (the identity of the person creating the -ACL) will be undef. As a general rule, if the second argument is undef, -the function should apply the most liberal accepted naming policy so that -the audit returns only ACLs that violate all naming policies, but some -sites may wish different results for their audit reports. - -Please note that this return status is backwards from what one would -normally expect. A false value is success; a true value is failure with -an error message. - -For example, the following verify_acl_name function would ensure that any -ACLs created contain a slash and the part before the slash be one of -C, C, C, or C. - - sub verify_acl_name { - my ($name, $user) = @_; - return 'ACL names must contain a slash' unless $name =~ m,/,; - my ($first, $rest) = split ('/', $name, 2); - my %types = map { $_ => 1 } qw(host group user service); - unless ($types{$first}) { - return "unknown ACL type $first"; - } - return; - } - -Obvious improvements could be made, such as checking that the part after -the slash for a C ACL looked like a host name and the part after a -slash for a C ACL look like a user name. - -=head1 ENVIRONMENT - -=over 4 - -=item WALLET_CONFIG - -If this environment variable is set, it is taken to be the path to the -wallet configuration file to load instead of F. - -=back - -=cut - -# Now, load the configuration file so that it can override the defaults. -if (-r $PATH) { - do $PATH or die (($@ || $!) . "\n"); -} - -1; -__END__ - -=head1 SEE ALSO - -DBI(3), Wallet::Object::Keytab(3), Wallet::Server(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Database.pm b/perl/Wallet/Database.pm deleted file mode 100644 index 031be9e..0000000 --- a/perl/Wallet/Database.pm +++ /dev/null @@ -1,123 +0,0 @@ -# Wallet::Database -- Wallet system database connection management. -# -# This module is a thin wrapper around DBIx::Class to handle determination -# of the database configuration settings automatically on connect. The -# intention is that Wallet::Database objects can be treated in all respects -# like DBIx::Class objects in the rest of the code. -# -# Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Database; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Wallet::Schema; -use Wallet::Config; - -@ISA = qw(Wallet::Schema); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.04'; - -############################################################################## -# Core overrides -############################################################################## - -# Override DBI::connect to supply our own connect string, username, and -# password and to set some standard options. Takes no arguments other than -# the implicit class argument. -sub connect { - my ($class) = @_; - unless ($Wallet::Config::DB_DRIVER - and (defined ($Wallet::Config::DB_INFO) - or defined ($Wallet::Config::DB_NAME))) { - die "database connection information not configured\n"; - } - my $dsn = "DBI:$Wallet::Config::DB_DRIVER:"; - if (defined $Wallet::Config::DB_INFO) { - $dsn .= $Wallet::Config::DB_INFO; - } else { - $dsn .= "database=$Wallet::Config::DB_NAME"; - $dsn .= ";host=$Wallet::Config::DB_HOST" if $Wallet::Config::DB_HOST; - $dsn .= ";port=$Wallet::Config::DB_PORT" if $Wallet::Config::DB_PORT; - } - my $user = $Wallet::Config::DB_USER; - my $pass = $Wallet::Config::DB_PASSWORD; - my %attrs = (PrintError => 0, RaiseError => 1); - my $dbh = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) }; - if ($@) { - die "cannot connect to database: $@\n"; - } - return $dbh; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=head1 NAME - -Wallet::Dabase - Wrapper module for wallet database connections - -=for stopwords -DBI RaiseError PrintError AutoCommit Allbery - -=head1 SYNOPSIS - - use Wallet::Database; - my $dbh = Wallet::Database->connect; - -=head1 DESCRIPTION - -Wallet::Database is a thin wrapper module around DBI that takes care of -building a connect string and setting database options based on wallet -configuration. The only overridden method is connect(). All other -methods should work the same as in DBI and Wallet::Database objects should -be usable exactly as if they were DBI objects. - -connect() will obtain the database connection information from the wallet -configuration; see L for more details. It will also -automatically set the RaiseError attribute to true and the PrintError and -AutoCommit attributes to false, matching the assumptions made by the -wallet database code. - -=head1 CLASS METHODS - -=over 4 - -=item connect() - -Opens a new database connection and returns the database object. On any -failure, throws an exception. Unlike the DBI method, connect() takes no -arguments; all database connection information is derived from the wallet -configuration. - -=back - -=head1 SEE ALSO - -DBI(3), Wallet::Config(3) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm deleted file mode 100644 index 4ea7920..0000000 --- a/perl/Wallet/Kadmin.pm +++ /dev/null @@ -1,240 +0,0 @@ -# Wallet::Kadmin -- Kerberos administration API for wallet keytab backend. -# -# Written by Jon Robertson -# Copyright 2009, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Kadmin; -require 5.006; - -use strict; -use vars qw($VERSION); - -use Wallet::Config (); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.03'; - -############################################################################## -# Utility functions for child classes -############################################################################## - -# Read the entirety of a possibly binary file and return the contents, -# deleting the file after reading it. If reading the file fails, set the -# error message and return undef. -sub read_keytab { - my ($self, $file) = @_; - local *TMPFILE; - unless (open (TMPFILE, '<', $file)) { - $self->error ("cannot open temporary file $file: $!"); - return; - } - local $/; - undef $!; - my $data = ; - if ($!) { - $self->error ("cannot read temporary file $file: $!"); - unlink $file; - return; - } - close TMPFILE; - unlink $file; - return $data; -} - -############################################################################## -# Public methods -############################################################################## - -# Create a new kadmin object, by finding the type requested in the wallet -# config and passing off to the proper module. Returns the object directly -# from the specific Wallet::Kadmin::* module. -sub new { - my ($class) = @_; - my $kadmin; - if (not $Wallet::Config::KEYTAB_KRBTYPE) { - die "keytab object implementation not configured\n"; - } elsif (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'mit') { - require Wallet::Kadmin::MIT; - $kadmin = Wallet::Kadmin::MIT->new; - } elsif (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'heimdal') { - require Wallet::Kadmin::Heimdal; - $kadmin = Wallet::Kadmin::Heimdal->new; - } else { - my $type = $Wallet::Config::KEYTAB_KRBTYPE; - die "unknown KEYTAB_KRBTYPE setting: $type\n"; - } - - return $kadmin; -} - -# Set or return the error stashed in the object. -sub error { - my ($self, @error) = @_; - if (@error) { - my $error = join ('', @error); - chomp $error; - 1 while ($error =~ s/ at \S+ line \d+\.?\z//); - $self->{error} = $error; - } - return $self->{error}; -} - -# Set a callback to be called for forked kadmin processes. This does nothing -# by default but may be overridden by subclasses that need special behavior -# (such as the current Wallet::Kadmin::MIT module). -sub fork_callback { } - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -backend Kadmin keytabs keytab Heimdal API kadmind kadmin KDC ENCTYPE -enctypes enctype Allbery - -=head1 NAME - -Wallet::Kadmin - Kerberos administration API for wallet keytab backend - -=head1 SYNOPSIS - - my $kadmin = Wallet::Kadmin->new; - $kadmin->create ('host/foo.example.com'); - my $data = $kadmin->keytab_rekey ('host/foo.example.com', - 'aes256-cts-hmac-sha1-96'); - $data = $kadmin->keytab ('host/foo.example.com'); - my $exists = $kadmin->exists ('host/oldshell.example.com'); - $kadmin->destroy ('host/oldshell.example.com') if $exists; - -=head1 DESCRIPTION - -Wallet::Kadmin is a wrapper and base class for modules that provide an -interface for wallet to do Kerberos administration, specifically create -and delete principals and create keytabs for a principal. Each subclass -administers a specific type of Kerberos implementation, such as MIT -Kerberos or Heimdal, providing a standard set of API calls used to -interact with that implementation's kadmin interface. - -The class uses Wallet::Config to find which type of kadmin interface is in -use and then returns an object to use for interacting with that interface. -See L for details on how to -configure this module. - -=head1 CLASS METHODS - -=over 4 - -=item new() - -Finds the proper Kerberos implementation and calls the new() constructor -for that implementation's module, returning the resulting object. If the -implementation is not recognized or set, die with an error message. - -=back - -=head1 INSTANCE METHODS - -These methods are provided by any object returned by new(), regardless of -the underlying kadmin interface. They are implemented by the child class -appropriate for the configured Kerberos implementation. - -=over 4 - -=item create(PRINCIPAL) - -Adds a new principal with a given name. The principal is created with a -random password, and any other flags set by Wallet::Config. Returns true -on success and false on failure. If the principal already exists, return -true as we are bringing our expectations in line with reality. - -=item destroy(PRINCIPAL) - -Removes a principal with the given name. Returns true on success or false -on failure. If the principal does not exist, return true as we are -bringing our expectations in line with reality. - -=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. - -For the convenience of child classes, this method can also be called with -one or more error strings. If so, those strings are concatenated -together, trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is -stored as the error. Only child classes should call this method with an -error string. - -=item exists(PRINCIPAL) - -Returns true if the given principal exists in the KDC and C<0> if it -doesn't. If an error is encountered in checking whether the principal -exists, exists() returns undef. - -=item fork_callback(CALLBACK) - -If the module has to fork an external process for some reason, such as a -kadmin command-line client, the sub CALLBACK will be called in the child -process before running the program. This can be used to, for example, -properly clean up shared database handles. - -=item keytab(PRINCIPAL) - -keytab() creates a keytab for the given principal, storing it in the given -file. A keytab is an on-disk store for the key or keys for a Kerberos -principal. Keytabs are used by services to verify incoming authentication -from clients or by automated processes that need to authenticate to -Kerberos. To create a keytab, the principal has to have previously been -created in the Kerberos KDC. Returns the keytab as binary data on success -and undef on failure. - -=item keytab_rekey(PRINCIPAL [, ENCTYPE ...]) - -Like keytab(), but randomizes the key for the principal before generating -the keytab and writes it to the given file. This will invalidate any -existing keytabs for that principal. This method can also limit the -encryption types of the keys for that principal via the optional ENCTYPE -arguments. The enctype values must be enctype strings recognized by the -Kerberos implementation (strings like C or -C). If none are given, the KDC defaults will be used. -Returns the keytab as binary data on success and undef on failure. - -=back - -The following methods are utility methods to aid with child class -implementation and should only be called by child classes. - -=over 4 - -=item read_keytab(FILE) - -Reads the contents of the keytab stored in FILE into memory and returns it -as binary data. On failure, returns undef and sets the object error. - -=back - -=head1 SEE ALSO - -kadmin(8), Wallet::Config(3), Wallet::Object::Keytab(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHORS - -Jon Robertson and Russ Allbery - -=cut diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm deleted file mode 100644 index 42de8e0..0000000 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ /dev/null @@ -1,314 +0,0 @@ -# Wallet::Kadmin::Heimdal -- Wallet Kerberos administration API for Heimdal. -# -# Written by Jon Robertson -# Copyright 2009, 2010, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Kadmin::Heimdal; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Heimdal::Kadm5 qw(KRB5_KDB_DISALLOW_ALL_TIX); -use Wallet::Config (); -use Wallet::Kadmin (); - -@ISA = qw(Wallet::Kadmin); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.04'; - -############################################################################## -# Utility functions -############################################################################## - -# Add the realm to the end of the principal if no realm is currently present. -sub canonicalize_principal { - my ($self, $principal) = @_; - if ($Wallet::Config::KEYTAB_REALM && $principal !~ /\@/) { - $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - } - return $principal; -} - -# Generate a long random password. -# -# Please note: This is not a cryptographically secure password! It's used -# only because the Heimdal kadmin interface requires a password on create. -# The keys will be set before the principal is ever set active, so it will -# never be possible to use the password. It just needs to be random in case -# password quality checks are applied to it. -# -# Make the password reasonably long and include a variety of character classes -# so that it should pass any password strength checking. -sub insecure_random_password { - my ($self) = @_; - my @classes = ( - 'abcdefghijklmnopqrstuvwxyz', - 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', - '0123456789', - '~`!@#$%^&*()-_+={[}]|:;<,>.?/' - ); - my $password = q{}; - for my $i (1..20) { - my $class = $i % scalar (@classes); - my $alphabet = $classes[$class]; - my $letter = substr ($alphabet, int (rand (length $alphabet)), 1); - $password .= $letter; - } - return $password; -} - -############################################################################## -# Public interfaces -############################################################################## - -# Check whether a given principal already exists in Kerberos. Returns true if -# so, false otherwise. -sub exists { - my ($self, $principal) = @_; - $principal = $self->canonicalize_principal ($principal); - my $kadmin = $self->{client}; - my $princdata = eval { $kadmin->getPrincipal ($principal) }; - if ($@) { - $self->error ("error getting principal: $@"); - return; - } - return $princdata ? 1 : 0; -} - -# Create a principal in Kerberos. If there is an error, return undef and set -# the error. Return 1 on success or the principal already existing. -sub create { - my ($self, $principal) = @_; - $principal = $self->canonicalize_principal ($principal); - my $exists = eval { $self->exists ($principal) }; - if ($@) { - $self->error ("error adding principal $principal: $@"); - return; - } - return 1 if $exists; - - # The way Heimdal::Kadm5 works, we create a principal object, create the - # actual principal set inactive, then randomize it and activate it. We - # have to set a password, even though we're about to replace it with - # random keys, but since the principal is created inactive, it doesn't - # have to be a very good one. - my $kadmin = $self->{client}; - eval { - my $princdata = $kadmin->makePrincipal ($principal); - my $attrs = $princdata->getAttributes; - $attrs |= KRB5_KDB_DISALLOW_ALL_TIX; - $princdata->setAttributes ($attrs); - my $password = $self->insecure_random_password; - $kadmin->createPrincipal ($princdata, $password, 0); - $kadmin->randKeyPrincipal ($principal); - $kadmin->enablePrincipal ($principal); - }; - if ($@) { - $self->error ("error adding principal $principal: $@"); - return; - } - return 1; -} - -# Create a keytab for a principal. Returns the keytab as binary data or undef -# on failure, setting the error. -sub keytab { - my ($self, $principal) = @_; - $principal = $self->canonicalize_principal ($principal); - my $kadmin = $self->{client}; - my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; - unlink $file; - my $princdata = eval { $kadmin->getPrincipal ($principal) }; - if ($@) { - $self->error ("error creating keytab for $principal: $@"); - return; - } elsif (!$princdata) { - $self->error ("error creating keytab for $principal: principal does" - . " not exist"); - return; - } - eval { $kadmin->extractKeytab ($princdata, $file) }; - if ($@) { - $self->error ("error creating keytab for principal: $@"); - return; - } - return $self->read_keytab ($file); -} - -# Create a keytab for a principal, randomizing the keys for that principal at -# the same time. Takes the principal and an optional list of encryption types -# to which to limit the keytab. Return the keytab data on success and undef -# on failure. If the keytab creation fails, sets the error. -sub keytab_rekey { - my ($self, $principal, @enctypes) = @_; - $principal = $self->canonicalize_principal ($principal); - - # The way Heimdal works, you can only remove enctypes from a principal, - # not add them back in. So we need to run randkeyPrincipal first each - # time to restore all possible enctypes and then whittle them back down - # to those we have been asked for this time. - my $kadmin = $self->{client}; - eval { $kadmin->randKeyPrincipal ($principal) }; - if ($@) { - $self->error ("error creating keytab for $principal: could not" - . " reinit enctypes: $@"); - return; - } - my $princdata = eval { $kadmin->getPrincipal ($principal) }; - if ($@) { - $self->error ("error creating keytab for $principal: $@"); - return; - } elsif (!$princdata) { - $self->error ("error creating keytab for $principal: principal does" - . " not exist"); - return; - } - - # Now actually remove any non-requested enctypes, if we requested any. - if (@enctypes) { - my $alltypes = $princdata->getKeytypes; - my %wanted = map { $_ => 1 } @enctypes; - for my $key (@{ $alltypes }) { - my $keytype = $key->[0]; - next if exists $wanted{$keytype}; - eval { $princdata->delKeytypes ($keytype) }; - if ($@) { - $self->error ("error removing keytype $keytype from the" - . " keytab: $@"); - return; - } - } - eval { $kadmin->modifyPrincipal ($princdata) }; - if ($@) { - $self->error ("error saving principal modifications: $@"); - return; - } - } - - # Create the keytab. - my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; - unlink $file; - eval { $kadmin->extractKeytab ($princdata, $file) }; - if ($@) { - $self->error ("error creating keytab for principal: $@"); - return; - } - return $self->read_keytab ($file); -} - -# Delete a principal from Kerberos. Return true if successful, false -# otherwise. If the deletion fails, sets the error. If the principal doesn't -# exist, return success; we're bringing reality in line with our expectations. -sub destroy { - my ($self, $principal) = @_; - $principal = $self->canonicalize_principal ($principal); - my $exists = eval { $self->exists ($principal) }; - if ($@) { - $self->error ("error checking principal existance: $@"); - return; - } elsif (not $exists) { - return 1; - } - my $kadmin = $self->{client}; - my $retval = eval { $kadmin->deletePrincipal ($principal) }; - if ($@) { - $self->error ("error deleting $principal: $@"); - return; - } - return 1; -} - -# Create a new Wallet::Kadmin::Heimdal object and its underlying -# Heimdal::Kadm5 object. -sub new { - my ($class) = @_; - unless (defined ($Wallet::Config::KEYTAB_PRINCIPAL) - and defined ($Wallet::Config::KEYTAB_FILE) - and defined ($Wallet::Config::KEYTAB_REALM)) { - die "keytab object implementation not configured\n"; - } - unless (defined ($Wallet::Config::KEYTAB_TMP)) { - die "KEYTAB_TMP configuration variable not set\n"; - } - my @options = (RaiseError => 1, - Principal => $Wallet::Config::KEYTAB_PRINCIPAL, - Realm => $Wallet::Config::KEYTAB_REALM, - Keytab => $Wallet::Config::KEYTAB_FILE); - if ($Wallet::Config::KEYTAB_HOST) { - push (@options, Server => $Wallet::Config::KEYTAB_HOST); - } - my $client = Heimdal::Kadm5::Client->new (@options); - my $self = { client => $client }; - bless ($self, $class); - return $self; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -keytabs keytab kadmin KDC API Allbery Heimdal unlinked - -=head1 NAME - -Wallet::Kadmin::Heimdal - Wallet Kerberos administration API for Heimdal - -=head1 SYNOPSIS - - my $kadmin = Wallet::Kadmin::Heimdal->new; - $kadmin->create ('host/foo.example.com'); - $kadmin->keytab_rekey ('host/foo.example.com', 'keytab', - 'aes256-cts-hmac-sha1-96'); - my $data = $kadmin->keytab ('host/foo.example.com'); - my $exists = $kadmin->exists ('host/oldshell.example.com'); - $kadmin->destroy ('host/oldshell.example.com') if $exists; - -=head1 DESCRIPTION - -Wallet::Kadmin::Heimdal implements the Wallet::Kadmin API for Heimdal, -providing an interface to create and delete principals and create keytabs. -It provides the API documented in L for a Heimdal KDC. - -To use this class, several configuration parameters must be set. See -L for details. - -=head1 FILES - -=over 4 - -=item KEYTAB_TMP/keytab. - -The keytab is created in this file and then read into memory. KEYTAB_TMP -is set in the wallet configuration, and is the process ID of the -current process. The file is unlinked after being read. - -=back - -=head1 SEE ALSO - -kadmin(8), Wallet::Config(3), Wallet::Kadmin(3), -Wallet::Object::Keytab(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHORS - -Russ Allbery and Jon Robertson . - -=cut diff --git a/perl/Wallet/Kadmin/MIT.pm b/perl/Wallet/Kadmin/MIT.pm deleted file mode 100644 index 1ae01bf..0000000 --- a/perl/Wallet/Kadmin/MIT.pm +++ /dev/null @@ -1,323 +0,0 @@ -# Wallet::Kadmin::MIT -- Wallet Kerberos administration API for MIT. -# -# Written by Russ Allbery -# Pulled into a module by Jon Robertson -# Copyright 2007, 2008, 2009, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Kadmin::MIT; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Wallet::Config (); -use Wallet::Kadmin (); - -@ISA = qw(Wallet::Kadmin); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.03'; - -############################################################################## -# kadmin Interaction -############################################################################## - -# Make sure that principals are well-formed and don't contain characters that -# will cause us problems when talking to kadmin. Takes a principal and -# returns true if it's okay, false otherwise. Note that we do not permit -# realm information here. -sub valid_principal { - my ($self, $principal) = @_; - return scalar ($principal =~ m,^[\w-]+(/[\w_.-]+)?\z,); -} - -# Run a kadmin command and capture the output. Returns the output, either as -# a list of lines or, in scalar context, as one string. The exit status of -# kadmin is often worthless. -sub kadmin { - my ($self, $command) = @_; - unless (defined ($Wallet::Config::KEYTAB_PRINCIPAL) - and defined ($Wallet::Config::KEYTAB_FILE) - and defined ($Wallet::Config::KEYTAB_REALM)) { - die "keytab object implementation not configured\n"; - } - my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', '-t', - $Wallet::Config::KEYTAB_FILE, '-q', $command); - push (@args, '-s', $Wallet::Config::KEYTAB_HOST) - if $Wallet::Config::KEYTAB_HOST; - push (@args, '-r', $Wallet::Config::KEYTAB_REALM) - if $Wallet::Config::KEYTAB_REALM; - my $pid = open (KADMIN, '-|'); - if (not defined $pid) { - $self->error ("cannot fork: $!"); - return; - } elsif ($pid == 0) { - $self->{fork_callback} () if $self->{fork_callback}; - unless (open (STDERR, '>&STDOUT')) { - warn "wallet: cannot dup stdout: $!\n"; - exit 1; - } - unless (exec ($Wallet::Config::KEYTAB_KADMIN, @args)) { - warn "wallet: cannot run $Wallet::Config::KEYTAB_KADMIN: $!\n"; - exit 1; - } - } - local $_; - my @output; - while () { - if (/^wallet: cannot /) { - s/^wallet: //; - $self->error ($_); - return; - } - push (@output, $_) unless /Authenticating as principal/; - } - close KADMIN; - return wantarray ? @output : join ('', @output); -} - -############################################################################## -# Public interfaces -############################################################################## - -# Set a callback to be called for forked kadmin processes. -sub fork_callback { - my ($self, $callback) = @_; - $self->{fork_callback} = $callback; -} - -# Check whether a given principal already exists in Kerberos. Returns true if -# so, false otherwise. Returns undef if kadmin fails, with the error already -# set by kadmin. -sub exists { - my ($self, $principal) = @_; - return unless $self->valid_principal ($principal); - if ($Wallet::Config::KEYTAB_REALM) { - $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - } - my $output = $self->kadmin ("getprinc $principal"); - if (!defined $output) { - return; - } elsif ($output =~ /^get_principal: /) { - return 0; - } else { - return 1; - } -} - -# Create a principal in Kerberos. Sets the error and returns undef on failure, -# and returns 1 on either success or the principal already existing. -sub create { - my ($self, $principal) = @_; - unless ($self->valid_principal ($principal)) { - $self->error ("invalid principal name $principal"); - return; - } - return 1 if $self->exists ($principal); - if ($Wallet::Config::KEYTAB_REALM) { - $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - } - my $flags = $Wallet::Config::KEYTAB_FLAGS || ''; - my $output = $self->kadmin ("addprinc -randkey $flags $principal"); - if (!defined $output) { - return; - } elsif ($output =~ /^add_principal: (.*)/m) { - $self->error ("error adding principal $principal: $1"); - return; - } - return 1; -} - -# Retrieve an existing keytab from the KDC via a remctl call. The KDC needs -# to be running the keytab-backend script and support the keytab retrieve -# remctl command. In addition, the user must have configured us with the path -# to a ticket cache and the host to which to connect with remctl. Returns the -# keytab on success and undef on failure. -sub keytab { - my ($self, $principal) = @_; - my $host = $Wallet::Config::KEYTAB_REMCTL_HOST; - unless ($host and $Wallet::Config::KEYTAB_REMCTL_CACHE) { - $self->error ('keytab unchanging support not configured'); - return; - } - eval { require Net::Remctl }; - if ($@) { - $self->error ("keytab unchanging support not available: $@"); - return; - } - if ($principal !~ /\@/ && $Wallet::Config::KEYTAB_REALM) { - $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - } - local $ENV{KRB5CCNAME} = $Wallet::Config::KEYTAB_REMCTL_CACHE; - my $port = $Wallet::Config::KEYTAB_REMCTL_PORT || 0; - my $remctl_princ = $Wallet::Config::KEYTAB_REMCTL_PRINCIPAL || ''; - my @command = ('keytab', 'retrieve', $principal); - my $result = Net::Remctl::remctl ($host, $port, $remctl_princ, @command); - if ($result->error) { - $self->error ("cannot retrieve keytab for $principal: ", - $result->error); - return; - } elsif ($result->status != 0) { - my $error = $result->stderr; - $error =~ s/\s+$//; - $error =~ s/\n/ /g; - $self->error ("cannot retrieve keytab for $principal: $error"); - return; - } else { - return $result->stdout; - } -} - -# Create a keytab for a principal, randomizing the keys for that principal -# in the process. Takes the principal and an optional list of encryption -# types to which to limit the keytab. Return the keytab data on success -# and undef otherwise. If the keytab creation fails, sets the error. -sub keytab_rekey { - my ($self, $principal, @enctypes) = @_; - unless ($self->valid_principal ($principal)) { - $self->error ("invalid principal name: $principal"); - return; - } - if ($Wallet::Config::KEYTAB_REALM) { - $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - } - my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; - unlink $file; - my $command = "ktadd -q -k $file"; - if (@enctypes) { - @enctypes = map { /:/ ? $_ : "$_:normal" } @enctypes; - $command .= ' -e "' . join (' ', @enctypes) . '"'; - } - my $output = $self->kadmin ("$command $principal"); - if (!defined $output) { - return; - } elsif ($output =~ /^(?:kadmin|ktadd): (.*)/m) { - $self->error ("error creating keytab for $principal: $1"); - return; - } - return $self->read_keytab ($file); -} - -# Delete a principal from Kerberos. Return true if successful, false -# otherwise. If the deletion fails, sets the error. If the principal doesn't -# exist, return success; we're bringing reality in line with our expectations. -sub destroy { - my ($self, $principal) = @_; - unless ($self->valid_principal ($principal)) { - $self->error ("invalid principal name: $principal"); - } - my $exists = $self->exists ($principal); - if (!defined $exists) { - return; - } elsif (not $exists) { - return 1; - } - if ($Wallet::Config::KEYTAB_REALM) { - $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - } - my $output = $self->kadmin ("delprinc -force $principal"); - if (!defined $output) { - return; - } elsif ($output =~ /^delete_principal: (.*)/m) { - $self->error ("error deleting $principal: $1"); - return; - } - return 1; -} - -# Create a new MIT kadmin object. Very empty for the moment, but later it -# will probably fill out if we go to using a module rather than calling -# kadmin directly. -sub new { - my ($class) = @_; - unless (defined ($Wallet::Config::KEYTAB_TMP)) { - die "KEYTAB_TMP configuration variable not set\n"; - } - my $self = {}; - bless ($self, $class); - return $self; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -rekeying rekeys remctl backend keytabs keytab kadmin KDC API Allbery -unlinked - -=head1 NAME - -Wallet::Kadmin::MIT - Wallet Kerberos administration API for MIT - -=head1 SYNOPSIS - - my $kadmin = Wallet::Kadmin::MIT->new; - $kadmin->create ('host/foo.example.com'); - my $data = $kadmin->keytab_rekey ('host/foo.example.com', - 'aes256-cts-hmac-sha1-96'); - $data = $kadmin->keytab ('host/foo.example.com'); - my $exists = $kadmin->exists ('host/oldshell.example.com'); - $kadmin->destroy ('host/oldshell.example.com') if $exists; - -=head1 DESCRIPTION - -Wallet::Kadmin::MIT implements the Wallet::Kadmin API for MIT Kerberos, -providing an interface to create and delete principals and create keytabs. -It provides the API documented in L for an MIT Kerberos -KDC. - -MIT Kerberos does not provide any method via the kadmin network protocol -to retrieve a keytab for a principal without rekeying it, so the keytab() -method (as opposed to keytab_rekey(), which rekeys the principal) is -implemented using a remctl backend. For that method (used for unchanging -keytab objects) to work, the necessary wallet configuration and remctl -interface on the KDC must be set up. - -To use this class, several configuration parameters must be set. See -L for details. - -=head1 FILES - -=over 4 - -=item KEYTAB_TMP/keytab. - -The keytab is created in this file and then read into memory. KEYTAB_TMP -is set in the wallet configuration, and is the process ID of the -current process. The file is unlinked after being read. - -=back - -=head1 LIMITATIONS - -Currently, this implementation calls an external B program rather -than using a native Perl module and therefore requires B be -installed and parses its output. It may miss some error conditions if the -output of B ever changes. - -=head1 SEE ALSO - -kadmin(8), Wallet::Config(3), Wallet::Kadmin(3), -Wallet::Object::Keytab(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHORS - -Russ Allbery and Jon Robertson . - -=cut diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm deleted file mode 100644 index 8debac9..0000000 --- a/perl/Wallet/Object/Base.pm +++ /dev/null @@ -1,1015 +0,0 @@ -# Wallet::Object::Base -- Parent class for any object stored in the wallet. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Object::Base; -require 5.006; - -use strict; -use vars qw($VERSION); - -use DBI; -use POSIX qw(strftime); -use Text::Wrap qw(wrap); -use Wallet::ACL; - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.06'; - -############################################################################## -# Constructors -############################################################################## - -# Initialize an object from the database. Verifies that the object already -# exists with the given type, and if it does, returns a new blessed object of -# the specified class. Stores the database handle to use, the name, and the -# type in the object. If the object doesn't exist, returns undef. This will -# probably be usable as-is by most object types. -sub new { - my ($class, $type, $name, $schema) = @_; - my %search = (ob_type => $type, - ob_name => $name); - my $object = $schema->resultset('Object')->find (\%search); - die "cannot find ${type}:${name}\n" - unless ($object and $object->ob_name eq $name); - my $self = { - schema => $schema, - name => $name, - type => $type, - }; - bless ($self, $class); - return $self; -} - -# Create a new object in the database of the specified name and type, setting -# the ob_created_* fields accordingly, and returns a new blessed object of the -# specified class. Stores the database handle to use, the name, and the type -# in the object. Subclasses may need to override this to do additional setup. -sub create { - my ($class, $type, $name, $schema, $user, $host, $time) = @_; - $time ||= time; - die "invalid object type\n" unless $type; - die "invalid object name\n" unless $name; - my $guard = $schema->txn_scope_guard; - eval { - my %record = (ob_type => $type, - ob_name => $name, - ob_created_by => $user, - ob_created_from => $host, - ob_created_on => strftime ('%Y-%m-%d %T', - localtime $time)); - $schema->resultset('Object')->create (\%record); - - %record = (oh_type => $type, - oh_name => $name, - oh_action => 'create', - oh_by => $user, - oh_from => $host, - oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $schema->resultset('ObjectHistory')->create (\%record); - - $guard->commit; - }; - if ($@) { - die "cannot create object ${type}:${name}: $@\n"; - } - my $self = { - schema => $schema, - name => $name, - type => $type, - }; - bless ($self, $class); - return $self; -} - -############################################################################## -# Utility functions -############################################################################## - -# Set or return the error stashed in the object. -sub error { - my ($self, @error) = @_; - if (@error) { - my $error = join ('', @error); - chomp $error; - 1 while ($error =~ s/ at \S+ line \d+\.?\z//); - $self->{error} = $error; - } - return $self->{error}; -} - -# Returns the type of the object. -sub type { - my ($self) = @_; - return $self->{type}; -} - -# Returns the name of the object. -sub name { - my ($self) = @_; - return $self->{name}; -} - -# Record a global object action for this object. Takes the action (which must -# be one of get or store), and the trace information: user, host, and time. -# Returns true on success and false on failure, setting error appropriately. -# -# This function commits its transaction when complete and should not be called -# inside another transaction. -sub log_action { - my ($self, $action, $user, $host, $time) = @_; - unless ($action =~ /^(get|store)\z/) { - $self->error ("invalid history action $action"); - return; - } - - # We have two traces to record, one in the object_history table and one in - # the object record itself. Commit both changes as a transaction. We - # assume that AutoCommit is turned off. - my $guard = $self->{schema}->txn_scope_guard; - eval { - my %record = (oh_type => $self->{type}, - oh_name => $self->{name}, - oh_action => $action, - oh_by => $user, - oh_from => $host, - oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{schema}->resultset('ObjectHistory')->create (\%record); - - my %search = (ob_type => $self->{type}, - ob_name => $self->{name}); - my $object = $self->{schema}->resultset('Object')->find (\%search); - if ($action eq 'get') { - $object->ob_downloaded_by ($user); - $object->ob_downloaded_from ($host); - $object->ob_downloaded_on (strftime ('%Y-%m-%d %T', - localtime $time)); - } elsif ($action eq 'store') { - $object->ob_stored_by ($user); - $object->ob_stored_from ($host); - $object->ob_stored_on (strftime ('%Y-%m-%d %T', - localtime $time)); - } - $object->update; - $guard->commit; - }; - if ($@) { - my $id = $self->{type} . ':' . $self->{name}; - $self->error ("cannot update history for $id: $@"); - return; - } - return 1; -} - -# Record a setting change for this object. Takes the field, the old value, -# the new value, and the trace information (user, host, and time). The field -# may have the special value "type_data " in which case the value after -# the whitespace is used as the type_field value. -# -# This function does not commit and does not catch exceptions. It should -# normally be called as part of a larger transaction that implements the -# setting change and should be committed with that change. -sub log_set { - my ($self, $field, $old, $new, $user, $host, $time) = @_; - my $type_field; - if ($field =~ /^type_data\s+/) { - ($field, $type_field) = split (' ', $field, 2); - } - my %fields = map { $_ => 1 } - qw(owner acl_get acl_store acl_show acl_destroy acl_flags expires - comment flags type_data); - unless ($fields{$field}) { - die "invalid history field $field"; - } - - my %record = (oh_type => $self->{type}, - oh_name => $self->{name}, - oh_action => 'set', - oh_field => $field, - oh_type_field => $type_field, - oh_old => $old, - oh_new => $new, - oh_by => $user, - oh_from => $host, - oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{schema}->resultset('ObjectHistory')->create (\%record); -} - -############################################################################## -# Get/set values -############################################################################## - -# Set a particular attribute. Takes the attribute to set and its new value. -# Returns undef on failure and true on success. -sub _set_internal { - my ($self, $attr, $value, $user, $host, $time) = @_; - if ($attr !~ /^[a-z_]+\z/) { - $self->error ("invalid attribute $attr"); - return; - } - $time ||= time; - my $name = $self->{name}; - my $type = $self->{type}; - if ($self->flag_check ('locked')) { - $self->error ("cannot modify ${type}:${name}: object is locked"); - return; - } - - my $guard = $self->{schema}->txn_scope_guard; - eval { - my %search = (ob_type => $type, - ob_name => $name); - my $object = $self->{schema}->resultset('Object')->find (\%search); - my $old = $object->get_column ("ob_$attr"); - - $object->update ({ "ob_$attr" => $value }); - $self->log_set ($attr, $old, $value, $user, $host, $time); - $guard->commit; - }; - if ($@) { - my $id = $self->{type} . ':' . $self->{name}; - $self->error ("cannot set $attr on $id: $@"); - return; - } - return 1; -} - -# Get a particular attribute. Returns the attribute value or undef if the -# value isn't set or on a database error. The two cases can be distinguished -# by whether $self->{error} is set. -sub _get_internal { - my ($self, $attr) = @_; - undef $self->{error}; - if ($attr !~ /^[a-z_]+\z/) { - $self->error ("invalid attribute $attr"); - return; - } - $attr = 'ob_' . $attr; - my $name = $self->{name}; - my $type = $self->{type}; - my $value; - eval { - my %search = (ob_type => $type, - ob_name => $name); - my $object = $self->{schema}->resultset('Object')->find (\%search); - $value = $object->get_column ($attr); - }; - if ($@) { - $self->error ($@); - return; - } - return $value; -} - -# Get or set an ACL on an object. Takes the type of ACL and, if setting, the -# new ACL identifier. If setting it, trace information must also be provided. -sub acl { - my ($self, $type, $id, $user, $host, $time) = @_; - if ($type !~ /^(get|store|show|destroy|flags)\z/) { - $self->error ("invalid ACL type $type"); - return; - } - my $attr = "acl_$type"; - if ($id) { - my $acl; - eval { $acl = Wallet::ACL->new ($id, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } - return $self->_set_internal ($attr, $acl->id, $user, $host, $time); - } elsif (defined $id) { - return $self->_set_internal ($attr, undef, $user, $host, $time); - } else { - return $self->_get_internal ($attr); - } -} - -# Get or set an attribute on an object. Takes the name of the attribute and, -# if setting, the values and trace information. The values must be provided -# as a reference to an array, even if there is only one value. -# -# Attributes are used by backends for backend-specific information (such as -# enctypes for a keytab). The default implementation rejects all attribute -# names as unknown. -sub attr { - my ($self, $attr, $values, $user, $host, $time) = @_; - $self->error ("unknown attribute $attr"); - return; -} - -# Format the object attributes for inclusion in show(). The default -# implementation just returns the empty string. -sub attr_show { - my ($self) = @_; - return ''; -} - -# Get or set the comment value of an object. If setting it, trace information -# must also be provided. -sub comment { - my ($self, $comment, $user, $host, $time) = @_; - if ($comment) { - return $self->_set_internal ('comment', $comment, $user, $host, $time); - } elsif (defined $comment) { - return $self->_set_internal ('comment', undef, $user, $host, $time); - } else { - return $self->_get_internal ('comment'); - } -} - -# Get or set the expires value of an object. Expects an expiration time in -# seconds since epoch. If setting the expiration, trace information must also -# be provided. -sub expires { - my ($self, $expires, $user, $host, $time) = @_; - if ($expires) { - if ($expires !~ /^\d{4}-\d\d-\d\d( \d\d:\d\d:\d\d)?\z/) { - $self->error ("malformed expiration time $expires"); - return; - } - return $self->_set_internal ('expires', $expires, $user, $host, $time); - } elsif (defined $expires) { - return $self->_set_internal ('expires', undef, $user, $host, $time); - } else { - return $self->_get_internal ('expires'); - } -} - -# Get or set the owner of an object. If setting it, trace information must -# also be provided. -sub owner { - my ($self, $owner, $user, $host, $time) = @_; - if ($owner) { - my $acl; - eval { $acl = Wallet::ACL->new ($owner, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } - return $self->_set_internal ('owner', $acl->id, $user, $host, $time); - } elsif (defined $owner) { - return $self->_set_internal ('owner', undef, $user, $host, $time); - } else { - return $self->_get_internal ('owner'); - } -} - -############################################################################## -# Flags -############################################################################## - -# Check whether a flag is set on the object. Returns true if set, 0 if not -# set, and undef on error. -sub flag_check { - my ($self, $flag) = @_; - my $name = $self->{name}; - my $type = $self->{type}; - my $schema = $self->{schema}; - my $value; - eval { - my %search = (fl_type => $type, - fl_name => $name, - fl_flag => $flag); - my $flag = $schema->resultset('Flag')->find (\%search); - if (not defined $flag) { - $value = 0; - } else { - $value = $flag->fl_flag; - } - }; - if ($@) { - $self->error ("cannot check flag $flag for ${type}:${name}: $@"); - return; - } else { - return ($value) ? 1 : 0; - } -} - -# Clear a flag on an object. Takes the flag and trace information. Returns -# true on success and undef on failure. -sub flag_clear { - my ($self, $flag, $user, $host, $time) = @_; - $time ||= time; - my $name = $self->{name}; - my $type = $self->{type}; - my $schema = $self->{schema}; - my $guard = $schema->txn_scope_guard; - eval { - my %search = (fl_type => $type, - fl_name => $name, - fl_flag => $flag); - my $flag = $schema->resultset('Flag')->find (\%search); - unless (defined $flag) { - die "flag not set\n"; - } - $flag->delete; - $self->log_set ('flags', $flag->fl_flag, undef, $user, $host, $time); - $guard->commit; - }; - if ($@) { - $self->error ("cannot clear flag $flag on ${type}:${name}: $@"); - return; - } - return 1; -} - -# List the flags on an object. Returns a list of flag names, which may be -# empty. On error, returns the empty list. The caller should call error() in -# this case to determine if an error occurred. -sub flag_list { - my ($self) = @_; - undef $self->{error}; - my @flags; - eval { - my %search = (fl_type => $self->{type}, - fl_name => $self->{name}); - my %attrs = (order_by => 'fl_flag'); - my @flags_rs = $self->{schema}->resultset('Flag')->search (\%search, - \%attrs); - for my $flag (@flags_rs) { - push (@flags, $flag->fl_flag); - } - }; - if ($@) { - my $id = $self->{type} . ':' . $self->{name}; - $self->error ("cannot retrieve flags for $id: $@"); - return; - } else { - return @flags; - } -} - -# Set a flag on an object. Takes the flag and trace information. Returns -# true on success and undef on failure. -sub flag_set { - my ($self, $flag, $user, $host, $time) = @_; - $time ||= time; - my $name = $self->{name}; - my $type = $self->{type}; - my $schema = $self->{schema}; - my $guard = $schema->txn_scope_guard; - eval { - my %search = (fl_type => $type, - fl_name => $name, - fl_flag => $flag); - my $flag = $schema->resultset('Flag')->find (\%search); - if (defined $flag) { - die "flag already set\n"; - } - $flag = $schema->resultset('Flag')->create (\%search); - $self->log_set ('flags', undef, $flag->fl_flag, $user, $host, $time); - $guard->commit; - }; - if ($@) { - $self->error ("cannot set flag $flag on ${type}:${name}: $@"); - return; - } - return 1; -} - -############################################################################## -# History -############################################################################## - -# Expand a given ACL id to add its name, for readability. Returns the -# original id alone if there was a problem finding the name. -sub format_acl_id { - my ($self, $id) = @_; - my $name = $id; - - my %search = (ac_id => $id); - my $acl_rs = $self->{schema}->resultset('Acl')->find (\%search); - if (defined $acl_rs) { - $name = $acl_rs->ac_name . " ($id)"; - } - - return $name; -} - -# Return the formatted history for a given object or undef on error. -# Currently always returns the complete history, but eventually will need to -# provide some way of showing only recent entries. -sub history { - my ($self) = @_; - my $output = ''; - eval { - my %search = (oh_type => $self->{type}, - oh_name => $self->{name}); - my %attrs = (order_by => 'oh_on'); - my @history = $self->{schema}->resultset('ObjectHistory') - ->search (\%search, \%attrs); - - for my $history_rs (@history) { - $output .= sprintf ("%s %s ", $history_rs->oh_on->ymd, - $history_rs->oh_on->hms); - - my $old = $history_rs->oh_old; - my $new = $history_rs->oh_new; - my $action = $history_rs->oh_action; - my $field = $history_rs->oh_field; - - if ($action eq 'set' and $field eq 'flags') { - if (defined ($new)) { - $output .= "set flag $new"; - } elsif (defined ($old)) { - $output .= "clear flag $old"; - } - } elsif ($action eq 'set' and $field eq 'type_data') { - my $attr = $history_rs->oh_type_field; - if (defined ($old) and defined ($new)) { - $output .= "set attribute $attr to $new (was $old)"; - } elsif (defined ($old)) { - $output .= "remove $old from attribute $attr"; - } elsif (defined ($new)) { - $output .= "add $new to attribute $attr"; - } - } elsif ($action eq 'set' - and ($field eq 'owner' or $field =~ /^acl_/)) { - $old = $self->format_acl_id ($old) if defined ($old); - $new = $self->format_acl_id ($new) if defined ($new); - if (defined ($old) and defined ($new)) { - $output .= "set $field to $new (was $old)"; - } elsif (defined ($new)) { - $output .= "set $field to $new"; - } elsif (defined ($old)) { - $output .= "unset $field (was $old)"; - } - } elsif ($action eq 'set') { - if (defined ($old) and defined ($new)) { - $output .= "set $field to $new (was $old)"; - } elsif (defined ($new)) { - $output .= "set $field to $new"; - } elsif (defined ($old)) { - $output .= "unset $field (was $old)"; - } - } else { - $output .= $action; - } - $output .= sprintf ("\n by %s from %s\n", $history_rs->oh_by, - $history_rs->oh_from); - } - }; - if ($@) { - my $id = $self->{type} . ':' . $self->{name}; - $self->error ("cannot read history for $id: $@"); - return; - } - return $output; -} - -############################################################################## -# Object manipulation -############################################################################## - -# The get methods must always be overridden by the subclass. -sub get { die "Do not instantiate Wallet::Object::Base directly\n"; } - -# 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 { - my ($self, $data, $user, $host, $time) = @_; - my $id = $self->{type} . ':' . $self->{name}; - if ($self->flag_check ('locked')) { - $self->error ("cannot store $id: object is locked"); - return; - } - $self->error ("cannot store $id: object type is immutable"); - return; -} - -# The default show function. This may be adequate for many types; types that -# have additional data should call this method, grab the results, and then add -# their data on to the end. -sub show { - my ($self) = @_; - my $name = $self->{name}; - my $type = $self->{type}; - my @attrs = ([ ob_type => 'Type' ], - [ ob_name => 'Name' ], - [ ob_owner => 'Owner' ], - [ ob_acl_get => 'Get ACL' ], - [ ob_acl_store => 'Store ACL' ], - [ ob_acl_show => 'Show ACL' ], - [ ob_acl_destroy => 'Destroy ACL' ], - [ ob_acl_flags => 'Flags ACL' ], - [ ob_expires => 'Expires' ], - [ ob_comment => 'Comment' ], - [ ob_created_by => 'Created by' ], - [ ob_created_from => 'Created from' ], - [ ob_created_on => 'Created on' ], - [ ob_stored_by => 'Stored by' ], - [ ob_stored_from => 'Stored from' ], - [ ob_stored_on => 'Stored on' ], - [ ob_downloaded_by => 'Downloaded by' ], - [ ob_downloaded_from => 'Downloaded from' ], - [ ob_downloaded_on => 'Downloaded on' ]); - my $fields = join (', ', map { $_->[0] } @attrs); - my @data; - my $object_rs; - eval { - my %search = (ob_type => $type, - ob_name => $name); - $object_rs = $self->{schema}->resultset('Object')->find (\%search); - }; - if ($@) { - $self->error ("cannot retrieve data for ${type}:${name}: $@"); - return; - } - my $output = ''; - my @acls; - - # Format the results. We use a hack to insert the flags before the first - # trace field since they're not a field in the object in their own right. - # The comment should be word-wrapped at 80 columns. - for my $i (0 .. $#attrs) { - my $field = $attrs[$i][0]; - my $fieldtext = $attrs[$i][1]; - next unless my $value = $object_rs->get_column ($field); - - if ($field eq 'ob_comment' && length ($value) > 79 - 17) { - local $Text::Wrap::columns = 80; - local $Text::Wrap::unexpand = 0; - $value = wrap (' ' x 17, ' ' x 17, $value); - $value =~ s/^ {17}//; - } - if ($field eq 'ob_created_by') { - my @flags = $self->flag_list; - if (not @flags and $self->error) { - return; - } - if (@flags) { - $output .= sprintf ("%15s: %s\n", 'Flags', "@flags"); - } - my $attr_output = $self->attr_show; - if (not defined $attr_output) { - return; - } - $output .= $attr_output; - } - if ($field =~ /^ob_(owner|acl_)/) { - my $acl = eval { Wallet::ACL->new ($value, $self->{schema}) }; - if ($acl and not $@) { - $value = $acl->name || $value; - push (@acls, [ $acl, $value ]); - } - } - $output .= sprintf ("%15s: %s\n", $fieldtext, $value); - } - if (@acls) { - my %seen; - @acls = grep { !$seen{$_->[1]}++ } @acls; - for my $acl (@acls) { - $output .= "\n" . $acl->[0]->show; - } - } - return $output; -} - -# The default destroy function only destroys the database metadata. Generally -# subclasses need to override this to destroy whatever additional information -# is stored about this object. -sub destroy { - my ($self, $user, $host, $time) = @_; - $time ||= time; - my $name = $self->{name}; - my $type = $self->{type}; - if ($self->flag_check ('locked')) { - $self->error ("cannot destroy ${type}:${name}: object is locked"); - return; - } - my $guard = $self->{schema}->txn_scope_guard; - eval { - - # Remove any flags that may exist for the record. - my %search = (fl_type => $type, - fl_name => $name); - $self->{schema}->resultset('Flag')->search (\%search)->delete; - - # Remove any object records - %search = (ob_type => $type, - ob_name => $name); - $self->{schema}->resultset('Object')->search (\%search)->delete; - - # And create a new history object for the destroy action. - my %record = (oh_type => $type, - oh_name => $name, - oh_action => 'destroy', - oh_by => $user, - oh_from => $host, - oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{schema}->resultset('ObjectHistory')->create (\%record); - $guard->commit; - }; - if ($@) { - $self->error ("cannot destroy ${type}:${name}: $@"); - return; - } - return 1; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=head1 NAME - -Wallet::Object::Base - Generic parent class for wallet objects - -=for stopwords -DBH HOSTNAME DATETIME ACL backend metadata timestamp Allbery wallet-backend -backend-specific subclasses - -=head1 SYNOPSIS - - package Wallet::Object::Simple; - @ISA = qw(Wallet::Object::Base); - sub get { - my ($self, $user, $host, $time) = @_; - $self->log_action ('get', $user, $host, $time) or return; - return "Some secure data"; - } - -=head1 DESCRIPTION - -Wallet::Object::Base is the generic parent class for wallet objects (data -types that can be stored in the wallet system). It provides default -functions and behavior, including handling generic object settings. All -handlers for objects stored in the wallet should inherit from it. It is -not used directly. - -=head1 PUBLIC CLASS METHODS - -The following methods are called by the rest of the wallet system and -should be implemented by all objects stored in the wallet. They should be -called with the desired wallet object class as the first argument -(generally using the Wallet::Object::Type->new syntax). - -=over 4 - -=item new(TYPE, NAME, DBH) - -Creates a new object with the given object type and name, based on data -already in the database. This method will only succeed if an object of -the given TYPE and NAME is already present in the wallet database. If no -such object exits, throws an exception. Otherwise, returns an object -blessed into the class used for the new() call (so subclasses can leave -this method alone and not override it). - -Takes a Wallet::Schema object, which is stored in the object and used -for any further operations. - -=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME]) - -Similar to new() but instead creates a new entry in the database. This -method will throw an exception if an entry for that type and name already -exists in the database or if creating the database record fails. -Otherwise, a new database entry will be created with that type and name, -no owner, no ACLs, no expiration, no flags, and with created by, from, and -on set to the PRINCIPAL, HOSTNAME, and DATETIME parameters. If DATETIME -isn't given, the current time is used. The database handle is treated as -with new(). - -=back - -=head1 PUBLIC INSTANCE METHODS - -The following methods may be called on instantiated wallet objects. -Normally, the only methods that a subclass will need to override are -get(), store(), show(), and destroy(). - -If the locked flag is set on an object, no actions may be performed on -that object except for the flag methods and show(). All other actions -will be rejected with an error saying the object is locked. - -=over 4 - -=item acl(TYPE [, ACL, PRINCIPAL, HOSTNAME [, DATETIME]]) - -Sets or retrieves a given object ACL as a numeric ACL ID. TYPE must be -one of C, C, C, C, or C, corresponding -to the ACLs kept on an object. If no other arguments are given, returns -the current ACL setting as an ACL ID or undef if that ACL isn't set. If -other arguments are given, change that ACL to ACL and return true on -success and false on failure. Pass in the empty string for ACL to clear -the ACL. The other arguments are used for logging and history and should -indicate the user and host from which the change is made and the time of -the change. - -=item attr(ATTRIBUTE [, VALUES, PRINCIPAL, HOSTNAME [, DATETIME]]) - -Sets or retrieves a given object attribute. Attributes are used to store -backend-specific information for a particular object type and ATTRIBUTE -must be an attribute type known to the underlying object implementation. -The default implementation of this method rejects all attributes as -unknown. - -If no other arguments besides ATTRIBUTE are given, returns the values of -that attribute, if any, as a list. On error, returns the empty list. To -distinguish between an error and an empty return, call error() afterward. -It is guaranteed to return undef unless there was an error. - -If other arguments are given, sets the given ATTRIBUTE values to VALUES, -which must be a reference to an array (even if only one value is being -set). Pass a reference to an empty array to clear the attribute values. -The other arguments are used for logging and history and should indicate -the user and host from which the change is made and the time of the -change. Returns true on success and false on failure. - -=item attr_show() - -Returns a formatted text description of the type-specific attributes of -the object, or undef on error. The default implementation of this method -always returns the empty string. If there are any type-specific -attributes set, this method should return that metadata, formatted as key: -value pairs with the keys right-aligned in the first 15 characters, -followed by a space, a colon, and the value. - -=item comment([COMMENT, PRINCIPAL, HOSTNAME [, DATETIME]]) - -Sets or retrieves the comment associated with an object. If no arguments -are given, returns the current comment or undef if no comment is set. If -arguments are given, change the comment to COMMENT and return true on -success and false on failure. Pass in the empty string for COMMENT to -clear the comment. - -The other arguments are used for logging and history and should indicate -the user and host from which the change is made and the time of the -change. - -=item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) - -Destroys the object by removing all record of it from the database. The -Wallet::Object::Base implementation handles the generic database work, but -any subclass should override this method to do any deletion of files or -entries in external databases and any other database entries and then call -the parent method to handle the generic database cleanup. Returns true on -success and false on failure. The arguments are used for logging and -history and should indicate the user and host from which the change is -made and the time of the change. - -=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. - -For the convenience of child classes, this method can also be called with -one or more error strings. If so, those strings are concatenated -together, trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is -stored as the error. Only child classes should call this method with an -error string. - -=item expires([EXPIRES, PRINCIPAL, HOSTNAME [, DATETIME]]) - -Sets or retrieves the expiration date of an object. If no arguments are -given, returns the current expiration or undef if no expiration is set. -If arguments are given, change the expiration to EXPIRES and return true -on success and false on failure. EXPIRES must be in the format -C, although the time portion may be omitted. Pass in -the empty string for EXPIRES to clear the expiration date. - -The other arguments are used for logging and history and should indicate -the user and host from which the change is made and the time of the -change. - -=item flag_check(FLAG) - -Check whether the given flag is set on an object. Returns true if set, -C<0> if not set, and undef on error. - -=item flag_clear(FLAG, PRINCIPAL, HOSTNAME [, DATETIME]) - -Clears FLAG on an object. Returns true on success and false on failure. -The other arguments are used for logging and history and should indicate -the user and host from which the change is made and the time of the -change. - -=item flag_list() - -List the flags set on an object. If no flags are set, returns the empty -list. On failure, returns an empty list. To distinguish between the -empty response and an error, the caller should call error() after an empty -return. It is guaranteed to return undef if there was no error. - -=item flag_set(FLAG, PRINCIPAL, HOSTNAME [, DATETIME]) - -Sets FLAG on an object. Returns true on success and false on failure. -The other arguments are used for logging and history and should indicate -the user and host from which the change is made and the time of the -change. - -=item get(PRINCIPAL, HOSTNAME [, DATETIME]) - -An object implementation must override this method with one that returns -either the data of the object or undef on some error, using the provided -arguments to update history information. The Wallet::Object::Base -implementation just throws an exception. - -=item history() - -Returns the formatted history for the object. There will be two lines for -each action on the object. The first line has the timestamp of the action -and the action, and the second line gives the user who performed the -action and the host from which they performed it (based on the trace -information passed into the other object methods). - -=item name() - -Returns the object's name. - -=item owner([OWNER, PRINCIPAL, HOSTNAME [, DATETIME]]) - -Sets or retrieves the owner of an object as a numeric ACL ID. If no -arguments are given, returns the current owner ACL ID or undef if none is -set. If arguments are given, change the owner to OWNER and return true on -success and false on failure. Pass in the empty string for OWNER to clear -the owner. The other arguments are used for logging and history and -should indicate the user and host from which the change is made and the -time of the change. - -=item show() - -Returns a formatted text description of the object suitable for human -display, or undef on error. All of the base metadata about the object, -formatted as key: value pairs with the keys aligned in the first 15 -characters followed by a space, a colon, and the value. The attr_show() -method of the object is also called and any formatted output it returns -will be included. If any ACLs or an owner are set, after this data there -is a blank line and then the information for each unique ACL, separated by -blank lines. - -=item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME]) - -Store user-supplied data into the given object. This may not be supported -by all backends (for instance, backends that automatically generate the -data will not support this). The default implementation rejects all -store() calls with an error message saying that the object is immutable. - -=item type() - -Returns the object's type. - -=back - -=head1 UTILITY METHODS - -The following instance methods should not be called externally but are -provided for subclasses to call to implement some generic actions. - -=over 4 - -=item log_action (ACTION, PRINCIPAL, HOSTNAME, DATETIME) - -Updates the history tables and trace information appropriately for ACTION, -which should be either C or C. No other changes are made to -the database, just updates of the history table and trace fields with the -provided data about who performed the action and when. - -This function commits its transaction when complete and therefore should -not be called inside another transaction. Normally it's called as a -separate transaction after the data is successfully stored or retrieved. - -=item log_set (FIELD, OLD, NEW, PRINCIPAL, HOSTNAME, DATETIME) - -Updates the history tables for the change in a setting value for an -object. FIELD should be one of C, C, C, -C, C, C, C, C, or a -value starting with C followed by a space and a type-specific -field name. The last form is the most common form used by a subclass. -OLD is the previous value of the field or undef if the field was unset, -and NEW is the new value of the field or undef if the field should be -unset. - -This function does not commit and does not catch database exceptions. It -should normally be called as part of a larger transaction that implements -the change in the setting. - -=back - -=head1 SEE ALSO - -wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Object/Duo.pm b/perl/Wallet/Object/Duo.pm deleted file mode 100644 index e5773c8..0000000 --- a/perl/Wallet/Object/Duo.pm +++ /dev/null @@ -1,331 +0,0 @@ -# Wallet::Object::Duo -- Duo integration object implementation for the wallet. -# -# Written by Russ Allbery -# Copyright 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Object::Duo; -require 5.006; - -use strict; -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::Base; - -@ISA = qw(Wallet::Object::Base); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.01'; - -############################################################################## -# Core methods -############################################################################## - -# Override attr_show to display the Duo integration key attribute. -sub attr_show { - my ($self) = @_; - my $output = ''; - 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; - } - return sprintf ("%15s: %s\n", 'Duo key', $key); -} - -# Override new to start by creating a Net::Duo::Admin object for subsequent -# calls. -sub new { - my ($class, $type, $name, $schema) = @_; - - # We have to have a Duo integration key file set. - if (not $Wallet::Config::DUO_KEY_FILE) { - die "duo object implementation not configured\n"; - } - my $key_file = $Wallet::Config::DUO_KEY_FILE; - my $agent = $Wallet::Config::DUO_AGENT; - - # Construct the Net::Duo::Admin object. - require Net::Duo::Admin; - my $duo = Net::Duo::Admin->new ( - { - key_file => $key_file, - user_agent => $agent, - } - ); - - # Construct the object. - my $self = $class->SUPER::new ($type, $name, $schema); - $self->{duo} = $duo; - return $self; -} - -# Override create to start by creating a new integration in Duo, and only -# create the entry in the database if that succeeds. Error handling isn't -# 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) = @_; - - # We have to have a Duo integration key file set. - if (not $Wallet::Config::DUO_KEY_FILE) { - die "duo object implementation not configured\n"; - } - my $key_file = $Wallet::Config::DUO_KEY_FILE; - my $agent = $Wallet::Config::DUO_AGENT; - - # Construct the Net::Duo::Admin object. - require Net::Duo::Admin; - my $duo = Net::Duo::Admin->new ( - { - key_file => $key_file, - user_agent => $agent, - } - ); - - # Create the object in Duo. - require Net::Duo::Admin::Integration; - my %data = ( - name => $name, - notes => 'Managed by wallet', - type => $Wallet::Config::DUO_TYPE, - ); - my $integration = Net::Duo::Admin::Integration->create ($duo, \%data); - - # Create the object in wallet. - my @trace = ($creator, $host, $time); - my $self = $class->SUPER::create ($type, $name, $schema, @trace); - $self->{duo} = $duo; - - # Add the integration key to the object metadata. - my $guard = $self->{schema}->txn_scope_guard; - eval { - my %record = ( - du_name => $name, - du_key => $integration->integration_key, - ); - $self->{schema}->resultset ('Duo')->create (\%record); - $guard->commit; - }; - if ($@) { - my $id = $self->{type} . ':' . $self->{name}; - $self->error ("cannot set Duo key for $id: $@"); - return; - } - - # Done. Return the object. - return $self; -} - -# Override destroy to delete the integration out of Duo as well. -sub destroy { - my ($self, $user, $host, $time) = @_; - my $id = $self->{type} . ':' . $self->{name}; - if ($self->flag_check ('locked')) { - $self->error ("cannot destroy $id: object is locked"); - return; - } - my $schema = $self->{schema}; - my $guard = $schema->txn_scope_guard; - eval { - my %search = (du_name => $self->{name}); - my $row = $schema->resultset ('Duo')->find (\%search); - my $key = $row->get_column ('du_key'); - my $int = Net::Duo::Admin::Integration->new ($self->{duo}, $key); - $int->delete; - $row->delete; - $guard->commit; - }; - if ($@) { - $self->error ($@); - return; - } - return $self->SUPER::destroy ($user, $host, $time); -} - -# Our get implementation. Retrieve the integration information from Duo and -# construct the configuration file expected by the Duo 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); - 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 - Duo integration object implementation for wallet - -=head1 SYNOPSIS - - my @name = qw(duo host.example.com); - my @trace = ($user, $host, time); - my $object = Wallet::Object::Duo->create (@name, $schema, @trace); - my $config = $object->get (@trace); - $object->destroy (@trace); - -=head1 DESCRIPTION - -Wallet::Object::Duo is a representation of Duo integrations the wallet. -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. - -Currently, only one configured integration type can be managed by the -wallet, and 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 for details on supported configuration parameters and -information about how to set wallet configuration. - -=head1 METHODS - -This object mostly inherits from Wallet::Object::Base. 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 is a class method and should be called on the Wallet::Object::Duo -class. It creates a new object with the given TYPE and NAME (TYPE is -normally C 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. The new integration's type is controlled by the DUO_TYPE -configuration variable, which defaults to C. See L -for more information. - -If create() fails, it throws an exception. - -=item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) - -Destroys a Duo integration object by removing it from the database and -deleting the integration from Duo. If deleting the Duo integration fails, -destroy() fails. Returns true on success and false on failure. The -caller should call error() to get the error message after a failure. -PRINCIPAL, HOSTNAME, and DATETIME are stored as history information. -PRINCIPAL should be the user who is destroying the object. If DATETIME -isn't given, the current time is used. - -=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 = - skey = - host = - -The C 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. -Currently, only one Duo integration type is supported as well. Further -development should expand the available integration types, possibly as -additional wallet object types. - -=head1 SEE ALSO - -Net::Duo(3), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Object/File.pm b/perl/Wallet/Object/File.pm deleted file mode 100644 index 4afef04..0000000 --- a/perl/Wallet/Object/File.pm +++ /dev/null @@ -1,242 +0,0 @@ -# Wallet::Object::File -- File object implementation for the wallet. -# -# Written by Russ Allbery -# Copyright 2008, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Object::File; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Digest::MD5 qw(md5_hex); -use Wallet::Config (); -use Wallet::Object::Base; - -@ISA = qw(Wallet::Object::Base); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.03'; - -############################################################################## -# File naming -############################################################################## - -# Returns the path into which that file 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::FILE_BUCKET) { - $self->error ('file support not configured'); - return; - } - unless ($name) { - $self->error ('file 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::FILE_BUCKET/$hash"; - unless (-d $parent || mkdir ($parent, 0700)) { - $self->error ("cannot create file bucket $hash: $!"); - return; - } - return "$Wallet::Config::FILE_BUCKET/$hash/$name"; -} - -############################################################################## -# Core methods -############################################################################## - -# Override destroy to delete the file as well. -sub destroy { - my ($self, $user, $host, $time) = @_; - my $id = $self->{type} . ':' . $self->{name}; - my $path = $self->file_path; - if (defined ($path) && -f $path && !unlink ($path)) { - $self->error ("cannot delete $id: $!"); - return; - } - return $self->SUPER::destroy ($user, $host, $time); -} - -# Return the contents of the file. -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 $path = $self->file_path; - return unless $path; - unless (open (FILE, '<', $path)) { - $self->error ("cannot get $id: object has not been stored"); - return; - } - local $/; - my $data = ; - unless (close FILE) { - $self->error ("cannot get $id: $!"); - return; - } - $self->log_action ('get', $user, $host, $time); - return $data; -} - -# Store the file on the wallet server. -sub store { - my ($self, $data, $user, $host, $time) = @_; - $time ||= time; - my $id = $self->{type} . ':' . $self->{name}; - if ($self->flag_check ('locked')) { - $self->error ("cannot store $id: object is locked"); - return; - } - if ($Wallet::Config::FILE_MAX_SIZE) { - my $max = $Wallet::Config::FILE_MAX_SIZE; - if (length ($data) > $max) { - $self->error ("data exceeds maximum of $max bytes"); - return; - } - } - my $path = $self->file_path; - return unless $path; - unless (open (FILE, '>', $path)) { - $self->error ("cannot store $id: $!"); - return; - } - unless (print FILE ($data) and close FILE) { - $self->error ("cannot store $id: $!"); - close FILE; - return; - } - $self->log_action ('store', $user, $host, $time); - return 1; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=head1 NAME - -Wallet::Object::File - File 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::Keytab->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::File is a representation of simple file objects in the -wallet. 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 file object is deleted. A file object must be stored before -it can be retrieved with get. - -To use this object, the configuration option specifying where on the -wallet server to store file objects must be set. See L -for details on this configuration parameter and information about how to -set wallet configuration. - -=head1 METHODS - -This object mostly inherits from Wallet::Object::Base. 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 destroy(PRINCIPAL, HOSTNAME [, DATETIME]) - -Destroys a file object by removing it from the database and deleting the -corresponding file on the wallet server. Returns true on success and -false on failure. The caller should call error() to get the error message -after a failure. PRINCIPAL, HOSTNAME, and DATETIME are stored as history -information. PRINCIPAL should be the user who is destroying the object. -If DATETIME isn't given, the current time is used. - -=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. - -=item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME]) - -Store DATA as the current contents of the file object. Any existing data -will be overwritten. Returns true on success and false on failure. The -caller should call error() to get the error message after a failure. -PRINCIPAL, HOSTNAME, and DATETIME are stored as history information. -PRINCIPAL should be the user who is destroying the object. If DATETIME -isn't given, the current time is used. - -If FILE_MAX_SIZE is set in the wallet configuration, a store() of DATA -larger than that configuration setting will be rejected. - -=back - -=head1 FILES - -=over 4 - -=item FILE_BUCKET// - -Files are stored on the wallet server under the directory FILE_BUCKET as -set in the wallet configuration. is the first two characters of -the hex-encoded MD5 hash of the wallet file object name, used to not put -too many files in the same directory. is the name of the file -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 file object names. -However, due to limitations in the B server usually used to run -B, file 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 file object name. - -=head1 SEE ALSO - -remctld(8), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm deleted file mode 100644 index 24c3302..0000000 --- a/perl/Wallet/Object/Keytab.pm +++ /dev/null @@ -1,513 +0,0 @@ -# Wallet::Object::Keytab -- Keytab object implementation for the wallet. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2009, 2010, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Object::Keytab; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Wallet::Config (); -use Wallet::Object::Base; -use Wallet::Kadmin; - -@ISA = qw(Wallet::Object::Base); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.09'; - -############################################################################## -# Enctype restriction -############################################################################## - -# Set the enctype restrictions for a keytab. Called by attr() and takes a -# reference to the encryption types to set. Returns true on success and false -# on failure, setting the object error if it fails. -sub enctypes_set { - my ($self, $enctypes, $user, $host, $time) = @_; - $time ||= time; - my @trace = ($user, $host, $time); - my $name = $self->{name}; - my %enctypes = map { $_ => 1 } @$enctypes; - my $guard = $self->{schema}->txn_scope_guard; - eval { - # Find all enctypes for the given keytab. - my %search = (ke_name => $name); - my @enctypes = $self->{schema}->resultset('KeytabEnctype') - ->search (\%search); - my (@current); - for my $enctype_rs (@enctypes) { - push (@current, $enctype_rs->ke_enctype); - } - - # Use the existing enctypes and the enctypes we should have to match - # against ones that need to be removed, and note those that already - # exist. - for my $enctype (@current) { - if ($enctypes{$enctype}) { - delete $enctypes{$enctype}; - } else { - %search = (ke_name => $name, - ke_enctype => $enctype); - $self->{schema}->resultset('KeytabEnctype')->find (\%search) - ->delete; - $self->log_set ('type_data enctypes', $enctype, undef, @trace); - } - } - - # When inserting new enctypes, we unfortunately have to do the - # consistency check against the enctypes table ourselves, since SQLite - # doesn't enforce integrity constraints. We do this in sorted order - # to make it easier to test. - for my $enctype (sort keys %enctypes) { - my %search = (en_name => $enctype); - my $enctype_rs = $self->{schema}->resultset('Enctype') - ->find (\%search); - unless (defined $enctype_rs) { - die "unknown encryption type $enctype\n"; - } - my %record = (ke_name => $name, - ke_enctype => $enctype); - $self->{schema}->resultset('KeytabEnctype')->create (\%record); - $self->log_set ('type_data enctypes', undef, $enctype, @trace); - } - $guard->commit; - }; - if ($@) { - $self->error ($@); - return; - } - return 1; -} - -# Return a list of the encryption types current set for a keytab. Called by -# attr() or get(). Returns the empty list on failure or on an empty list of -# enctype restrictions, but sets the object error on failure so the caller -# should use that to determine success. -sub enctypes_list { - my ($self) = @_; - my @enctypes; - eval { - my %search = (ke_name => $self->{name}); - my %attrs = (order_by => 'ke_enctype'); - my @enctypes_rs = $self->{schema}->resultset('KeytabEnctype') - ->search (\%search, \%attrs); - for my $enctype_rs (@enctypes_rs) { - push (@enctypes, $enctype_rs->ke_enctype); - } - }; - if ($@) { - $self->error ($@); - return; - } - return @enctypes; -} - -############################################################################## -# Synchronization -############################################################################## - -# Set a synchronization target or clear the targets if $targets is an -# empty list. Returns true on success and false on failure. -# -# Currently, no synchronization targets are supported, but we preserve the -# ability to clear synchronization and the basic structure of the code so -# that they can be added later. -sub sync_set { - my ($self, $targets, $user, $host, $time) = @_; - $time ||= time; - my @trace = ($user, $host, $time); - if (@$targets > 1) { - $self->error ('only one synchronization target supported'); - return; - } elsif (@$targets) { - my $target = $targets->[0]; - $self->error ("unsupported synchronization target $target"); - return; - } else { - my $guard = $self->{schema}->txn_scope_guard; - eval { - my $name = $self->{name}; - my %search = (ks_name => $name); - my $sync_rs = $self->{schema}->resultset('KeytabSync') - ->find (\%search); - if (defined $sync_rs) { - my $target = $sync_rs->ks_target; - $sync_rs->delete; - $self->log_set ('type_data sync', $target, undef, @trace); - } - $guard->commit; - }; - if ($@) { - $self->error ($@); - return; - } - } - return 1; -} - -# Return a list of the current synchronization targets. Returns the empty -# list on failure or on an empty list of enctype restrictions, but sets -# the object error on failure so the caller should use that to determine -# success. -sub sync_list { - my ($self) = @_; - my @targets; - eval { - my %search = (ks_name => $self->{name}); - my %attrs = (order_by => 'ks_target'); - my @syncs = $self->{schema}->resultset('KeytabSync')->search (\%search, - \%attrs); - for my $sync_rs (@syncs) { - push (@targets, $sync_rs->ks_target); - } - }; - if ($@) { - $self->error ($@); - return; - } - return @targets; -} - -############################################################################## -# Core methods -############################################################################## - -# Override attr to support setting the enctypes and sync attributes. Note -# that the sync attribute has no supported targets at present and hence will -# always return an error, but the code is still here so that it doesn't have -# to be rewritten once a new sync target is added. -sub attr { - my ($self, $attribute, $values, $user, $host, $time) = @_; - $time ||= time; - my @trace = ($user, $host, $time); - my %known = map { $_ => 1 } qw(enctypes sync); - undef $self->{error}; - unless ($known{$attribute}) { - $self->error ("unknown attribute $attribute"); - return; - } - if ($values) { - if ($attribute eq 'enctypes') { - return $self->enctypes_set ($values, $user, $host, $time); - } elsif ($attribute eq 'sync') { - return $self->sync_set ($values, $user, $host, $time); - } - } else { - if ($attribute eq 'enctypes') { - return $self->enctypes_list; - } elsif ($attribute eq 'sync') { - return $self->sync_list; - } - } -} - -# Override attr_show to display the enctypes and sync attributes. -sub attr_show { - my ($self) = @_; - my $output = ''; - my @targets = $self->attr ('sync'); - if (not @targets and $self->error) { - return; - } elsif (@targets) { - $output .= sprintf ("%15s: %s\n", 'Synced with', "@targets"); - } - my @enctypes = $self->attr ('enctypes'); - if (not @enctypes and $self->error) { - return; - } elsif (@enctypes) { - $output .= sprintf ("%15s: %s\n", 'Enctypes', $enctypes[0]); - shift @enctypes; - for my $enctype (@enctypes) { - $output .= (' ' x 17) . $enctype . "\n"; - } - } - return $output; -} - -# Override new to start by creating a handle for the kadmin module we're -# using. -sub new { - my ($class, $type, $name, $schema) = @_; - my $self = { - schema => $schema, - kadmin => undef, - }; - bless $self, $class; - my $kadmin = Wallet::Kadmin->new (); - $self->{kadmin} = $kadmin; - - $self = $class->SUPER::new ($type, $name, $schema); - $self->{kadmin} = $kadmin; - return $self; -} - -# Override create to start by creating the principal in Kerberos and only -# create the entry in the database if that succeeds. Error handling isn't -# 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) = @_; - my $self = { - schema => $schema, - kadmin => undef, - }; - bless $self, $class; - my $kadmin = Wallet::Kadmin->new (); - $self->{kadmin} = $kadmin; - - if (not $kadmin->create ($name)) { - die $kadmin->error, "\n"; - } - $self = $class->SUPER::create ($type, $name, $schema, $creator, $host, - $time); - $self->{kadmin} = $kadmin; - return $self; -} - -# Override destroy to delete the principal out of Kerberos as well. -sub destroy { - my ($self, $user, $host, $time) = @_; - my $id = $self->{type} . ':' . $self->{name}; - if ($self->flag_check ('locked')) { - $self->error ("cannot destroy $id: object is locked"); - return; - } - my $schema = $self->{schema}; - my $guard = $schema->txn_scope_guard; - eval { - my %search = (ks_name => $self->{name}); - my $sync_rs = $schema->resultset('KeytabSync')->search (\%search); - $sync_rs->delete_all if defined $sync_rs; - - %search = (ke_name => $self->{name}); - my $enctype_rs = $schema->resultset('KeytabEnctype')->search (\%search); - $enctype_rs->delete_all if defined $enctype_rs; - - $guard->commit; - }; - if ($@) { - $self->error ($@); - return; - } - my $kadmin = $self->{kadmin}; - if (not $kadmin->destroy ($self->{name})) { - $self->error ($kadmin->error); - return; - } - return $self->SUPER::destroy ($user, $host, $time); -} - -# Our get implementation. Generate a keytab into a temporary file and then -# 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); - } - return $result; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -keytab API KDC keytabs HOSTNAME DATETIME enctypes enctype DBH metadata -unmanaged kadmin Allbery unlinked - -=head1 NAME - -Wallet::Object::Keytab - Keytab object implementation for wallet - -=head1 SYNOPSIS - - my @name = qw(keytab host/shell.example.com); - my @trace = ($user, $host, time); - my $object = Wallet::Object::Keytab->create (@name, $schema, @trace); - my $keytab = $object->get (@trace); - $object->destroy (@trace); - -=head1 DESCRIPTION - -Wallet::Object::Keytab is a representation of Kerberos keytab objects in -the wallet. It implements the wallet object API and provides the -necessary glue to create principals in a Kerberos KDC, create and return -keytabs for those principals, and delete them out of Kerberos when the -wallet object is destroyed. - -A keytab is an on-disk store for the key or keys for a Kerberos principal. -Keytabs are used by services to verify incoming authentication from -clients or by automated processes that need to authenticate to Kerberos. -To create a keytab, the principal has to be created in Kerberos and then a -keytab is generated and stored in a file on disk. - -This implementation generates a new random key (and hence invalidates all -existing keytabs) each time the keytab is retrieved with the get() method. - -To use this object, several configuration parameters must be set. See -L for details on those configuration parameters and -information about how to set wallet configuration. - -=head1 METHODS - -This object mostly inherits from Wallet::Object::Base. 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 attr(ATTRIBUTE [, VALUES, PRINCIPAL, HOSTNAME [, DATETIME]]) - -Sets or retrieves a given object attribute. The following attribute is -supported: - -=over 4 - -=item enctypes - -Restricts the generated keytab to a specific set of encryption types. The -values of this attribute must be enctype strings recognized by Kerberos -(strings like C or C). Encryption -types must also be present in the list of supported enctypes stored in the -database database or the attr() method will reject them. Note that the -salt should not be included; since the salt is irrelevant for keytab keys, -it will always be set to the default by the wallet. - -If this attribute is set, the principal will be restricted to that -specific enctype list when get() is called for that keytab. If it is not -set, the default set in the KDC will be used. - -This attribute is ignored if the C flag is set on a keytab. -Keytabs retrieved with C set will contain all keys present in -the KDC for that Kerberos principal and therefore may contain different -enctypes than those requested by this attribute. - -=item sync - -This attribute is intended to set a list of external systems with which -data about this keytab is synchronized, but there are no supported targets -currently. However, there is support for clearing this attribute or -returning its current value. - -=back - -If no other arguments besides ATTRIBUTE are given, returns the values of -that attribute, if any, as a list. On error, returns the empty list. To -distinguish between an error and an empty return, call error() afterward. -It is guaranteed to return undef unless there was an error. - -If other arguments are given, sets the given ATTRIBUTE values to VALUES, -which must be a reference to an array (even if only one value is being -set). Pass a reference to an empty array to clear the attribute values. -PRINCIPAL, HOSTNAME, and DATETIME are stored as history information. -PRINCIPAL should be the user who is destroying the object. If DATETIME -isn't given, the current time is used. - -=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME]) - -This is a class method and should be called on the Wallet::Object::Keytab -class. It creates a new object with the given TYPE and NAME (TYPE is -normally C 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 keytab object is created, the Kerberos principal designated by -NAME is also created in the Kerberos realm determined from the wallet -configuration. If the principal already exists, create() still succeeds -(so that a previously unmanaged principal can be imported into the -wallet). Otherwise, if the Kerberos principal could not be created, -create() fails. The principal is created with the randomized keys. NAME -must not contain the realm; instead, the KEYTAB_REALM configuration -variable should be set. See L for more information. - -If create() fails, it throws an exception. - -=item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) - -Destroys a keytab object by removing it from the database and deleting the -principal out of Kerberos. If deleting the principal fails, destroy() -fails, but destroy() succeeds if the principal didn't exist when it was -called (so that it can be used to clean up stranded entries). Returns -true on success and false on failure. The caller should call error() to -get the error message after a failure. PRINCIPAL, HOSTNAME, and DATETIME -are stored as history information. PRINCIPAL should be the user who is -destroying the object. If DATETIME isn't given, the current time is used. - -=item get(PRINCIPAL, HOSTNAME [, DATETIME]) - -Retrieves a keytab for this object and returns the keytab data or undef on -error. The caller should call error() to get the error message if get() -returns undef. The keytab is created with new randomized keys, -invalidating any existing keytabs for that principal, unless the -unchanging flag is set on the object. 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 KEYTAB_TMP/keytab. - -The keytab is created in this file and then read into memory. KEYTAB_TMP -is set in the wallet configuration, and is the process ID of the -current process. The file is unlinked after being read. - -=back - -=head1 LIMITATIONS - -Only one Kerberos realm is supported for a given wallet implementation and -all keytab objects stored must be in that realm. Keytab names in the -wallet database do not have realm information. - -=head1 SEE ALSO - -kadmin(8), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Object/WAKeyring.pm b/perl/Wallet/Object/WAKeyring.pm deleted file mode 100644 index f8bd0f7..0000000 --- a/perl/Wallet/Object/WAKeyring.pm +++ /dev/null @@ -1,370 +0,0 @@ -# Wallet::Object::WAKeyring -- WebAuth keyring object implementation. -# -# Written by Russ Allbery -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Object::WAKeyring; -require 5.006; - -use strict; -use vars qw(@ISA $VERSION); - -use Digest::MD5 qw(md5_hex); -use Fcntl qw(LOCK_EX); -use Wallet::Config (); -use Wallet::Object::Base; -use WebAuth 3.06 qw(WA_KEY_AES WA_AES_128); - -@ISA = qw(Wallet::Object::Base); - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.01'; - -############################################################################## -# File naming -############################################################################## - -# Returns the path into which that keyring 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::WAKEYRING_BUCKET) { - $self->error ('WebAuth keyring support not configured'); - return; - } - unless ($name) { - $self->error ('WebAuth keyring 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::WAKEYRING_BUCKET/$hash"; - unless (-d $parent || mkdir ($parent, 0700)) { - $self->error ("cannot create keyring bucket $hash: $!"); - return; - } - return "$Wallet::Config::WAKEYRING_BUCKET/$hash/$name"; -} - -############################################################################## -# Core methods -############################################################################## - -# Override destroy to delete the file as well. -sub destroy { - my ($self, $user, $host, $time) = @_; - my $id = $self->{type} . ':' . $self->{name}; - my $path = $self->file_path; - if (defined ($path) && -f $path && !unlink ($path)) { - $self->error ("cannot delete $id: $!"); - return; - } - return $self->SUPER::destroy ($user, $host, $time); -} - -# Update the keyring if needed, and then return the contents of the current -# keyring. -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 $path = $self->file_path; - return unless defined $path; - - # Create a WebAuth context and ensure we can load the relevant modules. - my $wa = eval { WebAuth->new }; - if ($@) { - $self->error ("cannot initialize WebAuth: $@"); - return; - } - - # Check if the keyring already exists. If not, create a new one with a - # single key that's immediately valid and two more that will become valid - # in the future. - # - # If the keyring does already exist, get a lock on the file. At the end - # of this process, we'll do an atomic update and then drop our lock. - # - # FIXME: There are probably better ways to do this. There are some race - # conditions here, particularly with new keyrings. - unless (open (FILE, '+<', $path)) { - my $data; - eval { - my $key = $wa->key_create (WA_KEY_AES, WA_AES_128); - my $ring = $wa->keyring_new ($key); - $key = $wa->key_create (WA_KEY_AES, WA_AES_128); - my $valid = time + $Wallet::Config::WAKEYRING_REKEY_INTERVAL; - $ring->add (time, $valid, $key); - $key = $wa->key_create (WA_KEY_AES, WA_AES_128); - $valid += $Wallet::Config::WAKEYRING_REKEY_INTERVAL; - $ring->add (time, $valid, $key); - $data = $ring->encode; - $ring->write ($path); - }; - if ($@) { - $self->error ("cannot create new keyring"); - return; - }; - $self->log_action ('get', $user, $host, $time); - return $data; - } - unless (flock (FILE, LOCK_EX)) { - $self->error ("cannot get lock on keyring: $!"); - return; - } - - # Read the keyring. - my $ring = eval { WebAuth::Keyring->read ($wa, $path) }; - if ($@) { - $self->error ("cannot read keyring: $@"); - return; - } - - # If the most recent key has a valid-after older than now + - # WAKEYRING_REKEY_INTERVAL, we generate a new key with a valid_after of - # now + 2 * WAKEYRING_REKEY_INTERVAL. - my ($count, $newest) = (0, 0); - for my $entry ($ring->entries) { - $count++; - if ($entry->valid_after > $newest) { - $newest = $entry->valid_after; - } - } - eval { - if ($newest <= time + $Wallet::Config::WAKEYRING_REKEY_INTERVAL) { - my $valid = time + 2 * $Wallet::Config::WAKEYRING_REKEY_INTERVAL; - my $key = $wa->key_create (WA_KEY_AES, WA_AES_128); - $ring->add (time, $valid, $key); - } - }; - if ($@) { - $self->error ("cannot add new key: $@"); - return; - } - - # If there are any keys older than the purge interval, remove them, but - # only do so if we have more than three keys (the one that's currently - # active, the one that's going to come active in the rekey interval, and - # the one that's going to come active after that. - # - # FIXME: Be sure that we don't remove the last currently-valid key. - my $cutoff = time - $Wallet::Config::WAKEYRING_PURGE_INTERVAL; - my $i = 0; - my @purge; - if ($count > 3) { - for my $entry ($ring->entries) { - if ($entry->creation < $cutoff) { - push (@purge, $i); - } - $i++; - } - } - if (@purge && $count - @purge >= 3) { - eval { - for my $key (reverse @purge) { - $ring->remove ($key); - } - }; - if ($@) { - $self->error ("cannot remove old keys: $@"); - return; - } - } - - # Encode the key. - my $data = eval { $ring->encode }; - if ($@) { - $self->error ("cannot encode keyring: $@"); - return; - } - - # Write the new keyring to the path. - eval { $ring->write ($path) }; - if ($@) { - $self->error ("cannot store new keyring: $@"); - return; - } - close FILE; - $self->log_action ('get', $user, $host, $time); - return $data; -} - -# Store the file on the wallet server. -# -# FIXME: Check the provided keyring for validity. -sub store { - my ($self, $data, $user, $host, $time) = @_; - $time ||= time; - my $id = $self->{type} . ':' . $self->{name}; - if ($self->flag_check ('locked')) { - $self->error ("cannot store $id: object is locked"); - return; - } - if ($Wallet::Config::FILE_MAX_SIZE) { - my $max = $Wallet::Config::FILE_MAX_SIZE; - if (length ($data) > $max) { - $self->error ("data exceeds maximum of $max bytes"); - return; - } - } - my $path = $self->file_path; - return unless $path; - unless (open (FILE, '>', $path)) { - $self->error ("cannot store $id: $!"); - return; - } - unless (print FILE ($data) and close FILE) { - $self->error ("cannot store $id: $!"); - close FILE; - return; - } - $self->log_action ('store', $user, $host, $time); - return 1; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -WebAuth keyring keyrings API HOSTNAME DATETIME keytab AES rekey Allbery - -=head1 NAME - -Wallet::Object::WAKeyring - WebAuth keyring object implementation for wallet - -=head1 SYNOPSIS - - my ($user, $host, $time); - my @name = qw(wa-keyring www.stanford.edu); - my @trace = ($user, $host, $time); - my $object = Wallet::Object::WAKeyring->create (@name, $schema, $trace); - my $keyring = $object->get (@trace); - unless ($object->store ($keyring)) { - die $object->error, "\n"; - } - $object->destroy (@trace); - -=head1 DESCRIPTION - -Wallet::Object::WAKeyring is a representation of a WebAuth keyring in the -wallet. It implements the wallet object API and provides the necessary -glue to store a keyring on the wallet server, retrieve it, update the -keyring with new keys automatically as needed, purge old keys -automatically, and delete the keyring when the object is deleted. - -WebAuth keyrings hold one or more keys. Each key has a creation time and -a validity time. The key cannot be used until its validity time has been -reached. This permits safe key rotation: a new key is added with a -validity time in the future, and then the keyring is updated everywhere it -needs to be before that validity time is reached. This wallet object -automatically handles key rotation by adding keys with validity dates in -the future and removing keys with creation dates substantially in the -past. - -To use this object, various configuration options specifying where to -store the keyrings and how to handle key rotation must be set. See -Wallet::Config for details on these configuration parameters and -information about how to set wallet configuration. - -=head1 METHODS - -This object mostly inherits from Wallet::Object::Base. 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 destroy(PRINCIPAL, HOSTNAME [, DATETIME]) - -Destroys a WebAuth keyring object by removing it from the database and -deleting the corresponding file on the wallet server. Returns true on -success and false on failure. The caller should call error() to get the -error message after a failure. PRINCIPAL, HOSTNAME, and DATETIME are -stored as history information. PRINCIPAL should be the user who is -destroying the object. If DATETIME isn't given, the current time is used. - -=item get(PRINCIPAL, HOSTNAME [, DATETIME]) - -Either creates a new WebAuth keyring (if this object has not bee stored or -retrieved before) or does any necessary periodic maintenance on the -keyring and then returns its data. 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. - -If this object has never been stored or retrieved before, a new keyring -will be created with three 128-bit AES keys: one that is immediately -valid, one that will become valid after the rekey interval, and one that -will become valid after twice the rekey interval. - -If keyring data for this object already exists, the creation and validity -dates for each key in the keyring will be examined. If the key with the -validity date the farthest into the future has a date that's less than or -equal to the current time plus the rekey interval, a new 128-bit AES key -will be added to the keyring with a validity time of twice the rekey -interval in the future. Finally, all keys with a creation date older than -the configured purge interval will be removed provided that the keyring -has at least three keys - -=item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME]) - -Store DATA as the current contents of the WebAuth keyring object. Note -that this is not checked for validity, just assumed to be a valid keyring. -Any existing data will be overwritten. Returns true on success and false -on failure. The caller should call error() to get the error message after -a failure. PRINCIPAL, HOSTNAME, and DATETIME are stored as history -information. PRINCIPAL should be the user who is destroying the object. -If DATETIME isn't given, the current time is used. - -If FILE_MAX_SIZE is set in the wallet configuration, a store() of DATA -larger than that configuration setting will be rejected. - -=back - -=head1 FILES - -=over 4 - -=item WAKEYRING_BUCKET// - -WebAuth keyrings are stored on the wallet server under the directory -WAKEYRING_BUCKET as set in the wallet configuration. is the first -two characters of the hex-encoded MD5 hash of the wallet file object name, -used to not put too many files in the same directory. is the name -of the file object with all characters other than alphanumerics, -underscores, and dashes replaced by "%" and the hex code of the character. - -=back - -=head1 SEE ALSO - -Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8), WebAuth(3) - -This module is part of the wallet system. The current version is available -from . - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Policy/Stanford.pm b/perl/Wallet/Policy/Stanford.pm deleted file mode 100644 index 5ac29e0..0000000 --- a/perl/Wallet/Policy/Stanford.pm +++ /dev/null @@ -1,422 +0,0 @@ -# Wallet::Policy::Stanford -- Stanford's wallet naming and ownership policy. -# -# Written by Russ Allbery -# Copyright 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Policy::Stanford; - -use 5.008; -use strict; -use warnings; - -use base qw(Exporter); - -# Declare variables that should be set in BEGIN for robustness. -our (@EXPORT_OK, $VERSION); - -# Set $VERSION and everything export-related in a BEGIN block for robustness -# 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); -} - -############################################################################## -# Configuration -############################################################################## - -# These variables are all declared as globals so that they can be overridden -# from wallet.conf if desirable. - -# The domain to append to hostnames to fully-qualify them. -our $DOMAIN = 'stanford.edu'; - -# Groups for file object naming, each mapped to the ACL to use for -# non-host-based objects owned by that group. This default is entirely -# Stanford-specific, even more so than the rest of this file. -our %ACL_FOR_GROUP = ( - 'its-apps' => 'group/its-app-support', - 'its-crc-sg' => 'group/crcsg', - 'its-idg' => 'group/its-idg', - 'its-rc' => 'group/its-rc', - 'its-sa-core' => 'group/its-sa-core', -); - -# Legacy group names for older file objects. -our @GROUPS_LEGACY = qw(apps crcsg gsb idg sysadmin sulair vast); - -# File object types. Each type can have one or more parameters: whether it is -# host-based (host), whether it takes a qualifier after the host or service -# (extra), and whether that qualifier is mandatory (need_extra). -our %FILE_TYPE = ( - config => { extra => 1, need_extra => 1 }, - db => { extra => 1, need_extra => 1 }, - 'gpg-key' => { }, - htpasswd => { host => 1, extra => 1, need_extra => 1 }, - password => { extra => 1, need_extra => 1 }, - 'password-ipmi' => { host => 1 }, - 'password-root' => { host => 1 }, - 'password-tivoli' => { host => 1 }, - properties => { extra => 1 }, - 'ssh-dsa' => { host => 1 }, - 'ssh-rsa' => { host => 1 }, - 'ssl-key' => { host => 1, extra => 1 }, - 'ssl-keypair' => { host => 1, extra => 1 }, - 'ssl-keystore' => { extra => 1 }, - 'ssl-pkcs12' => { extra => 1 }, - 'tivoli-key' => { host => 1 }, -); - -# 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); - -# File object types for the legacy file object naming scheme. -our @FILE_TYPES_LEGACY = qw(config db gpg-key htpasswd password properties - ssh-rsa ssh-dsa ssl-key ssl-keystore ssl-pkcs12 tivoli-key); - -# Host-based Kerberos principal prefixes. -our @KEYTAB_HOST = qw(HTTP afpserver cifs ftp host imap ipp ldap lpr nfs pop - postgres sieve smtp webauth xmpp); - -# The Kerberos realm, used when forming principals for krb5 ACLs. -our $REALM = 'stanford.edu'; - -# A file listing principal names that should be required to use a root -# instance to autocreate any objects. -our $ROOT_REQUIRED = '/etc/remctl/acl/its-idg'; - -############################################################################## -# Implementation -############################################################################## - -# Retrieve an existing ACL and return its members as a list. -# -# $name - Name of the ACL to retrieve -# -# Returns: Members of the ACL as a list of pairs -# The empty list on any failure to retrieve the ACL -sub _acl_members { - my ($name) = @_; - my $schema = eval { Wallet::Schema->connect }; - return if (!$schema || $@); - my $acl = eval { Wallet::ACL->new ($name, $schema) }; - return if (!$acl || $@); - return $acl->list; -} - -# Retrieve an existing ACL and check whether it contains a netdb-root member. -# This is used to check if a default ACL is already present with a netdb-root -# member so that we can return a default owner that matches. We only ever -# increase the ACL from netdb to netdb-root, never degrade it, so this doesn't -# pose a security problem. -# -# On any failure, just return an empty ACL to use the default. -sub _acl_has_netdb_root { - my ($name) = @_; - for my $line (_acl_members($name)) { - return 1 if $line->[0] eq 'netdb-root'; - } - return; -} - -# Map a file object name to a hostname for the legacy file object naming -# scheme and return it. Returns undef if this file object name doesn't map to -# a hostname. -sub _host_for_file_legacy { - my ($name) = @_; - my %allowed = map { $_ => 1 } @FILE_HOST_LEGACY; - my $allowed_regex = '(?:' . join ('|', sort keys %allowed) . ')'; - if ($name !~ /^[^-]+-(.*)-$allowed_regex(?:-.*)?$/) { - return; - } - my $host = $1; - if ($host !~ /\./) { - $host .= q{.} . $DOMAIN; - } - 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 { - my ($name) = @_; - - # If $name doesn't contain /, defer to the legacy naming scheme. - if ($name !~ m{ / }xms) { - return _host_for_file_legacy($name); - } - - # Parse the name and check whether this is a host-based object. - my ($type, $host) = split('/', $name); - return if !$FILE_TYPE{$type}{host}; - return $host; -} - -# Map a keytab object name to a hostname and return it. Returns undef if this -# keytab principal name doesn't map to a hostname. -sub _host_for_keytab { - my ($name) = @_; - my %allowed = map { $_ => 1 } @KEYTAB_HOST; - return unless $name =~ m,/,; - my ($service, $host) = split ('/', $name, 2); - return unless $allowed{$service}; - if ($host !~ /\./) { - $host .= q{.} . $DOMAIN; - } - return $host; -} - -# 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 -# using root instances by default. -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, - ); - - # 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 ($host) { - my $acl_name = "host/$host"; - my @acl; - if ($ENV{REMOTE_USER} =~ m,/root, - || _acl_has_netdb_root ($acl_name)) { - @acl = ([ 'netdb-root', $host ], - [ 'krb5', "host/$host\@$REALM" ]); - } else { - @acl = ([ 'netdb', $host ], - [ 'krb5', "host/$host\@$REALM" ]); - } - return ($acl_name, @acl); - } - } - - # We have no open if this is not a file object. - return if $type ne 'file'; - - # Parse the name of the file object only far enough to get type and group - # (if there is a group). - my ($file_type, $group) = split('/', $name); - - # Host-based file objects should be caught by the above. We certainly - # can't do anything about them here. - return if $FILE_TYPE{$file_type}{host}; - - # If we have a mapping for this group, retrieve the ACL contents. We - # would like to just return the ACL name, but wallet currently requires we - # return the whole ACL. - my $acl = $ACL_FOR_GROUP{$group}; - return if !defined($acl); - my @members = _acl_members($acl); - return if @members == 0; - return ($acl, @members); -} - -# Enforce a naming policy. Host-based keytabs must have fully-qualified -# 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 -# creation using a */root instance. -sub verify_name { - my ($type, $name, $user) = @_; - my %staff; - if (open (STAFF, '<', $ROOT_REQUIRED)) { - local $_; - while () { - s/^\s+//; - s/\s+$//; - next if m,/root\@,; - $staff{$_} = 1; - } - close STAFF; - } - - # Check for a staff member not using their root instance. - if (defined ($user) && $staff{$user}) { - return 'use a */root instance for wallet object creation'; - } - - # Check keytab naming conventions. - if ($type eq 'keytab') { - my %host = map { $_ => 1 } @KEYTAB_HOST; - if ($name !~ m,^[a-zA-Z0-9_-]+/[a-z0-9.-]+$,) { - return "invalid principal name $name"; - } - my ($principal, $instance) - = ($name =~ m,^([a-zA-Z0-9_-]+)/([a-z0-9.-]+)$,); - unless (defined ($principal) && defined ($instance)) { - return "invalid principal name $name"; - } - if ($host{$principal} and $principal ne 'http') { - if ($instance !~ /^[a-z0-9-]+\.[a-z0-9.-]+$/) { - return "host name $instance is not fully qualified"; - } - } elsif ($principal eq 'afs') { - if ($instance !~ /^[a-z0-9-]+\.[a-z0-9.-]+$/) { - return "AFS cell name $instance is not fully qualified"; - } - } elsif ($principal eq 'service') { - if ($instance !~ /^[a-z0-9-]+$/) { - return "invalid service principal name $name"; - } - } elsif ($instance eq 'cgi') { - if ($principal !~ /^[a-z][a-z0-9]{1,7}$/ - and $principal !~ /^(class|dept|group)-[a-z0-9_-]+$/) { - return "invalid CGI principal name $name"; - } - } elsif ($instance eq 'cron') { - if ($principal !~ /^[a-z][a-z0-9]{1,7}$/ - and $principal !~ /^(class|dept|group)-[a-z0-9_-]+$/) { - return "invalid cron principal name $name"; - } - } else { - return "unknown principal type $principal"; - } - } - - # Check file object naming conventions. - if ($type eq 'file') { - 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 ($FILE_TYPE{$type} && $FILE_TYPE{$type}{host}) { - my ($host, $extra) = @name; - if ($host !~ m{ [.] }xms) { - return "host name $host is not fully qualified"; - } - if (defined($extra) && !$FILE_TYPE{$type}{extra}) { - return "extraneous component at end of $name"; - } - if (!defined($extra) && $FILE_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 (!$FILE_TYPE{$type}) { - return "unknown type $type"; - } - if ($FILE_TYPE{$type}{host}) { - return "bad name for host-based file type $type"; - } - - # Check the extra data. - if (defined($extra) && !$FILE_TYPE{$type}{extra}) { - return "extraneous component at end of $name"; - } - if (!defined($extra) && $FILE_TYPE{$type}{need_extra}) { - return "missing component in $name"; - } - return; - } else { - # Legacy naming scheme. - my %groups = map { $_ => 1 } @GROUPS_LEGACY; - my %types = map { $_ => 1 } @FILE_TYPES_LEGACY; - if ($name !~ m,^[a-zA-Z0-9_.-]+$,) { - return "invalid file object $name"; - } - my $group_regex = '(?:' . join ('|', sort keys %groups) . ')'; - my $type_regex = '(?:' . join ('|', sort keys %types) . ')'; - if ($name !~ /^$group_regex-/) { - return "no recognized owning group in $name"; - } elsif ($name !~ /^$group_regex-.*-$type_regex(-.*)?$/) { - return "invalid file object name $name"; - } - } - } - - # Success. - return; -} - -1; - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -Allbery - -=head1 NAME - -Wallet::Policy::Stanford - Stanford's wallet naming and ownership policy - -=head1 SYNOPSIS - - use Wallet::Policy::Stanford; - my ($type, $name, $user) = @_; - - my $error = valid_name($type, $name, $user); - my ($name, @acl) = default_owner($type, $name); - -=head1 DESCRIPTION - -Wallet::Policy::Stanford implements Stanford's wallet naming and ownership -policy as described in F in the wallet distribution. -It is primarily intended as an example for other sites, but it is used at -Stanford to implement that policy. - -This module provides the default_owner() and verify_name() functions that -are part of the wallet configuration interface (as documented in -L). They can be imported directly into a wallet -configuration file from this module or wrapped to apply additional rules. - -=head1 SEE ALSO - -Wallet::Config(3) - -The L -implemented by this module. - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm deleted file mode 100644 index 1085546..0000000 --- a/perl/Wallet/Report.pm +++ /dev/null @@ -1,680 +0,0 @@ -# Wallet::Report -- Wallet system reporting interface. -# -# Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Report; -require 5.006; - -use strict; -use vars qw($VERSION); - -use Wallet::ACL; -use Wallet::Schema; - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.04'; - -############################################################################## -# Constructor, destructor, and accessors -############################################################################## - -# Create a new wallet report object. Opens a connection to the database that -# will be used for all of the wallet configuration information. Throw an -# exception if anything goes wrong. -sub new { - my ($class) = @_; - my $schema = Wallet::Schema->connect; - my $self = { schema => $schema }; - bless ($self, $class); - return $self; -} - -# Returns the database handle (used mostly for testing). -sub dbh { - my ($self) = @_; - return $self->{schema}->storage->dbh; -} - -# Returns the DBIx::Class-based database schema object. -sub schema { - my ($self) = @_; - return $self->{schema}; -} - -# Set or return the error stashed in the object. -sub error { - my ($self, @error) = @_; - if (@error) { - my $error = join ('', @error); - chomp $error; - 1 while ($error =~ s/ at \S+ line \d+\.?\z//); - $self->{error} = $error; - } - return $self->{error}; -} - -# Disconnect the database handle on object destruction to avoid warnings. -sub DESTROY { - my ($self) = @_; - $self->{schema}->storage->dbh->disconnect; -} - -############################################################################## -# Object reports -############################################################################## - -# Return the SQL statement to find every object in the database. -sub objects_all { - my ($self) = @_; - my @objects; - - my %search = (); - my %options = (order_by => [ qw/ob_type ob_name/ ], - select => [ qw/ob_type ob_name/ ]); - - return (\%search, \%options); -} - -# Return the SQL statement and the search field required to find all objects -# matching a specific type. -sub objects_type { - my ($self, $type) = @_; - my @objects; - - my %search = (ob_type => $type); - my %options = (order_by => [ qw/ob_type ob_name/ ], - select => [ qw/ob_type ob_name/ ]); - - return (\%search, \%options); -} - -# Return the SQL statement and search field required to find all objects owned -# by a given ACL. If the requested owner is null, we ignore this and do a -# different search for IS NULL. If the requested owner does not actually -# match any ACLs, set an error and return undef. -sub objects_owner { - my ($self, $owner) = @_; - my @objects; - - my %search; - my %options = (order_by => [ qw/ob_type ob_name/ ], - select => [ qw/ob_type ob_name/ ]); - - if (lc ($owner) eq 'null') { - %search = (ob_owner => undef); - } else { - my $acl = eval { Wallet::ACL->new ($owner, $self->{schema}) }; - return unless $acl; - %search = (ob_owner => $acl->id); - } - - return (\%search, \%options); -} - -# Return the SQL statement and search field required to find all objects that -# have a specific flag set. -sub objects_flag { - my ($self, $flag) = @_; - my @objects; - - my %search = ('flags.fl_flag' => $flag); - my %options = (join => 'flags', - prefetch => 'flags', - order_by => [ qw/ob_type ob_name/ ], - select => [ qw/ob_type ob_name/ ]); - - return (\%search, \%options); -} - -# Return the SQL statement and search field required to find all objects that -# a given ACL has any permissions on. This expands from objects_owner in that -# it will also match any records that have the ACL set for get, store, show, -# destroy, or flags. If the requested owner does not actually match any ACLs, -# set an error and return the empty string. -sub objects_acl { - my ($self, $search) = @_; - my @objects; - - my $schema = $self->{schema}; - my $acl = eval { Wallet::ACL->new ($search, $schema) }; - return unless $acl; - - my @search = ({ ob_owner => $acl->id }, - { ob_acl_get => $acl->id }, - { ob_acl_store => $acl->id }, - { ob_acl_show => $acl->id }, - { ob_acl_destroy => $acl->id }, - { ob_acl_flags => $acl->id }); - my %options = (order_by => [ qw/ob_type ob_name/ ], - select => [ qw/ob_type ob_name/ ]); - - return (\@search, \%options); -} - -# Return the SQL statement to find all objects that have been created but -# have never been retrieved (via get). -sub objects_unused { - my ($self) = @_; - my @objects; - - my %search = (ob_downloaded_on => undef); - 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 -# 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 { - my ($self, $type, @args) = @_; - undef $self->{error}; - - # Get the search and options array refs from specific functions. - my ($search_ref, $options_ref); - if (!defined $type || $type eq '') { - ($search_ref, $options_ref) = $self->objects_all; - } else { - if ($type ne 'unused' && @args != 1) { - $self->error ("object searches require one argument to search"); - } elsif ($type eq 'type') { - ($search_ref, $options_ref) = $self->objects_type (@args); - } elsif ($type eq 'owner') { - ($search_ref, $options_ref) = $self->objects_owner (@args); - } elsif ($type eq 'flag') { - ($search_ref, $options_ref) = $self->objects_flag (@args); - } elsif ($type eq 'acl') { - ($search_ref, $options_ref) = $self->objects_acl (@args); - } elsif ($type eq 'unused') { - ($search_ref, $options_ref) = $self->objects_unused (@args); - } else { - $self->error ("do not know search type: $type"); - } - return unless $search_ref; - } - - # Perform the search and return on any errors. - my @objects; - my $schema = $self->{schema}; - eval { - my @objects_rs = $schema->resultset('Object')->search ($search_ref, - $options_ref); - for my $object_rs (@objects_rs) { - push (@objects, [ $object_rs->ob_type, $object_rs->ob_name ]); - } - }; - if ($@) { - $self->error ("cannot list objects: $@"); - return; - } - - return @objects; -} - -############################################################################## -# ACL reports -############################################################################## - -# Returns the SQL statement required to find and return all ACLs in the -# database. -sub acls_all { - my ($self) = @_; - my @acls; - - my $schema = $self->{schema}; - my %search = (); - my %options = (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 SQL statement required to find all empty ACLs in the database. -sub acls_empty { - my ($self) = @_; - my @acls; - - my $schema = $self->{schema}; - my %search = (ae_id => undef); - 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 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. -sub acls_entry { - my ($self, $type, $identifier) = @_; - my @acls; - - my $schema = $self->{schema}; - my %search = (ae_scheme => $type, - ae_identifier => { like => '%'.$identifier.'%' }); - my %options = (join => 'acl_entries', - prefetch => 'acl_entries', - order_by => [ qw/ac_id/ ], - select => [ qw/ac_id ac_name/ ], - distinct => 1); - - 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 SQL statement required to find unused ACLs. -sub acls_unused { - my ($self) = @_; - my @acls; - - my $schema = $self->{schema}; - my %search = ( - #'acls_owner.ob_owner' => undef, - #'acls_get.ob_owner' => undef, - #'acls_store.ob_owner' => undef, - #'acls_show.ob_owner' => undef, - #'acls_destroy.ob_owner' => undef, - #'acls_flags.ob_owner' => undef, - ); - my %options = (#join => [ qw/acls_owner acls_get acls_store acls_show acls_destroy acls_flags/ ], - order_by => [ qw/ac_id/ ], - select => [ qw/ac_id ac_name/ ]); - - eval { - my @acls_rs = $schema->resultset('Acl')->search (\%search, \%options); - - # FIXME: Almost certainly a way of doing this with the search itself. - for my $acl_rs (@acls_rs) { - next if $acl_rs->acls_owner->first; - next if $acl_rs->acls_get->first; - next if $acl_rs->acls_store->first; - next if $acl_rs->acls_show->first; - next if $acl_rs->acls_destroy->first; - next if $acl_rs->acls_flags->first; - push (@acls, [ $acl_rs->ac_id, $acl_rs->ac_name ]); - } - }; - - if ($@) { - $self->error ("cannot list ACLs: $@"); - return; - } - return (@acls); -} - -# Obtain a textual representation of the membership of an ACL, returning undef -# on error and setting the internal error. -sub acl_membership { - my ($self, $id) = @_; - my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } - my @members = map { "$_->[0] $_->[1]" } $acl->list; - if (!@members && $acl->error) { - $self->error ($acl->error); - return; - } - return join ("\n", @members); -} - -# Duplicate ACL detection unfortunately needs to do something more complex -# than just return a SQL statement, so it's handled differently than other -# reports. All the work is done here and the results returned as a list of -# sets of duplicates. -sub acls_duplicate { - my ($self) = @_; - my @acls = sort map { $_->[1] } $self->acls; - return if (!@acls && $self->{error}); - return if @acls < 2; - my %result; - for my $i (0 .. ($#acls - 1)) { - my $members = $self->acl_membership ($acls[$i]); - return unless defined $members; - for my $j (($i + 1) .. $#acls) { - my $check = $self->acl_membership ($acls[$j]); - return unless defined $check; - if ($check eq $members) { - $result{$acls[$i]} ||= []; - push (@{ $result{$acls[$i]} }, $acls[$j]); - } - } - } - my @result; - for my $acl (sort keys %result) { - push (@result, [ $acl, sort @{ $result{$acl} } ]); - } - return @result; -} - -# Returns a list of all ACLs stored in the wallet database as a list of pairs -# of ACL IDs and ACL names, possibly limited by some criteria. 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. -sub acls { - my ($self, $type, @args) = @_; - undef $self->{error}; - - # Find the ACLs for any given search. - my @acls; - if (!defined $type || $type eq '') { - @acls = $self->acls_all; - } else { - if ($type eq 'duplicate') { - return $self->acls_duplicate; - } elsif ($type eq 'entry') { - if (@args == 0) { - $self->error ('ACL searches require an argument to search'); - return; - } else { - @acls = $self->acls_entry (@args); - } - } elsif ($type eq 'empty') { - @acls = $self->acls_empty; - } elsif ($type eq 'unused') { - @acls = $self->acls_unused; - } else { - $self->error ("unknown search type: $type"); - return; - } - } - return @acls; -} - -# Returns all ACL entries contained in owner ACLs for matching objects. -# Objects are specified by type and name, which may be SQL wildcard -# expressions. Each list member will be a pair of ACL scheme and ACL -# identifier, with duplicates removed. On error and for no matching entries, -# the empty list will be returned. To distinguish between an empty return and -# an error, call error(), which will return undef if there was no error. -sub owners { - my ($self, $type, $name) = @_; - undef $self->{error}; - my $schema = $self->{schema}; - - my @owners; - eval { - my %search = ( - 'acls_owner.ob_type' => { like => $type }, - 'acls_owner.ob_name' => { like => $name }); - my %options = ( - join => { 'acls' => 'acls_owner' }, - order_by => [ qw/ae_scheme ae_identifier/ ], - distinct => 1, - ); - - my @acls_rs = $schema->resultset('AclEntry')->search (\%search, - \%options); - for my $acl_rs (@acls_rs) { - my $scheme = $acl_rs->ae_scheme; - my $identifier = $acl_rs->ae_identifier; - push (@owners, [ $scheme, $identifier ]); - } - }; - if ($@) { - $self->error ("cannot report on owners: $@"); - return; - } - return @owners; -} - -############################################################################## -# Auditing -############################################################################## - -# Audit the database for violations of local policy. Returns a list of -# objects (as type and name pairs) or a list of ACLs (as ID and name pairs). -# On error and for no matching entries, the empty list will be returned. To -# distinguish between an empty return and an error, call error(), which will -# return undef if there was no error. -sub audit { - my ($self, $type, $audit) = @_; - undef $self->{error}; - unless (defined ($type) and defined ($audit)) { - $self->error ("type and audit not specified"); - return; - } - if ($type eq 'objects') { - if ($audit eq 'name') { - return unless defined &Wallet::Config::verify_name; - my @objects = $self->objects; - my @results; - for my $object (@objects) { - my ($type, $name) = @$object; - my $error = Wallet::Config::verify_name ($type, $name); - push (@results, $object) if $error; - } - return @results; - } else { - $self->error ("unknown object audit: $audit"); - return; - } - } elsif ($type eq 'acls') { - if ($audit eq 'name') { - return unless defined &Wallet::Config::verify_acl_name; - my @acls = $self->acls; - my @results; - for my $acl (@acls) { - my $error = Wallet::Config::verify_acl_name ($acl->[1]); - push (@results, $acl) if $error; - } - return @results; - } else { - $self->error ("unknown acl audit: $audit"); - return; - } - } else { - $self->error ("unknown audit type: $type"); - return; - } -} - -1; -__DATA__ - -############################################################################## -# Documentation -############################################################################## - -=head1 NAME - -Wallet::Report - Wallet system reporting interface - -=for stopwords -ACL ACLs wildcard Allbery SQL tuples - -=head1 SYNOPSIS - - use Wallet::Report; - my $report = Wallet::Report->new; - my @objects = $report->objects ('type', 'keytab'); - for my $object (@objects) { - print "@$object\n"; - } - @objects = $report->audit ('objects', 'name'); - -=head1 DESCRIPTION - -Wallet::Report provides a mechanism to generate lists and reports on the -contents of the wallet database. The format of the results returned -depend on the type of search, but will generally be returned as a list of -tuples identifying objects, ACLs, or ACL entries. - -To use this object, several configuration variables must be set (at least -the database configuration). For information on those variables and how -to set them, see L. For more information on the normal -user interface to the wallet server, see L. - -=head1 CLASS METHODS - -=over 4 - -=item new() - -Creates a new wallet report object and connects to the database. On any -error, this method throws an exception. - -=back - -=head1 INSTANCE METHODS - -For all methods that can fail, the caller should call error() after a -failure to get the error message. For all methods that return lists, if -they return an empty list, the caller should call error() to distinguish -between an empty report and an error. - -=over 4 - -=item acls([ TYPE [, SEARCH ... ]]) - -Returns a list of all ACLs matching a search type and string in the -database, or all ACLs if no search information is given. There are -currently four search types. C returns sets of duplicate ACLs -(ones with exactly the same entries). C takes no arguments and -will return only those ACLs that have no entries within them. C -takes two arguments, an entry scheme and a (possibly partial) entry -identifier, and will return any ACLs containing an entry with that scheme -and with an identifier containing that value. C returns all ACLs -that are not referenced by any object. - -The return value for everything except C is a list of -references to pairs of ACL ID and name. For example, if there are two -ACLs in the database, one with name C and ID 1 and one with name -C and ID 3, acls() with no arguments would return: - - ([ 1, 'ADMIN' ], [ 3, 'group/admins' ]) - -The return value for the C search is sets of ACL names that are -duplicates (have the same entries). For example, if C, C, and -C are all duplicates, and C and C are also duplicates, the -result would be: - - ([ 'd1', 'd2', 'd3' ], [ 'o1', 'o2' ]) - -Returns the empty list on failure. An error can be distinguished from -empty search results by calling error(). error() is guaranteed to return -the error message if there was an error and undef if there was no error. - -=item audit(TYPE, AUDIT) - -Audits the wallet database for violations of local policy. TYPE is the -general class of thing to audit, and AUDIT is the specific audit to -perform. TYPE may be either C or C. Currently, the only -implemented audit is C. This returns a list of all objects, as -references to pairs of type and name, or ACLs, as references to pairs of -ID and name, that are not accepted by the verify_name() or -verify_acl_name() function defined in the wallet configuration. See -L for more information. - -Returns the empty list on failure. An error can be distinguished from -empty search results by calling error(). error() is guaranteed to return -the error message if there was an error and undef if there was no error. - -=item 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. - -=item objects([ TYPE [, SEARCH ... ]]) - -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, with a given type, -will return only those entries where the type matches the given type. -C, with a given owner, will only return those objects owned by the -given ACL name or ID. C, with a given flag name, will only return -those items with a flag set to the given value. C operates like -C, 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 will -return all entries for which a get command has never been issued. - -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 -and with values C and C, objects() with no -arguments would return: - - ([ 'keytab', 'host/example.com' ], [ 'keytab', 'foo' ]) - -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 -matching TYPE and NAME, which are interpreted as SQL patterns using C<%> -as a wildcard. The return value is a list of references to pairs of -schema and identifier, with duplicates removed. - -Returns the empty list on failure. To distinguish between this and no -matches, 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. - -=back - -=head1 SEE ALSO - -Wallet::Config(3), Wallet::Server(3) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery and Jon Robertson . - -=cut diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm deleted file mode 100644 index 74b4c99..0000000 --- a/perl/Wallet/Schema.pm +++ /dev/null @@ -1,354 +0,0 @@ -# Database schema and connector for the wallet system. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema; - -use strict; -use warnings; - -use Wallet::Config; - -use base 'DBIx::Class::Schema'; - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -our $VERSION = '0.09'; - -__PACKAGE__->load_namespaces; -__PACKAGE__->load_components (qw/Schema::Versioned/); - -############################################################################## -# Core overrides -############################################################################## - -# Override DBI::connect to supply our own connect string, username, and -# password and to set some standard options. Takes no arguments other than -# the implicit class argument. -sub connect { - my ($class) = @_; - unless ($Wallet::Config::DB_DRIVER - and (defined ($Wallet::Config::DB_INFO) - or defined ($Wallet::Config::DB_NAME))) { - die "database connection information not configured\n"; - } - my $dsn = "DBI:$Wallet::Config::DB_DRIVER:"; - if (defined $Wallet::Config::DB_INFO) { - $dsn .= $Wallet::Config::DB_INFO; - } else { - $dsn .= "database=$Wallet::Config::DB_NAME"; - $dsn .= ";host=$Wallet::Config::DB_HOST" if $Wallet::Config::DB_HOST; - $dsn .= ";port=$Wallet::Config::DB_PORT" if $Wallet::Config::DB_PORT; - } - my $user = $Wallet::Config::DB_USER; - my $pass = $Wallet::Config::DB_PASSWORD; - my %attrs = (PrintError => 0, RaiseError => 1); - my $schema = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) }; - if ($@) { - die "cannot connect to database: $@\n"; - } - return $schema; -} - -1; - -__END__ - -############################################################################## -# Documentation -############################################################################## - -=for stopwords -RaiseError PrintError AutoCommit ACL verifier API APIs enums keytab backend -enctypes DBI Allbery - -=head1 NAME - -Wallet::Schema - Database schema and connector for the wallet system - -=head1 SYNOPSIS - - use Wallet::Schema; - my $schema = Wallet::Schema->connect; - -=head1 DESCRIPTION - -This class encapsulates the database schema for the wallet system. The -documentation you're reading explains and comments the schema. The -class runs using the DBIx::Class module. - -connect() will obtain the database connection information from the wallet -configuration; see L for more details. It will also -automatically set the RaiseError attribute to true and the PrintError and -AutoCommit attributes to false, matching the assumptions made by the -wallet database code. - -=head1 SCHEMA - -=head2 Normalization Tables - -Holds the supported object types and their corresponding Perl classes: - - create table types - (ty_name varchar(16) primary key, - ty_class varchar(64)); - insert into types (ty_name, ty_class) - values ('file', 'Wallet::Object::File'); - insert into types (ty_name, ty_class) - values ('keytab', 'Wallet::Object::Keytab'); - -Holds the supported ACL schemes and their corresponding Perl classes: - - create table acl_schemes - (as_name varchar(32) primary key, - as_class varchar(64)); - insert into acl_schemes (as_name, as_class) - values ('krb5', 'Wallet::ACL::Krb5'); - insert into acl_schemes (as_name, as_class) - values ('krb5-regex', 'Wallet::ACL::Krb5::Regex'); - insert into acl_schemes (as_name, as_class) - values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute'); - 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'); - -If you have extended the wallet to support additional object types or -additional ACL schemes, you will want to add additional rows to these -tables mapping those types or schemes to Perl classes that implement the -object or ACL verifier APIs. - -=head2 ACL Tables - -A wallet ACL consists of zero or more ACL entries, each of which is a -scheme and an identifier. The scheme identifies the check that should be -performed and the identifier is additional scheme-specific information. -Each ACL references entries in the following table: - - create table acls - (ac_id integer auto_increment primary key, - ac_name varchar(255) not null, - unique (ac_name)); - -This just keeps track of unique ACL identifiers. The data is then stored -in: - - create table acl_entries - (ae_id integer not null references acls(ac_id), - ae_scheme varchar(32) - not null references acl_schemes(as_name), - ae_identifier varchar(255) not null, - primary key (ae_id, ae_scheme, ae_identifier)); - create index ae_id on acl_entries (ae_id); - -ACLs may be referred to in the API via either the numeric ID or the -human-readable name, but internally ACLs are always referenced by numeric -ID so that they can be renamed without requiring complex data -modifications. - -Currently, the ACL named C (case-sensitive) is special-cased in the -Wallet::Server code and granted global access. - -Every change made to any ACL in the database will be recorded in this -table. - - create table acl_history - (ah_id integer auto_increment primary key, - ah_acl integer not null, - ah_action varchar(16) not null, - ah_scheme varchar(32) default null, - ah_identifier varchar(255) default null, - ah_by varchar(255) not null, - ah_from varchar(255) not null, - ah_on datetime not null); - create index ah_acl on acl_history (ah_acl); - -ah_action must be one of C, C, C, or C -(enums aren't used for compatibility with databases other than MySQL). -For a change of type create or destroy, only the action and the trace -records (by, from, and on) are stored. For a change to the lines of an -ACL, the scheme and identifier of the line that was added or removed is -included. Note that changes to the ACL name are not recorded; ACLs are -always tracked by system-generated ID, so name changes are purely -cosmetic. - -ah_by stores the authenticated identity that made the change, ah_from -stores the host from which they made the change, and ah_on stores the time -the change was made. - -=head2 Object Tables - -Each object stored in the wallet is represented by an entry in the objects -table: - - create table objects - (ob_type varchar(16) - not null references types(ty_name), - ob_name varchar(255) not null, - ob_owner integer default null references acls(ac_id), - ob_acl_get integer default null references acls(ac_id), - ob_acl_store integer default null references acls(ac_id), - ob_acl_show integer default null references acls(ac_id), - ob_acl_destroy integer default null references acls(ac_id), - ob_acl_flags integer default null references acls(ac_id), - ob_expires datetime default null, - ob_created_by varchar(255) not null, - ob_created_from varchar(255) not null, - ob_created_on datetime not null, - ob_stored_by varchar(255) default null, - ob_stored_from varchar(255) default null, - ob_stored_on datetime default null, - ob_downloaded_by varchar(255) default null, - ob_downloaded_from varchar(255) default null, - ob_downloaded_on datetime default null, - ob_comment varchar(255) default null, - primary key (ob_name, ob_type)); - create index ob_owner on objects (ob_owner); - create index ob_expires on objects (ob_expires); - -Object names are not globally unique but only unique within their type, so -the table has a joint primary key. Each object has an owner and then up -to five more specific ACLs. The owner provides permission for get, store, -and show operations if no more specific ACL is set. It does not provide -permission for destroy or flags. - -The ob_acl_flags ACL controls who can set flags on this object. Each -object may have zero or more flags associated with it: - - create table flags - (fl_type varchar(16) - not null references objects(ob_type), - fl_name varchar(255) - not null references objects(ob_name), - fl_flag enum('locked', 'unchanging') - not null, - primary key (fl_type, fl_name, fl_flag)); - create index fl_object on flags (fl_type, fl_name); - -Every change made to any object in the wallet database will be recorded in -this table: - - create table object_history - (oh_id integer auto_increment primary key, - oh_type varchar(16) - not null references objects(ob_type), - oh_name varchar(255) - not null references objects(ob_name), - oh_action varchar(16) not null, - oh_field varchar(16) default null, - oh_type_field varchar(255) default null, - oh_old varchar(255) default null, - oh_new varchar(255) default null, - oh_by varchar(255) not null, - oh_from varchar(255) not null, - oh_on datetime not null); - create index oh_object on object_history (oh_type, oh_name); - -oh_action must be one of C, C, C, C, or -C. oh_field must be one of C, C, C, -C, C, C, C, C, or -C. Enums aren't used for compatibility with databases other -than MySQL. - -For a change of type create, get, store, or destroy, only the action and -the trace records (by, from, and on) are stored. For changes to columns -or to the flags table, oh_field takes what attribute is changed, oh_from -takes the previous value converted to a string and oh_to takes the next -value similarly converted to a string. The special field value -"type_data" is used when type-specific data is changed, and in that case -(and only that case) some type-specific name for the data being changed is -stored in oh_type_field. - -When clearing a flag, oh_old will have the name of the flag and oh_new -will be null. When setting a flag, oh_old will be null and oh_new will -have the name of the flag. - -oh_by stores the authenticated identity that made the change, oh_from -stores the host from which they made the change, and oh_on stores the time -the change was made. - -=head2 Duo Backend Data - -Duo integration objects store some additional metadata about the -integration to aid in synchronization with Duo. - - create table duo - (du_name varchar(255) - not null references objects(ob_name), - du_key varchar(255) not null); - create index du_key on duo (du_key); - -du_key holds the Duo integration key, which is the unique name of the -integration within Duo. Additional data may be added later to represent -the other possible settings within Duo. - -=head2 Keytab Backend Data - -The keytab backend has stub support for synchronizing keys with an -external system, although no external systems are currently supported. -The permitted external systems are listed in a normalization table: - - create table sync_targets - (st_name varchar(255) primary key); - -and then the synchronization targets for a given keytab are stored in this -table: - - create table keytab_sync - (ks_name varchar(255) - not null references objects(ob_name), - ks_target varchar(255) - not null references sync_targets(st_name), - primary key (ks_name, ks_target)); - create index ks_name on keytab_sync (ks_name); - -The keytab backend supports restricting the allowable enctypes for a given -keytab. The permitted enctypes are listed in a normalization table: - - create table enctypes - (en_name varchar(255) primary key); - -and then the restrictions for a given keytab are stored in this table: - - create table keytab_enctypes - (ke_name varchar(255) - not null references objects(ob_name), - ke_enctype varchar(255) - not null references enctypes(en_name), - primary key (ke_name, ke_enctype)); - create index ke_name on keytab_enctypes (ke_name); - -To use this functionality, you will need to populate the enctypes table -with the enctypes that a keytab may be restricted to. Currently, there is -no automated mechanism to do this. - -=head1 CLASS METHODS - -=over 4 - -=item connect() - -Opens a new database connection and returns the database object. On any -failure, throws an exception. Unlike the DBI method, connect() takes no -arguments; all database connection information is derived from the wallet -configuration. - -=back - -=head1 SEE ALSO - -wallet-backend(8), Wallet::Config(3) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/Wallet/Schema/Result/Acl.pm b/perl/Wallet/Schema/Result/Acl.pm deleted file mode 100644 index 226738a..0000000 --- a/perl/Wallet/Schema/Result/Acl.pm +++ /dev/null @@ -1,110 +0,0 @@ -# Wallet schema for an ACL. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::Acl; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=for stopwords -ACL - -=head1 NAME - -Wallet::Schema::Result::Acl - Wallet schema for an ACL - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("acls"); - -=head1 ACCESSORS - -=head2 ac_id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - -=head2 ac_name - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=cut - -__PACKAGE__->add_columns( - "ac_id", - { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, - "ac_name", - { data_type => "varchar", is_nullable => 0, size => 255 }, -); -__PACKAGE__->set_primary_key("ac_id"); -__PACKAGE__->add_unique_constraint("ac_name", ["ac_name"]); - -__PACKAGE__->has_one( - 'acl_entries', - 'Wallet::Schema::Result::AclEntry', - { 'foreign.ae_id' => 'self.ac_id' }, - { cascade_copy => 0, cascade_delete => 0 }, - ); -__PACKAGE__->has_many( - 'acl_history', - 'Wallet::Schema::Result::AclHistory', - { 'foreign.ah_id' => 'self.ac_id' }, - { cascade_copy => 0, cascade_delete => 0 }, - ); - -# References for all of the various potential ACLs in owners. -__PACKAGE__->has_many( - 'acls_owner', - 'Wallet::Schema::Result::Object', - { 'foreign.ob_owner' => 'self.ac_id' }, - ); -__PACKAGE__->has_many( - 'acls_get', - 'Wallet::Schema::Result::Object', - { 'foreign.ob_acl_get' => 'self.ac_id' }, - ); -__PACKAGE__->has_many( - 'acls_store', - 'Wallet::Schema::Result::Object', - { 'foreign.ob_acl_store' => 'self.ac_id' }, - ); -__PACKAGE__->has_many( - 'acls_show', - 'Wallet::Schema::Result::Object', - { 'foreign.ob_acl_show' => 'self.ac_id' }, - ); -__PACKAGE__->has_many( - 'acls_destroy', - 'Wallet::Schema::Result::Object', - { 'foreign.ob_acl_destroy' => 'self.ac_id' }, - ); -__PACKAGE__->has_many( - 'acls_flags', - 'Wallet::Schema::Result::Object', - { 'foreign.ob_acl_flags' => 'self.ac_id' }, - ); - -# Override the insert method so that we can automatically create history -# items. -#sub insert { -# my ($self, @args) = @_; -# my $ret = $self->next::method (@args); -# print "ID: ".$self->ac_id."\n"; -# use Data::Dumper; print Dumper (@args); - -# return $self; -#} - -1; diff --git a/perl/Wallet/Schema/Result/AclEntry.pm b/perl/Wallet/Schema/Result/AclEntry.pm deleted file mode 100644 index a33a98c..0000000 --- a/perl/Wallet/Schema/Result/AclEntry.pm +++ /dev/null @@ -1,74 +0,0 @@ -# Wallet schema for an entry in an ACL. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::AclEntry; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=for stopwords -ACL - -=head1 NAME - -Wallet::Schema::Result::AclEntry - Wallet schema for an entry in an ACL - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("acl_entries"); - -=head1 ACCESSORS - -=head2 ae_id - - data_type: 'integer' - is_nullable: 0 - -=head2 ae_scheme - - data_type: 'varchar' - is_nullable: 0 - size: 32 - -=head2 ae_identifier - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=cut - -__PACKAGE__->add_columns( - "ae_id", - { data_type => "integer", is_nullable => 0 }, - "ae_scheme", - { data_type => "varchar", is_nullable => 0, size => 32 }, - "ae_identifier", - { data_type => "varchar", is_nullable => 0, size => 255 }, -); -__PACKAGE__->set_primary_key("ae_id", "ae_scheme", "ae_identifier"); - -__PACKAGE__->belongs_to( - 'acls', - 'Wallet::Schema::Result::Acl', - { 'foreign.ac_id' => 'self.ae_id' }, - { is_deferrable => 1, on_delete => 'CASCADE', - on_update => 'CASCADE' }, - ); - -__PACKAGE__->has_one( - 'acl_scheme', - 'Wallet::Schema::Result::AclScheme', - { 'foreign.as_name' => 'self.ae_scheme' }, - { cascade_delete => 0 }, - ); -1; diff --git a/perl/Wallet/Schema/Result/AclHistory.pm b/perl/Wallet/Schema/Result/AclHistory.pm deleted file mode 100644 index 11593b7..0000000 --- a/perl/Wallet/Schema/Result/AclHistory.pm +++ /dev/null @@ -1,113 +0,0 @@ -# Wallet schema for ACL history. -# -# Written by Jon Robertson -# Copyright 2012, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::AclHistory; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -__PACKAGE__->load_components("InflateColumn::DateTime"); - -=for stopwords -ACL - -=head1 NAME - -Wallet::Schema::Result::AclHistory - Wallet schema for ACL history - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("acl_history"); - -=head1 ACCESSORS - -=head2 ah_id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - -=head2 ah_acl - - data_type: 'integer' - is_nullable: 0 - -=head2 ah_action - - data_type: 'varchar' - is_nullable: 0 - size: 16 - -=head2 ah_scheme - - data_type: 'varchar' - is_nullable: 1 - size: 32 - -=head2 ah_identifier - - data_type: 'varchar' - is_nullable: 1 - size: 255 - -=head2 ah_by - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 ah_from - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 ah_on - - data_type: 'datetime' - datetime_undef_if_invalid: 1 - is_nullable: 0 - -=cut - -__PACKAGE__->add_columns( - "ah_id", - { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, - "ah_acl", - { data_type => "integer", is_nullable => 0 }, - "ah_action", - { data_type => "varchar", is_nullable => 0, size => 16 }, - "ah_scheme", - { data_type => "varchar", is_nullable => 1, size => 32 }, - "ah_identifier", - { data_type => "varchar", is_nullable => 1, size => 255 }, - "ah_by", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "ah_from", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "ah_on", - { - data_type => "datetime", - datetime_undef_if_invalid => 1, - is_nullable => 0, - }, -); -__PACKAGE__->set_primary_key("ah_id"); - -# Add an index on the ACL. -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - my $name = 'acl_history_idx_ah_acl'; - $sqlt_table->add_index (name => $name, fields => [qw(ah_acl)]); -} - -1; diff --git a/perl/Wallet/Schema/Result/AclScheme.pm b/perl/Wallet/Schema/Result/AclScheme.pm deleted file mode 100644 index 91a58b2..0000000 --- a/perl/Wallet/Schema/Result/AclScheme.pm +++ /dev/null @@ -1,84 +0,0 @@ -# Wallet schema for ACL scheme. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::AclScheme; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; -__PACKAGE__->load_components (qw//); - -=for stopwords -ACL verifier APIs - -=head1 NAME - -Wallet::Schema::Result::AclScheme - Wallet schema for ACL scheme - -=head1 DESCRIPTION - -This is a normalization table used to constrain the values in other -tables. It contains the types of ACL schemes that Wallet will -recognize, and the modules that govern each of those schemes. - -By default it contains the following entries: - - insert into acl_schemes (as_name, as_class) - values ('krb5', 'Wallet::ACL::Krb5'); - insert into acl_schemes (as_name, as_class) - values ('krb5-regex', 'Wallet::ACL::Krb5::Regex'); - insert into acl_schemes (as_name, as_class) - values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute'); - 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'); - -If you have extended the wallet to support additional ACL schemes, you -will want to add additional rows to this table mapping those schemes -to Perl classes that implement the ACL verifier APIs. - -=cut - -__PACKAGE__->table("acl_schemes"); - -=head1 ACCESSORS - -=head2 as_name - - data_type: 'varchar' - is_nullable: 0 - size: 32 - -=head2 as_class - - data_type: 'varchar' - is_nullable: 1 - size: 64 - -=cut - -__PACKAGE__->add_columns( - "as_name", - { data_type => "varchar", is_nullable => 0, size => 32 }, - "as_class", - { data_type => "varchar", is_nullable => 1, size => 64 }, -); -__PACKAGE__->set_primary_key("as_name"); - -#__PACKAGE__->resultset->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' ], -# ]); - -1; diff --git a/perl/Wallet/Schema/Result/Duo.pm b/perl/Wallet/Schema/Result/Duo.pm deleted file mode 100644 index 80a71dc..0000000 --- a/perl/Wallet/Schema/Result/Duo.pm +++ /dev/null @@ -1,53 +0,0 @@ -# Wallet schema for Duo metadata. -# -# Written by Jon Robertson -# Copyright 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::Duo; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=for stopwords -keytab enctype - -=head1 NAME - -Wallet::Schema::Result::Duo - Wallet schema for Duo metadata - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("duo"); - -=head1 ACCESSORS - -=head2 du_name - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 du_key - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=cut - -__PACKAGE__->add_columns( - "du_name", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "du_key", - { data_type => "varchar", is_nullable => 0, size => 255 }, -); -__PACKAGE__->set_primary_key("du_name"); - -1; diff --git a/perl/Wallet/Schema/Result/Enctype.pm b/perl/Wallet/Schema/Result/Enctype.pm deleted file mode 100644 index 5733669..0000000 --- a/perl/Wallet/Schema/Result/Enctype.pm +++ /dev/null @@ -1,45 +0,0 @@ -# Wallet schema for Kerberos encryption type. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::Enctype; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=for stopwords -Kerberos - -=head1 NAME - -Wallet::Schema::Result::Enctype - Wallet schema for Kerberos encryption type - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("enctypes"); - -=head1 ACCESSORS - -=head2 en_name - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=cut - -__PACKAGE__->add_columns( - "en_name", - { data_type => "varchar", is_nullable => 0, size => 255 }, -); -__PACKAGE__->set_primary_key("en_name"); - -1; diff --git a/perl/Wallet/Schema/Result/Flag.pm b/perl/Wallet/Schema/Result/Flag.pm deleted file mode 100644 index e223ff8..0000000 --- a/perl/Wallet/Schema/Result/Flag.pm +++ /dev/null @@ -1,62 +0,0 @@ -# Wallet schema for object flags. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::Flag; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 NAME - -Wallet::Schema::Result::Flag - Wallet schema for object flags - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("flags"); - -=head1 ACCESSORS - -=head2 fl_type - - data_type: 'varchar' - is_nullable: 0 - size: 16 - -=head2 fl_name - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 fl_flag - - data_type: 'varchar' - is_nullable: 0 - size: 32 - -=cut - -__PACKAGE__->add_columns( - "fl_type" => - { data_type => "varchar", is_nullable => 0, size => 16 }, - "fl_name" => - { data_type => "varchar", is_nullable => 0, size => 255 }, - "fl_flag" => { - data_type => 'enum', - is_enum => 1, - extra => { list => [qw/locked unchanging/] }, - }, -); -__PACKAGE__->set_primary_key("fl_type", "fl_name", "fl_flag"); - - -1; diff --git a/perl/Wallet/Schema/Result/KeytabEnctype.pm b/perl/Wallet/Schema/Result/KeytabEnctype.pm deleted file mode 100644 index daea724..0000000 --- a/perl/Wallet/Schema/Result/KeytabEnctype.pm +++ /dev/null @@ -1,53 +0,0 @@ -# Wallet schema for keytab enctype. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::KeytabEnctype; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=for stopwords -keytab enctype - -=head1 NAME - -Wallet::Schema::Result::KeytabEnctype - Wallet schema for keytab enctype - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("keytab_enctypes"); - -=head1 ACCESSORS - -=head2 ke_name - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 ke_enctype - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=cut - -__PACKAGE__->add_columns( - "ke_name", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "ke_enctype", - { data_type => "varchar", is_nullable => 0, size => 255 }, -); -__PACKAGE__->set_primary_key("ke_name", "ke_enctype"); - -1; diff --git a/perl/Wallet/Schema/Result/KeytabSync.pm b/perl/Wallet/Schema/Result/KeytabSync.pm deleted file mode 100644 index ca84277..0000000 --- a/perl/Wallet/Schema/Result/KeytabSync.pm +++ /dev/null @@ -1,53 +0,0 @@ -# Wallet schema for keytab synchronization. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::KeytabSync; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=for stopwords -keytab - -=head1 NAME - -Wallet::Schema::Result::KeytabSync - Wallet schema for keytab synchronization - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("keytab_sync"); - -=head1 ACCESSORS - -=head2 ks_name - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 ks_target - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=cut - -__PACKAGE__->add_columns( - "ks_name", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "ks_target", - { data_type => "varchar", is_nullable => 0, size => 255 }, -); -__PACKAGE__->set_primary_key("ks_name", "ks_target"); - -1; diff --git a/perl/Wallet/Schema/Result/Object.pm b/perl/Wallet/Schema/Result/Object.pm deleted file mode 100644 index fd64e1b..0000000 --- a/perl/Wallet/Schema/Result/Object.pm +++ /dev/null @@ -1,266 +0,0 @@ -# Wallet schema for an object. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::Object; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -__PACKAGE__->load_components("InflateColumn::DateTime"); - -=head1 NAME - -Wallet::Schema::Result::Object - Wallet schema for an object - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("objects"); - -=head1 ACCESSORS - -=head2 ob_type - - data_type: 'varchar' - is_nullable: 0 - size: 16 - -=head2 ob_name - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 ob_owner - - data_type: 'integer' - is_nullable: 1 - -=head2 ob_acl_get - - data_type: 'integer' - is_nullable: 1 - -=head2 ob_acl_store - - data_type: 'integer' - is_nullable: 1 - -=head2 ob_acl_show - - data_type: 'integer' - is_nullable: 1 - -=head2 ob_acl_destroy - - data_type: 'integer' - is_nullable: 1 - -=head2 ob_acl_flags - - data_type: 'integer' - is_nullable: 1 - -=head2 ob_expires - - data_type: 'datetime' - datetime_undef_if_invalid: 1 - is_nullable: 1 - -=head2 ob_created_by - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 ob_created_from - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 ob_created_on - - data_type: 'datetime' - datetime_undef_if_invalid: 1 - is_nullable: 0 - -=head2 ob_stored_by - - data_type: 'varchar' - is_nullable: 1 - size: 255 - -=head2 ob_stored_from - - data_type: 'varchar' - is_nullable: 1 - size: 255 - -=head2 ob_stored_on - - data_type: 'datetime' - datetime_undef_if_invalid: 1 - is_nullable: 1 - -=head2 ob_downloaded_by - - data_type: 'varchar' - is_nullable: 1 - size: 255 - -=head2 ob_downloaded_from - - data_type: 'varchar' - is_nullable: 1 - size: 255 - -=head2 ob_downloaded_on - - data_type: 'datetime' - datetime_undef_if_invalid: 1 - is_nullable: 1 - -=head2 ob_comment - - data_type: 'varchar' - is_nullable: 1 - size: 255 - -=cut - -__PACKAGE__->add_columns( - "ob_type", - { data_type => "varchar", is_nullable => 0, size => 16 }, - "ob_name", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "ob_owner", - { data_type => "integer", is_nullable => 1 }, - "ob_acl_get", - { data_type => "integer", is_nullable => 1 }, - "ob_acl_store", - { data_type => "integer", is_nullable => 1 }, - "ob_acl_show", - { data_type => "integer", is_nullable => 1 }, - "ob_acl_destroy", - { data_type => "integer", is_nullable => 1 }, - "ob_acl_flags", - { data_type => "integer", is_nullable => 1 }, - "ob_expires", - { - data_type => "datetime", - datetime_undef_if_invalid => 1, - is_nullable => 1, - }, - "ob_created_by", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "ob_created_from", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "ob_created_on", - { - data_type => "datetime", - datetime_undef_if_invalid => 1, - is_nullable => 0, - }, - "ob_stored_by", - { data_type => "varchar", is_nullable => 1, size => 255 }, - "ob_stored_from", - { data_type => "varchar", is_nullable => 1, size => 255 }, - "ob_stored_on", - { - data_type => "datetime", - datetime_undef_if_invalid => 1, - is_nullable => 1, - }, - "ob_downloaded_by", - { data_type => "varchar", is_nullable => 1, size => 255 }, - "ob_downloaded_from", - { data_type => "varchar", is_nullable => 1, size => 255 }, - "ob_downloaded_on", - { - data_type => "datetime", - datetime_undef_if_invalid => 1, - is_nullable => 1, - }, - "ob_comment", - { data_type => "varchar", is_nullable => 1, size => 255 }, -); -__PACKAGE__->set_primary_key("ob_name", "ob_type"); - -__PACKAGE__->has_one( - 'types', - 'Wallet::Schema::Result::Type', - { 'foreign.ty_name' => 'self.ob_type' }, - ); - -__PACKAGE__->has_many( - 'flags', - 'Wallet::Schema::Result::Flag', - { 'foreign.fl_type' => 'self.ob_type', - 'foreign.fl_name' => 'self.ob_name' }, - { cascade_copy => 0, cascade_delete => 0 }, - ); - -__PACKAGE__->has_many( - 'object_history', - 'Wallet::Schema::Result::ObjectHistory', - { 'foreign.oh_type' => 'self.ob_type', - 'foreign.oh_name' => 'self.ob_name' }, - { cascade_copy => 0, cascade_delete => 0 }, - ); - -__PACKAGE__->has_many( - 'keytab_enctypes', - 'Wallet::Schema::Result::KeytabEnctype', - { 'foreign.ke_name' => 'self.ob_name' }, - { cascade_copy => 0, cascade_delete => 0 }, - ); - -__PACKAGE__->has_many( - 'keytab_sync', - 'Wallet::Schema::Result::KeytabSync', - { 'foreign.ks_name' => 'self.ob_name' }, - { cascade_copy => 0, cascade_delete => 0 }, - ); - -# References for all of the various potential ACLs. -__PACKAGE__->belongs_to( - 'acls_owner', - 'Wallet::Schema::Result::Acl', - { 'foreign.ac_id' => 'self.ob_owner' }, - ); -__PACKAGE__->belongs_to( - 'acls_get', - 'Wallet::Schema::Result::Acl', - { 'foreign.ac_id' => 'self.ob_acl_get' }, - ); -__PACKAGE__->belongs_to( - 'acls_store', - 'Wallet::Schema::Result::Acl', - { 'foreign.ac_id' => 'self.ob_acl_store' }, - ); -__PACKAGE__->belongs_to( - 'acls_show', - 'Wallet::Schema::Result::Acl', - { 'foreign.ac_id' => 'self.ob_acl_show' }, - ); -__PACKAGE__->belongs_to( - 'acls_destroy', - 'Wallet::Schema::Result::Acl', - { 'foreign.ac_id' => 'self.ob_acl_destroy' }, - ); -__PACKAGE__->belongs_to( - 'acls_flags', - 'Wallet::Schema::Result::Acl', - { 'foreign.ac_id' => 'self.ob_acl_flags' }, - ); - -1; diff --git a/perl/Wallet/Schema/Result/ObjectHistory.pm b/perl/Wallet/Schema/Result/ObjectHistory.pm deleted file mode 100644 index 5e9c8bd..0000000 --- a/perl/Wallet/Schema/Result/ObjectHistory.pm +++ /dev/null @@ -1,135 +0,0 @@ -# Wallet schema for object history. -# -# Written by Jon Robertson -# Copyright 2012, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::ObjectHistory; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -__PACKAGE__->load_components("InflateColumn::DateTime"); - -=head1 NAME - -Wallet::Schema::Result::ObjectHistory - Wallet schema for object history - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("object_history"); - -=head1 ACCESSORS - -=head2 oh_id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - -=head2 oh_type - - data_type: 'varchar' - is_nullable: 0 - size: 16 - -=head2 oh_name - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 oh_action - - data_type: 'varchar' - is_nullable: 0 - size: 16 - -=head2 oh_field - - data_type: 'varchar' - is_nullable: 1 - size: 16 - -=head2 oh_type_field - - data_type: 'varchar' - is_nullable: 1 - size: 255 - -=head2 oh_old - - data_type: 'varchar' - is_nullable: 1 - size: 255 - -=head2 oh_new - - data_type: 'varchar' - is_nullable: 1 - size: 255 - -=head2 oh_by - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 oh_from - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=head2 oh_on - - data_type: 'datetime' - datetime_undef_if_invalid: 1 - is_nullable: 0 - -=cut - -__PACKAGE__->add_columns( - "oh_id", - { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, - "oh_type", - { data_type => "varchar", is_nullable => 0, size => 16 }, - "oh_name", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "oh_action", - { data_type => "varchar", is_nullable => 0, size => 16 }, - "oh_field", - { data_type => "varchar", is_nullable => 1, size => 16 }, - "oh_type_field", - { data_type => "varchar", is_nullable => 1, size => 255 }, - "oh_old", - { data_type => "varchar", is_nullable => 1, size => 255 }, - "oh_new", - { data_type => "varchar", is_nullable => 1, size => 255 }, - "oh_by", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "oh_from", - { data_type => "varchar", is_nullable => 0, size => 255 }, - "oh_on", - { - data_type => "datetime", - datetime_undef_if_invalid => 1, - is_nullable => 0, - }, -); -__PACKAGE__->set_primary_key("oh_id"); - -# Add an index on object type and object name. -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - my $name = 'object_history_idx_oh_type_oh_name'; - $sqlt_table->add_index (name => $name, fields => [qw(oh_type oh_name)]); -} - -1; diff --git a/perl/Wallet/Schema/Result/SyncTarget.pm b/perl/Wallet/Schema/Result/SyncTarget.pm deleted file mode 100644 index 4300a54..0000000 --- a/perl/Wallet/Schema/Result/SyncTarget.pm +++ /dev/null @@ -1,48 +0,0 @@ -# Wallet schema for synchronization targets. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::SyncTarget; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 NAME - -Wallet::Schema::Result::SyncTarget - Wallet schema for synchronization targets - -=head1 DESCRIPTION - -=cut - -__PACKAGE__->table("sync_targets"); - -=head1 ACCESSORS - -=head2 st_name - - data_type: 'varchar' - is_nullable: 0 - size: 255 - -=cut - -__PACKAGE__->add_columns( - "st_name", - { data_type => "varchar", is_nullable => 0, size => 255 }, -); -__PACKAGE__->set_primary_key("st_name"); - -#__PACKAGE__->has_many( -# 'keytab_sync', -# 'Wallet::Schema::Result::KeytabSync', -# { 'foreign.ks_target' => 'self.st_name' }, -# { cascade_copy => 0, cascade_delete => 0 }, -# ); -1; diff --git a/perl/Wallet/Schema/Result/Type.pm b/perl/Wallet/Schema/Result/Type.pm deleted file mode 100644 index 748a8a8..0000000 --- a/perl/Wallet/Schema/Result/Type.pm +++ /dev/null @@ -1,75 +0,0 @@ -# Wallet schema for object types. -# -# Written by Jon Robertson -# Copyright 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -package Wallet::Schema::Result::Type; - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=for stopwords -APIs - -=head1 NAME - -Wallet::Schema::Result::Type - Wallet schema for object types - -=head1 DESCRIPTION - -This is a normalization table used to constrain the values in other -tables. It contains the types of wallet objects that are considered -valid, and the modules that govern each. - -By default it contains the following entries: - - insert into types (ty_name, ty_class) - values ('file', 'Wallet::Object::File'); - insert into types (ty_name, ty_class) - values ('keytab', 'Wallet::Object::Keytab'); - -If you have extended the wallet to support additional object types , -you will want to add additional rows to this table mapping those types -to Perl classes that implement the object APIs. - -=cut - -__PACKAGE__->table("types"); - -=head1 ACCESSORS - -=head2 ty_name - - data_type: 'varchar' - is_nullable: 0 - size: 16 - -=head2 ty_class - - data_type: 'varchar' - is_nullable: 1 - size: 64 - -=cut - -__PACKAGE__->add_columns( - "ty_name", - { data_type => "varchar", is_nullable => 0, size => 16 }, - "ty_class", - { data_type => "varchar", is_nullable => 1, size => 64 }, -); -__PACKAGE__->set_primary_key("ty_name"); - -#__PACKAGE__->has_many( -# 'objects', -# 'Wallet::Schema::Result::Object', -# { 'foreign.ob_type' => 'self.ty_name' }, -# { cascade_copy => 0, cascade_delete => 0 }, -# ); - -1; diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm deleted file mode 100644 index 3266928..0000000 --- a/perl/Wallet/Server.pm +++ /dev/null @@ -1,1095 +0,0 @@ -# Wallet::Server -- Wallet system server implementation. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -############################################################################## -# Modules and declarations -############################################################################## - -package Wallet::Server; -require 5.006; - -use strict; -use vars qw(%MAPPING $VERSION); - -use Wallet::ACL; -use Wallet::Config; -use Wallet::Schema; - -# This version should be increased on any code change to this module. Always -# use two digits for the minor version with a leading zero if necessary so -# that it will sort properly. -$VERSION = '0.11'; - -############################################################################## -# Utility methods -############################################################################## - -# Create a new wallet server object. A new server should be created for each -# user who is making changes to the wallet. Takes the principal and host who -# are sending wallet requests. Opens a connection to the database that will -# be used for all of the wallet metadata based on the wallet configuration -# information. We also instantiate the administrative ACL, which we'll use -# for various things. Throw an exception if anything goes wrong. -sub new { - my ($class, $user, $host) = @_; - my $schema = Wallet::Schema->connect; - my $acl = Wallet::ACL->new ('ADMIN', $schema); - my $self = { - schema => $schema, - user => $user, - host => $host, - admin => $acl, - }; - bless ($self, $class); - return $self; -} - -# Returns the database handle (used mostly for testing). -sub dbh { - my ($self) = @_; - return $self->{schema}->storage->dbh; -} - -# Returns the DBIx::Class-based database schema object. -sub schema { - my ($self) = @_; - return $self->{schema}; -} - -# Set or return the error stashed in the object. -sub error { - my ($self, @error) = @_; - if (@error) { - my $error = join ('', @error); - chomp $error; - 1 while ($error =~ s/ at \S+ line \d+\.?\z//); - $self->{error} = $error; - } - return $self->{error}; -} - -# Disconnect the database handle on object destruction to avoid warnings. -sub DESTROY { - my ($self) = @_; - - if ($self->{schema}) { - $self->{schema}->storage->dbh->disconnect; - } -} - -############################################################################## -# Object methods -############################################################################## - -# Given an object type, return the mapping to a class by querying the -# database, or undef if no mapping exists. Also load the relevant module. -sub type_mapping { - my ($self, $type) = @_; - my $class; - eval { - my $guard = $self->{schema}->txn_scope_guard; - my %search = (ty_name => $type); - my $type_rec = $self->{schema}->resultset('Type')->find (\%search); - $class = $type_rec->ty_class; - $guard->commit; - }; - if ($@) { - $self->error ($@); - return; - } - if (defined $class) { - eval "require $class"; - if ($@) { - $self->error ($@); - return; - } - } - return $class; -} - -# Given an object which doesn't currently exist, check whether a default_owner -# function is defined and, if so, if it returns an ACL for that object. If -# so, create the ACL and check if the current user is authorized by that ACL. -# Returns true if so, false if not, setting the internal error as appropriate. -# -# This leaves those new ACLs in the database, which may not be the best -# behavior, but it's the simplest given the current Wallet::ACL API. This -# should probably be revisited later. -sub create_check { - my ($self, $type, $name) = @_; - my $user = $self->{user}; - my $host = $self->{host}; - my $schema = $self->{schema}; - unless (defined (&Wallet::Config::default_owner)) { - $self->error ("$user not authorized to create ${type}:${name}"); - return; - } - my ($aname, @acl) = Wallet::Config::default_owner ($type, $name); - unless (defined $aname) { - $self->error ("$user not authorized to create ${type}:${name}"); - return; - } - my $acl = eval { Wallet::ACL->new ($aname, $schema) }; - if ($@) { - $acl = eval { Wallet::ACL->create ($aname, $schema, $user, $host) }; - if ($@) { - $self->error ($@); - return; - } - for my $entry (@acl) { - unless ($acl->add ($entry->[0], $entry->[1], $user, $host)) { - $self->error ($acl->error); - return; - } - } - } else { - my @entries = $acl->list; - if (not @entries and $acl->error) { - $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; - my $okay = 1; - if (@entries != @acl) { - $okay = 0; - } else { - for my $i (0 .. $#entries) { - $okay = 0 unless ($entries[$i][0] eq $acl[$i][0]); - $okay = 0 unless ($entries[$i][1] eq $acl[$i][1]); - } - } - unless ($okay) { - $self->error ("ACL $aname exists and doesn't match default"); - return; - } - } - if ($acl->check ($user)) { - return $aname; - } else { - $self->error ("$user not authorized to create ${type}:${name}"); - return; - } -} - -# Create an object and returns it. This function is called by both create and -# autocreate and assumes that permissions and names have already been checked. -# On error, returns undef and sets the internal error. -sub create_object { - my ($self, $type, $name) = @_; - my $class = $self->type_mapping ($type); - unless ($class) { - $self->error ("unknown object type $type"); - return; - } - my $schema = $self->{schema}; - my $user = $self->{user}; - my $host = $self->{host}; - my $object = eval { $class->create ($type, $name, $schema, $user, $host) }; - if ($@) { - $self->error ($@); - return; - } - return $object; -} - -# Create a new object and returns that object. This method can only be called -# by wallet administrators. autocreate should be used by regular users who -# may benefit from default ACLs. On error, returns undef and sets the -# internal error. -sub create { - my ($self, $type, $name) = @_; - unless ($self->{admin}->check ($self->{user})) { - my $id = $type . ':' . $name; - $self->error ("$self->{user} not authorized to create $id"); - return; - } - if (defined (&Wallet::Config::verify_name)) { - my $error = Wallet::Config::verify_name ($type, $name, $self->{user}); - if ($error) { - $self->error ("${type}:${name} rejected: $error"); - return; - } - } - return unless $self->create_object ($type, $name); - return 1; -} - -# Attempt to auto-create an object based on default ACLs. This method is -# called by the wallet client when trying to get an object that doesn't -# already exist. On error, returns undef and sets the internal error. -sub autocreate { - my ($self, $type, $name) = @_; - if (defined (&Wallet::Config::verify_name)) { - my $error = Wallet::Config::verify_name ($type, $name, $self->{user}); - if ($error) { - $self->error ("${type}:${name} rejected: $error"); - return; - } - } - my $acl = $self->create_check ($type, $name); - return unless $acl; - my $object = $self->create_object ($type, $name); - return unless $object; - unless ($object->owner ($acl, $self->{user}, $self->{host})) { - $self->error ($object->error); - return; - } - return 1; -} - -# Given the name and type of an object, returns a Perl object representing it -# or returns undef and sets the internal error. -sub retrieve { - my ($self, $type, $name) = @_; - my $class = $self->type_mapping ($type); - unless ($class) { - $self->error ("unknown object type $type"); - return; - } - my $object = eval { $class->new ($type, $name, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } else { - return $object; - } -} - -# Sets the internal error variable to the correct message for permission -# denied on an object. -sub object_error { - my ($self, $object, $action) = @_; - my $user = $self->{user}; - my $id = $object->type . ':' . $object->name; - if ($action eq 'getattr') { - $action = "get attributes for"; - } elsif ($action eq 'setattr') { - $action = "set attributes for"; - } elsif ($action !~ /^(create|get|store|show|destroy)\z/) { - $action = "set $action for"; - } - $self->error ("$self->{user} not authorized to $action $id"); -} - -# Given an object and an action, checks if the current user has access to -# perform that object. If so, returns true. If not, returns undef and sets -# the internal error message. Note that we do not allow any special access to -# admins for get and store; if they want to do that with objects, they need to -# set the ACL accordingly. -sub acl_verify { - my ($self, $object, $action) = @_; - my %actions = map { $_ => 1 } - qw(get store show destroy flags setattr getattr comment); - unless ($actions{$action}) { - $self->error ("unknown action $action"); - return; - } - if ($action ne 'get' and $action ne 'store') { - return 1 if $self->{admin}->check ($self->{user}); - } - my $id; - if ($action eq 'getattr') { - $id = $object->acl ('show'); - } elsif ($action eq 'setattr') { - $id = $object->acl ('store'); - } elsif ($action ne 'comment') { - $id = $object->acl ($action); - } - if (! defined ($id) and $action ne 'flags') { - $id = $object->owner; - } - unless (defined $id) { - $self->object_error ($object, $action); - return; - } - my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } - my $status = $acl->check ($self->{user}); - if ($status == 1) { - return 1; - } elsif (not defined $status) { - $self->error ($acl->error); - return; - } else { - $self->object_error ($object, $action); - return; - } -} - -# Retrieves or sets an ACL on an object. -sub acl { - my ($self, $type, $name, $acl, $id) = @_; - undef $self->{error}; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - unless ($self->{admin}->check ($self->{user})) { - $self->object_error ($object, 'ACL'); - return; - } - my $result; - if (defined $id) { - $result = $object->acl ($acl, $id, $self->{user}, $self->{host}); - } else { - $result = $object->acl ($acl); - } - if (not defined ($result) and $object->error) { - $self->error ($object->error); - } - return $result; -} - -# Retrieves or sets an attribute on an object. -sub attr { - my ($self, $type, $name, $attr, @values) = @_; - undef $self->{error}; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - my $user = $self->{user}; - my $host = $self->{host}; - if (@values) { - return unless $self->acl_verify ($object, 'setattr'); - if (@values == 1 and $values[0] eq '') { - @values = (); - } - my $result = $object->attr ($attr, [ @values ], $user, $host); - $self->error ($object->error) unless $result; - return $result; - } else { - return unless $self->acl_verify ($object, 'getattr'); - my @result = $object->attr ($attr); - if (not @result and $object->error) { - $self->error ($object->error); - return; - } else { - return @result; - } - } -} - -# Retrieves or sets the comment of an object. -sub comment { - my ($self, $type, $name, $comment) = @_; - undef $self->{error}; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - my $result; - if (defined $comment) { - return unless $self->acl_verify ($object, 'comment'); - $result = $object->comment ($comment, $self->{user}, $self->{host}); - } else { - return unless $self->acl_verify ($object, 'show'); - $result = $object->comment; - } - if (not defined ($result) and $object->error) { - $self->error ($object->error); - } - return $result; -} - -# Retrieves or sets the expiration of an object. -sub expires { - my ($self, $type, $name, $expires) = @_; - undef $self->{error}; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - unless ($self->{admin}->check ($self->{user})) { - $self->object_error ($object, 'expires'); - return; - } - my $result; - if (defined $expires) { - $result = $object->expires ($expires, $self->{user}, $self->{host}); - } else { - $result = $object->expires; - } - if (not defined ($result) and $object->error) { - $self->error ($object->error); - } - return $result; -} - -# Retrieves or sets the owner of an object. -sub owner { - my ($self, $type, $name, $owner) = @_; - undef $self->{error}; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - unless ($self->{admin}->check ($self->{user})) { - $self->object_error ($object, 'owner'); - return; - } - my $result; - if (defined $owner) { - $result = $object->owner ($owner, $self->{user}, $self->{host}); - } else { - $result = $object->owner; - } - if (not defined ($result) and $object->error) { - $self->error ($object->error); - } - return $result; -} - -# Checks for the existence of an object. Returns 1 if it does, 0 if it -# doesn't, and undef if there was an error in checking the existence of the -# object. -sub check { - my ($self, $type, $name) = @_; - my $object = $self->retrieve ($type, $name); - if (not defined $object) { - if ($self->error =~ /^cannot find/) { - return 0; - } else { - return; - } - } - return 1; -} - -# Retrieve the information associated with an object, or 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 get { - my ($self, $type, $name) = @_; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - return unless $self->acl_verify ($object, 'get'); - my $result = $object->get ($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 -# object doesn't exist, attempts dynamic creation of the object using the -# default ACL mappings (if any). -sub store { - my ($self, $type, $name, $data) = @_; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - return unless $self->acl_verify ($object, 'store'); - if (not defined ($data)) { - $self->{error} = "no data supplied to store"; - return; - } - my $result = $object->store ($data, $self->{user}, $self->{host}); - $self->error ($object->error) unless defined $result; - return $result; -} - -# Return a human-readable description of the object's metadata, or returns -# undef and sets the internal error if the object can't be found or if the -# user isn't authorized. -sub show { - my ($self, $type, $name) = @_; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - return unless $self->acl_verify ($object, 'show'); - my $result = $object->show; - $self->error ($object->error) unless defined $result; - return $result; -} - -# Return a human-readable description of the object history, or returns undef -# and sets the internal error if the object can't be found or if the user -# isn't authorized. -sub history { - my ($self, $type, $name) = @_; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - return unless $self->acl_verify ($object, 'show'); - my $result = $object->history; - $self->error ($object->error) unless defined $result; - return $result; -} - -# Destroys the object, or returns undef and sets the internal error if the -# object can't be found or if the user isn't authorized. -sub destroy { - my ($self, $type, $name) = @_; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - return unless $self->acl_verify ($object, 'destroy'); - my $result = $object->destroy ($self->{user}, $self->{host}); - $self->error ($object->error) unless defined $result; - return $result; -} - -############################################################################## -# Object flag methods -############################################################################## - -# Clear a flag on an object. Takes the object and the flag. Returns true on -# success or undef and sets the internal error on failure. -sub flag_clear { - my ($self, $type, $name, $flag) = @_; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - return unless $self->acl_verify ($object, 'flags'); - my $result = $object->flag_clear ($flag, $self->{user}, $self->{host}); - $self->error ($object->error) unless defined $result; - return $result; -} - -# Set a flag on an object. Takes the object and the flag. Returns true on -# success or undef and sets the internal error on failure. -sub flag_set { - my ($self, $type, $name, $flag) = @_; - my $object = $self->retrieve ($type, $name); - return unless defined $object; - return unless $self->acl_verify ($object, 'flags'); - my $result = $object->flag_set ($flag, $self->{user}, $self->{host}); - $self->error ($object->error) unless defined $result; - return $result; -} - -############################################################################## -# ACL methods -############################################################################## - -# Checks for the existence of an ACL. Returns 1 if it does, 0 if it doesn't, -# and undef if there was an error in checking the existence of the object. -sub acl_check { - my ($self, $id) = @_; - my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; - if ($@) { - if ($@ =~ /^ACL .* not found/) { - return 0; - } else { - $self->error ($@); - return; - } - } - return 1; -} - -# Create a new empty ACL in the database. Returns true on success and undef -# on failure, setting the internal error. -sub acl_create { - my ($self, $name) = @_; - unless ($self->{admin}->check ($self->{user})) { - $self->error ("$self->{user} not authorized to create ACL"); - return; - } - my $user = $self->{user}; - my $host = $self->{host}; - if (defined (&Wallet::Config::verify_acl_name)) { - my $error = Wallet::Config::verify_acl_name ($name, $user); - if ($error) { - $self->error ("$name rejected: $error"); - return; - } - } - my $schema = $self->{schema}; - my $acl = eval { Wallet::ACL->create ($name, $schema, $user, $host) }; - if ($@) { - $self->error ($@); - return; - } else { - return 1; - } -} - -# Sets the internal error variable to the correct message for permission -# denied on an ACL. -sub acl_error { - my ($self, $acl, $action) = @_; - my $user = $self->{user}; - if ($action eq 'add') { - $action = 'add to'; - } elsif ($action eq 'remove') { - $action = 'remove from'; - } elsif ($action eq 'history') { - $action = 'see history of'; - } - $self->error ("$self->{user} not authorized to $action ACL $acl"); -} - -# Display the history of an ACL or return undef and set the internal error. -sub acl_history { - my ($self, $id) = @_; - unless ($self->{admin}->check ($self->{user})) { - $self->acl_error ($id, 'history'); - return; - } - my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } - my $result = $acl->history; - if (not defined $result) { - $self->error ($acl->error); - return; - } - return $result; -} - -# Display the membership of an ACL or return undef and set the internal error. -sub acl_show { - my ($self, $id) = @_; - unless ($self->{admin}->check ($self->{user})) { - $self->acl_error ($id, 'show'); - return; - } - my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } - my $result = $acl->show; - if (not defined $result) { - $self->error ($acl->error); - return; - } - return $result; -} - -# Change the human-readable name of an ACL or return undef and set the -# internal error. -sub acl_rename { - my ($self, $id, $name) = @_; - unless ($self->{admin}->check ($self->{user})) { - $self->acl_error ($id, 'rename'); - return; - } - my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } - if ($acl->name eq 'ADMIN') { - $self->error ('cannot rename the ADMIN ACL'); - return; - } - if (defined (&Wallet::Config::verify_acl_name)) { - my $error = Wallet::Config::verify_acl_name ($name, $self->{user}); - if ($error) { - $self->error ("$name rejected: $error"); - return; - } - } - unless ($acl->rename ($name)) { - $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 { - my ($self, $id) = @_; - unless ($self->{admin}->check ($self->{user})) { - $self->acl_error ($id, 'destroy'); - return; - } - my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } - if ($acl->name eq 'ADMIN') { - $self->error ('cannot destroy the ADMIN ACL'); - return; - } - unless ($acl->destroy ($self->{user}, $self->{host})) { - $self->error ($acl->error); - return; - } - return 1; -} - -# Add an ACL entry to an ACL. Returns true on success. On failure, returns -# undef, setting the internal error. -sub acl_add { - my ($self, $id, $scheme, $identifier) = @_; - unless ($self->{admin}->check ($self->{user})) { - $self->acl_error ($id, 'add'); - return; - } - my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } - unless ($acl->add ($scheme, $identifier, $self->{user}, $self->{host})) { - $self->error ($acl->error); - return; - } - return 1; -} - -# Remove an ACL entry to an ACL. Returns true on success. On failure, -# returns undef, setting the internal error. -sub acl_remove { - my ($self, $id, $scheme, $identifier) = @_; - unless ($self->{admin}->check ($self->{user})) { - $self->acl_error ($id, 'remove'); - return; - } - my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; - if ($@) { - $self->error ($@); - return; - } - if ($acl->name eq 'ADMIN') { - my @e = $acl->list; - if (not @e and $acl->error) { - $self->error ($acl->error); - return; - } elsif (@e == 1 && $e[0][0] eq $scheme && $e[0][1] eq $identifier) { - $self->error ('cannot remove last ADMIN ACL entry'); - return; - } - } - my $user = $self->{user}; - my $host = $self->{host}; - unless ($acl->remove ($scheme, $identifier, $user, $host)) { - $self->error ($acl->error); - return; - } - return 1; -} - -1; -__END__ - -############################################################################## -# Documentation -############################################################################## - -=head1 NAME - -Wallet::Server - Wallet system server implementation - -=for stopwords -keytabs metadata backend HOSTNAME ACL timestamp ACL's nul Allbery -backend-specific wallet-backend verifier - -=head1 SYNOPSIS - - use Wallet::Server; - my $server = Wallet::Server->new ($user, $host); - $server->create ('keytab', 'host/example.com@EXAMPLE.COM'); - -=head1 DESCRIPTION - -Wallet::Server is the top-level class that implements the wallet server. -The wallet is a system for storing, generating, and retrieving secure -information such as Kerberos keytabs. The server maintains metadata about -the objects, checks access against ACLs, and dispatches requests for -objects to backend implementations for that object type. - -Wallet::Server is normally instantiated and used by B, a -thin wrapper around this object that determines the authenticated remote -user and gets user input and then calls the appropriate method of this -object. - -To use this object, several configuration variables must be set (at least -the database configuration). For information on those variables and how -to set them, see L. - -=head1 CLASS METHODS - -=over 4 - -=item new(PRINCIPAL, HOSTNAME) - -Creates a new wallet server object for actions from the user PRINCIPAL -connecting from HOSTNAME. PRINCIPAL and HOSTNAME will be used for logging -history information for all subsequent operations. new() opens the -database, using the database configuration as set by Wallet::Config and -ensures that the C ACL exists. That ACL will be used to authorize -privileged operations. - -On any error, this method throws an exception. - -=back - -=head1 INSTANCE METHODS - -For all methods that can fail, the caller should call error() after a -failure to get the error message. - -=over 4 - -=item acl(TYPE, NAME, ACL [, ID]) - -Gets or sets the ACL type ACL to ID for the object identified by TYPE and -NAME. ACL should be one of C, C, C, C, or -C. If ID is not given, returns the current setting of that ACL as -a numeric ACL ID or undef if that ACL isn't set or on failure. To -distinguish between an ACL that isn't set and a failure to retrieve the -ACL, the caller should call error() after an undef return. If error() -also returns undef, that ACL wasn't set; otherwise, error() will return -the error message. - -If ID is given, sets the specified ACL to ID, which can be either the name -of an ACL or a numeric ACL ID. To clear the ACL, pass in an empty string -as the ID. To set or clear an ACL, the current user must be authorized by -the ADMIN ACL. Returns true for success and false for failure. - -ACL settings are checked before the owner and override the owner setting. - -=item acl_add(ID, SCHEME, IDENTIFIER) - -Adds an ACL entry with scheme SCHEME and identifier IDENTIFIER to the ACL -identified by ID. ID may be either the ACL name or the numeric ACL ID. -SCHEME must be a valid ACL scheme for which the wallet system has an ACL -verifier implementation. To add an entry to an ACL, the current user must -be authorized by the ADMIN ACL. Returns true for success and false for -failure. - -=item acl_create(NAME) - -Create a new ACL with the specified NAME, which must not be all-numeric. -The newly created ACL will be empty. To create an ACL, the current user -must be authorized by the ADMIN ACL. Returns true on success and false on -failure. - -=item acl_destroy(ID) - -Destroys the ACL identified by ID, which may be either the ACL name or its -numeric ID. This call will fail if the ACL is still referenced by any -object. The ADMIN ACL may not be destroyed. To destroy an ACL, the -current user must be authorized by the ADMIN ACL. Returns true on success -and false on failure. - -=item acl_history(ID) - -Returns the history of the ACL identified by ID, which may be either the -ACL name or its numeric ID. To see the history of an ACL, the current -user must be authorized by the ADMIN ACL. Each change that modifies the -ACL (not counting changes in the name of the ACL) will be represented by -two lines. The first line will have a timestamp of the change followed by -a description of the change, and the second line will give the user who -made the change and the host from which the change was made. Returns -undef on failure. - -=item acl_remove(ID, SCHEME, IDENTIFIER) - -Removes from the ACL identified by ID the entry matching SCHEME and -IDENTIFIER. ID may be either the name of the ACL or its numeric ID. The -last entry in the ADMIN ACL cannot be removed. To remove an entry from an -ACL, the current user must be authorized by the ADMIN ACL. Returns true -on success and false on failure. - -=item acl_rename(OLD, NEW) - -Renames the ACL identified by OLD to NEW. This changes the human-readable -name, not the underlying numeric ID, so the ACL's associations with -objects will be unchanged. The ADMIN ACL may not be renamed. OLD may be -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_show(ID) - -Returns a human-readable description, including membership, of the ACL -identified by ID, which may be either the ACL name or its numeric ID. To -show an ACL, the current user must be authorized by the ADMIN ACL -(although be aware that anyone with show access to an object can see the -membership of ACLs associated with that object through the show() method). -Returns the human-readable description on success and undef on failure. - -=item attr(TYPE, NAME, ATTRIBUTE [, VALUE ...]) - -Sets or retrieves a given object attribute. Attributes are used to store -backend-specific information for a particular object type and ATTRIBUTE -must be an attribute type known to the underlying object implementation. - -If VALUE is not given, returns the values of that attribute, if any, as a -list. On error, returns the empty list. To distinguish between an error -and an empty return, call error() afterward. It is guaranteed to return -undef unless there was an error. To retrieve an attribute setting, the -user must be authorized by the ADMIN ACL, the show ACL if set, or the -owner ACL if the show ACL is not set. - -If VALUE is given, sets the given ATTRIBUTE values to VALUE, which is one -or more attribute values. Pass the empty string as the only VALUE to -clear the attribute values. Returns true on success and false on failure. -To set an attribute value, the user must be authorized by the ADMIN ACL, -the store ACL if set, or the owner ACL if the store ACL is not set. - -=item autocreate(TYPE, NAME) - -Creates a new object of type TYPE and name NAME. TYPE must be a -recognized type for which the wallet system has a backend implementation. -Returns true on success and false on failure. - -To create an object using this method, the current user must be authorized -by the default owner as determined by the wallet configuration. For more -information on how to map new objects to default owners, see -Wallet::Config(3). Wallet administrators should use the create() method -to create objects. - -=item check(TYPE, NAME) - -Check whether an object of type TYPE and name NAME exists. Returns 1 if -it does, 0 if it doesn't, and undef if some error occurred while checking -for the existence of the object. - -=item comment(TYPE, NAME, [COMMENT]) - -Gets or sets the comment for the object identified by TYPE and NAME. If -COMMENT is not given, returns the current comment or undef if no comment -is set or on an error. To distinguish between an expiration that isn't -set and a failure to retrieve the expiration, the caller should call -error() after an undef return. If error() also returns undef, no comment -was set; otherwise, error() will return the error message. - -If COMMENT is given, sets the comment to COMMENT. Pass in the empty -string for COMMENT to clear the comment. To set a comment, the current -user must be the object owner or be on the ADMIN ACL. Returns true for -success and false for failure. - -=item create(TYPE, NAME) - -Creates a new object of type TYPE and name NAME. TYPE must be a -recognized type for which the wallet system has a backend implementation. -Returns true on success and false on failure. - -To create an object using this method, the current user must be authorized -by the ADMIN ACL. Use autocreate() to create objects based on the default -owner as determined by the wallet configuration. - -=item destroy(TYPE, NAME) - -Destroys the object identified by TYPE and NAME. This destroys any data -that the wallet had saved about the object, may remove the underlying -object from other external systems, and destroys the wallet database entry -for the object. To destroy an object, the current user must be a member -of the ADMIN ACL, authorized by the destroy ACL, or authorized by the -owner ACL; however, if the destroy ACL is set, the owner ACL will not be -checked. Returns true on success and false on failure. - -=item dbh() - -Returns the database handle of a Wallet::Server object. This is used -mostly for testing; normally, clients should perform all actions through -the Wallet::Server object to ensure that authorization and history logging -is done properly. - -=item 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. - -=item expires(TYPE, NAME [, EXPIRES]) - -Gets or sets the expiration for the object identified by TYPE and NAME. -If EXPIRES is not given, returns the current expiration or undef if no -expiration is set or on an error. To distinguish between an expiration -that isn't set and a failure to retrieve the expiration, the caller should -call error() after an undef return. If error() also returns undef, the -expiration wasn't set; otherwise, error() will return the error message. - -If EXPIRES is given, sets the expiration to EXPIRES. EXPIRES must be in -the format C, although the time portion may be -omitted. Pass in the empty string for EXPIRES to clear the expiration -date. To set an expiration, the current user must be authorized by the -ADMIN ACL. Returns true for success and false for failure. - -=item flag_clear(TYPE, NAME, FLAG) - -Clears the flag FLAG on the object identified by TYPE and NAME. To clear -a flag, the current user must be authorized by the ADMIN ACL or the flags -ACL on the object. - -=item flag_set(TYPE, NAME, FLAG) - -Sets the flag FLAG on the object identified by TYPE and NAME. To set a -flag, the current user must be authorized by the ADMIN ACL or the flags -ACL on the object. - -=item get(TYPE, NAME) - -Returns the data associated with the object identified by TYPE and NAME. -Depending on the object TYPE, this may generate new data and invalidate -any existing data or it may return data previously stored or generated. -Note that this data may be binary and may contain nul characters. To get -an object, the current user must either be authorized by the owner ACL or -authorized by the get ACL; however, if the get ACL is set, the owner ACL -will not be checked. Being a member of the ADMIN ACL does not provide any -special privileges to get objects. - -Returns undef on failure. The caller should be careful to distinguish -between undef and the empty string, which is valid object data. - -=item history(TYPE, NAME) - -Returns (as a string) the human-readable history of the object identified -by TYPE and NAME, or undef on error. To see the object history, the -current user must be a member of the ADMIN ACL, authorized by the show -ACL, or authorized by the owner ACL; however, if the show ACL is set, the -owner ACL will not be checked. - -=item owner(TYPE, NAME [, OWNER]) - -Gets or sets the owner for the object identified by TYPE and NAME. If -OWNER is not given, returns the current owner as a numeric ACL ID or undef -if no owner is set or on an error. To distinguish between an owner that -isn't set and a failure to retrieve the owner, the caller should call -error() after an undef return. If error() also returns undef, that ACL -wasn't set; otherwise, error() will return the error message. - -If OWNER is given, sets the owner to OWNER, which may be either the name -of an ACL or a numeric ACL ID. To set an owner, the current user must be -authorized by the ADMIN ACL. Returns true for success and false for -failure. - -The owner of an object is permitted to get, store, and show that object, -but cannot destroy or set flags on that object without being listed on -those ACLs as well. - -=item schema() - -Returns the DBIx::Class schema object. - -=item show(TYPE, NAME) - -Returns (as a string) a human-readable representation of the metadata -stored for the object identified by TYPE and NAME, or undef on error. -Included is the metadata and entries of any ACLs associated with the -object. To show an object, the current user must be a member of the ADMIN -ACL, authorized by the show ACL, or authorized by the owner ACL; however, -if the show ACL is set, the owner ACL will not be checked. - -=item store(TYPE, NAME, DATA) - -Stores DATA for the object identified with TYPE and NAME for later -retrieval with get. Not all object types support this. Note that DATA -may be binary and may contain nul characters. To store an object, the -current user must either be authorized by the owner ACL or authorized by -the store ACL; however, if the store ACL is set, the owner ACL is not -checked. Being a member of the ADMIN ACL does not provide any special -privileges to store objects. Returns true on success and false on -failure. - -=back - -=head1 SEE ALSO - -wallet-backend(8) - -This module is part of the wallet system. The current version is -available from L. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/perl/lib/Wallet/ACL.pm b/perl/lib/Wallet/ACL.pm new file mode 100644 index 0000000..808be3c --- /dev/null +++ b/perl/lib/Wallet/ACL.pm @@ -0,0 +1,657 @@ +# Wallet::ACL -- Implementation of ACLs in the wallet system. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2010, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::ACL; +require 5.006; + +use strict; +use vars qw($VERSION); + +use DBI; +use POSIX qw(strftime); + +# 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.07'; + +############################################################################## +# Constructors +############################################################################## + +# Initialize a new ACL from the database. Verify that the ACL already exists +# in the database and, if so, return a new blessed object. Stores the ACL ID +# and the database handle to use for future operations. If the object +# doesn't exist, throws an exception. +sub new { + my ($class, $id, $schema) = @_; + my (%search, $data, $name); + if ($id =~ /^\d+\z/) { + $search{ac_id} = $id; + } else { + $search{ac_name} = $id; + } + eval { + $data = $schema->resultset('Acl')->find (\%search); + }; + if ($@) { + die "cannot search for ACL $id: $@\n"; + } elsif (not defined $data) { + die "ACL $id not found\n"; + } + my $self = { + schema => $schema, + id => $data->ac_id, + name => $data->ac_name, + }; + bless ($self, $class); + return $self; +} + +# Create a new ACL in the database with the given name and return a new +# blessed ACL object for it. Stores the database handle to use and the ID of +# the newly created ACL in the object. On failure, throws an exception. +sub create { + my ($class, $name, $schema, $user, $host, $time) = @_; + if ($name =~ /^\d+\z/) { + die "ACL name may not be all numbers\n"; + } + $time ||= time; + my $id; + eval { + my $guard = $schema->txn_scope_guard; + + # Create the new record. + my %record = (ac_name => $name); + my $acl = $schema->resultset('Acl')->create (\%record); + $id = $acl->ac_id; + die "unable to retrieve new ACL ID" unless defined $id; + + # Add to the history table. + my $date = strftime ('%Y-%m-%d %T', localtime $time); + %record = (ah_acl => $id, + ah_action => 'create', + ah_by => $user, + ah_from => $host, + ah_on => $date); + my $history = $schema->resultset('AclHistory')->create (\%record); + die "unable to create new history entry" unless defined $history; + + $guard->commit; + }; + if ($@) { + die "cannot create ACL $name: $@\n"; + } + my $self = { + schema => $schema, + id => $id, + name => $name, + }; + bless ($self, $class); + return $self; +} + +############################################################################## +# Utility functions +############################################################################## + +# Set or return the error stashed in the object. +sub error { + my ($self, @error) = @_; + if (@error) { + my $error = join ('', @error); + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + $self->{error} = $error; + } + return $self->{error}; +} + +# Returns the ID of an ACL. +sub id { + my ($self) = @_; + return $self->{id}; +} + +# Returns the name of the ACL. +sub name { + my ($self)= @_; + return $self->{name}; +} + +# Given an ACL scheme, return the mapping to a class by querying the +# database, or undef if no mapping exists. Also load the relevant module. +sub scheme_mapping { + my ($self, $scheme) = @_; + my $class; + eval { + my %search = (as_name => $scheme); + my $scheme_rec = $self->{schema}->resultset('AclScheme') + ->find (\%search); + $class = $scheme_rec->as_class; + }; + if ($@) { + $self->error ($@); + return; + } + if (defined $class) { + eval "require $class"; + if ($@) { + $self->error ($@); + return; + } + } + return $class; +} + +# Record a change to an ACL. Takes the type of change, the scheme and +# identifier of the entry, and the trace information (user, host, and time). +# This function does not commit and does not catch exceptions. It should +# normally be called as part of a larger transaction that implements the +# change and should be committed with that change. +sub log_acl { + my ($self, $action, $scheme, $identifier, $user, $host, $time) = @_; + unless ($action =~ /^(add|remove)\z/) { + die "invalid history action $action"; + } + my %record = (ah_acl => $self->{id}, + ah_action => $action, + ah_scheme => $scheme, + ah_identifier => $identifier, + ah_by => $user, + ah_from => $host, + ah_on => strftime ('%Y-%m-%d %T', localtime $time)); + $self->{schema}->resultset('AclHistory')->create (\%record); +} + +############################################################################## +# ACL manipulation +############################################################################## + +# Changes the human-readable name of the ACL. Note that this operation is not +# logged since it isn't a change to any of the data stored in the wallet. +# Returns true on success, false on failure. +sub rename { + my ($self, $name) = @_; + if ($name =~ /^\d+\z/) { + $self->error ("ACL name may not be all numbers"); + return; + } + eval { + my $guard = $self->{schema}->txn_scope_guard; + my %search = (ac_id => $self->{id}); + my $acls = $self->{schema}->resultset('Acl')->find (\%search); + $acls->ac_name ($name); + $acls->update; + $guard->commit; + }; + if ($@) { + $self->error ("cannot rename ACL $self->{id} to $name: $@"); + return; + } + $self->{name} = $name; + return 1; +} + +# Destroy the ACL, deleting it out of the database. Returns true on success, +# false on failure. +# +# Checks to ensure that the ACL is not referenced anywhere in the database, +# since we may not have referential integrity enforcement. It's not clear +# that this is the right place to do this; it's a bit of an abstraction +# violation, since it's a query against the object table. +sub destroy { + my ($self, $user, $host, $time) = @_; + $time ||= time; + eval { + my $guard = $self->{schema}->txn_scope_guard; + + # Make certain no one is using the ACL. + my @search = ({ ob_owner => $self->{id} }, + { ob_acl_get => $self->{id} }, + { ob_acl_store => $self->{id} }, + { ob_acl_show => $self->{id} }, + { ob_acl_destroy => $self->{id} }, + { ob_acl_flags => $self->{id} }); + my @entries = $self->{schema}->resultset('Object')->search (\@search); + if (@entries) { + my ($entry) = @entries; + die "ACL in use by ".$entry->ob_type.":".$entry->ob_name; + } + + # Delete any entries (there may or may not be any). + my %search = (ae_id => $self->{id}); + @entries = $self->{schema}->resultset('AclEntry')->search(\%search); + for my $entry (@entries) { + $entry->delete; + } + + # There should definitely be an ACL record to delete. + %search = (ac_id => $self->{id}); + my $entry = $self->{schema}->resultset('Acl')->find(\%search); + $entry->delete if defined $entry; + + # Create new history line for the deletion. + my %record = (ah_acl => $self->{id}, + ah_action => 'destroy', + ah_by => $user, + ah_from => $host, + ah_on => strftime ('%Y-%m-%d %T', localtime $time)); + $self->{schema}->resultset('AclHistory')->create (\%record); + $guard->commit; + }; + if ($@) { + $self->error ("cannot destroy ACL $self->{id}: $@"); + return; + } + return 1; +} + +############################################################################## +# ACL entry manipulation +############################################################################## + +# Add an ACL entry to this ACL. Returns true on success and false on failure. +sub add { + my ($self, $scheme, $identifier, $user, $host, $time) = @_; + $time ||= time; + unless ($self->scheme_mapping ($scheme)) { + $self->error ("unknown ACL scheme $scheme"); + return; + } + eval { + my $guard = $self->{schema}->txn_scope_guard; + my %record = (ae_id => $self->{id}, + ae_scheme => $scheme, + ae_identifier => $identifier); + my $entry = $self->{schema}->resultset('AclEntry')->create (\%record); + $self->log_acl ('add', $scheme, $identifier, $user, $host, $time); + $guard->commit; + }; + if ($@) { + $self->error ("cannot add $scheme:$identifier to $self->{id}: $@"); + return; + } + return 1; +} + +# Remove an ACL entry to this ACL. Returns true on success and false on +# failure. Detect the case where no such row exists before doing the delete +# so that we can provide a good error message. +sub remove { + my ($self, $scheme, $identifier, $user, $host, $time) = @_; + $time ||= time; + eval { + my $guard = $self->{schema}->txn_scope_guard; + my %search = (ae_id => $self->{id}, + ae_scheme => $scheme, + ae_identifier => $identifier); + my $entry = $self->{schema}->resultset('AclEntry')->find (\%search); + unless (defined $entry) { + die "entry not found in ACL\n"; + } + $entry->delete; + $self->log_acl ('remove', $scheme, $identifier, $user, $host, $time); + $guard->commit; + }; + if ($@) { + my $entry = "$scheme:$identifier"; + $self->error ("cannot remove $entry from $self->{id}: $@"); + return; + } + return 1; +} + +############################################################################## +# ACL checking +############################################################################## + +# List all of the entries in an ACL. Returns an array of tuples, each of +# which contains a scheme and identifier, or an array containing undef on +# error. Sets the internal error string on error. +sub list { + my ($self) = @_; + undef $self->{error}; + my @entries; + eval { + my $guard = $self->{schema}->txn_scope_guard; + my %search = (ae_id => $self->{id}); + my @entry_recs = $self->{schema}->resultset('AclEntry') + ->search (\%search); + for my $entry (@entry_recs) { + push (@entries, [ $entry->ae_scheme, $entry->ae_identifier ]); + } + $guard->commit; + }; + if ($@) { + $self->error ("cannot retrieve ACL $self->{id}: $@"); + return; + } else { + return @entries; + } +} + +# Return as a string a human-readable description of an ACL, including its +# membership. This method is only for human-readable output; use the list() +# method if you are using the results in other code. Returns undef on +# failure. +sub show { + my ($self) = @_; + my @entries = $self->list; + if (not @entries and $self->error) { + return; + } + my $name = $self->name; + my $id = $self->id; + my $output = "Members of ACL $name (id: $id) are:\n"; + for my $entry (sort { $$a[0] cmp $$b[0] or $$a[1] cmp $$b[1] } @entries) { + my ($scheme, $identifier) = @$entry; + $output .= " $scheme $identifier\n"; + } + return $output; +} + +# Return as a string the history of an ACL. Returns undef on failure. +sub history { + my ($self) = @_; + my $output = ''; + eval { + my $guard = $self->{schema}->txn_scope_guard; + my %search = (ah_acl => $self->{id}); + my %options = (order_by => 'ah_on'); + my @data = $self->{schema}->resultset('AclHistory') + ->search (\%search, \%options); + for my $data (@data) { + $output .= sprintf ("%s %s ", $data->ah_on->ymd, + $data->ah_on->hms); + if ($data->ah_action eq 'add' || $data->ah_action eq 'remove') { + $output .= sprintf ("%s %s %s", $data->ah_action, + $data->ah_scheme, $data->ah_identifier); + } else { + $output .= $data->ah_action; + } + $output .= sprintf ("\n by %s from %s\n", $data->ah_by, + $data->ah_from); + } + $guard->commit; + }; + if ($@) { + $self->error ("cannot read history for $self->{id}: $@"); + return; + } + return $output; +} + +# Given a principal, a scheme, and an identifier, check whether that ACL +# scheme and identifier grant access to that principal. Return 1 if access +# was granted, 0 if access was deined, and undef on some error. On error, the +# error message is also added to the check_errors variable. This method is +# internal to the class. +# +# Maintain ACL verifiers for all schemes we've seen in the local %verifier +# hash so that we can optimize repeated ACL checks. +{ + my %verifier; + sub check_line { + my ($self, $principal, $scheme, $identifier) = @_; + unless ($verifier{$scheme}) { + my $class = $self->scheme_mapping ($scheme); + unless ($class) { + push (@{ $self->{check_errors} }, "unknown scheme $scheme"); + return; + } + $verifier{$scheme} = $class->new; + unless (defined $verifier{$scheme}) { + push (@{ $self->{check_errors} }, "cannot verify $scheme"); + return; + } + } + my $result = ($verifier{$scheme})->check ($principal, $identifier); + if (not defined $result) { + push (@{ $self->{check_errors} }, ($verifier{$scheme})->error); + return; + } else { + return $result; + } + } +} + +# Given a principal, check whether it should be granted access according to +# this ACL. Returns 1 if access was granted, 0 if access was denied, and +# undef on some error. Errors from ACL verifiers do not cause an error +# return, but are instead accumulated in the check_errors variable returned by +# the check_errors() method. +sub check { + my ($self, $principal) = @_; + unless ($principal) { + $self->error ('no principal specified'); + return; + } + my @entries = $self->list; + return if (not @entries and $self->error); + my %verifier; + $self->{check_errors} = []; + for my $entry (@entries) { + my ($scheme, $identifier) = @$entry; + my $result = $self->check_line ($principal, $scheme, $identifier); + return 1 if $result; + } + return 0; +} + +# Returns the errors from the last ACL verification as an array in array +# context or as a string with newlines after each error in a scalar context. +sub check_errors { + my ($self) = @_; + my @errors; + if ($self->{check_errors}) { + @errors = @{ $self->{check_errors} }; + } + return wantarray ? @errors : join ("\n", @errors, ''); +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +Wallet::ACL - Implementation of ACLs in the wallet system + +=for stopwords +ACL DBH metadata HOSTNAME DATETIME timestamp Allbery verifier verifiers + +=head1 SYNOPSIS + + my $acl = Wallet::ACL->create ('group:sysadmin'); + $acl->rename ('group:unix'); + $acl->add ('krb5', 'alice@EXAMPLE.COM', $admin, $host); + $acl->add ('krb5', 'bob@EXAMPLE.COM', $admin, $host); + if ($acl->check ($user)) { + print "Permission granted\n"; + warn scalar ($acl->check_errors) if $acl->check_errors; + } + $acl->remove ('krb5', 'bob@EXAMPLE.COM', $admin, $host); + my @entries = $acl->list; + my $summary = $acl->show; + my $history = $acl->history; + $acl->destroy ($admin, $host); + +=head1 DESCRIPTION + +Wallet::ACL implements the ACL system for the wallet: the methods to +create, find, rename, and destroy ACLs; the methods to add and remove +entries from an ACL; and the methods to list the contents of an ACL and +check a principal against it. + +An ACL is a list of zero or more ACL entries, each of which consists of a +scheme and an identifier. Each scheme is associated with a verifier +module that checks Kerberos principals against identifiers for that scheme +and returns whether the principal should be permitted access by that +identifier. The interpretation of the identifier is entirely left to the +scheme. This module maintains the ACLs and dispatches check operations to +the appropriate verifier module. + +Each ACL is identified by a human-readable name and a persistent unique +numeric identifier. The numeric identifier (ID) should be used to refer +to the ACL so that it can be renamed as needed without breaking external +references. + +=head1 CLASS METHODS + +=over 4 + +=item new(ACL, SCHEMA) + +Instantiate a new ACL object with the given ACL ID or name. Takes the +Wallet::Schema object to use for retrieving metadata from the wallet +database. Returns a new ACL object if the ACL was found and throws an +exception if it wasn't or on any other error. + +=item create(NAME, SCHEMA, PRINCIPAL, HOSTNAME [, DATETIME]) + +Similar to new() in that it instantiates a new ACL object, but instead of +finding an existing one, creates a new ACL record in the database with the +given NAME. NAME must not be all-numeric, since that would conflict with +the automatically assigned IDs. Returns the new object on success and +throws an exception on failure. PRINCIPAL, HOSTNAME, and DATETIME are +stored as history information. PRINCIPAL should be the user who is +creating the ACL. If DATETIME isn't given, the current time is used. + +=back + +=head1 INSTANCE METHODS + +=over 4 + +=item add(SCHEME, INSTANCE, PRINCIPAL, HOSTNAME [, DATETIME]) + +Add the given ACL entry (given by SCHEME and INSTANCE) to this ACL. +Returns true on success and false on failure. On failure, the caller +should call error() to get the error message. PRINCIPAL, HOSTNAME, and +DATETIME are stored as history information. PRINCIPAL should be the user +who is adding the ACL entry. If DATETIME isn't given, the current time is +used. + +=item check(PRINCIPAL) + +Checks whether the given PRINCIPAL should be allowed access given ACL. +Returns 1 if access was granted, 0 if access is declined, and undef on +error. On error, the caller should call error() to get the error text. +Any errors found by the individual ACL verifiers can be retrieved by +calling check_errors(). Errors from individual ACL verifiers will not +result in an error return from check(); instead, the check will continue +with the next entry in the ACL. + +check() returns success as soon as an entry in the ACL grants access to +PRINCIPAL. There is no provision for negative ACLs or exceptions. + +=item check_errors() + +Return (as a list in array context and a string with newlines between +errors and at the end of the last error in scalar context) the errors, if +any, returned by ACL verifiers for the last check operation. If there +were no errors from the last check() operation, returns the empty list in +array context and undef in scalar context. + +=item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) + +Destroys this ACL from the database. Note that this will fail if the ACL +is still referenced by any object; the ACL must be removed from all +objects first. Returns true on success and false on failure. On failure, +the caller should call error() to get the error message. PRINCIPAL, +HOSTNAME, and DATETIME are stored as history information. PRINCIPAL +should be the user who is destroying the ACL. If DATETIME isn't given, +the current time is used. + +=item 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. + +=item history() + +Returns the human-readable history of this ACL. Each action that changes +the ACL (not including changes to the name of the ACL) will be represented +by two lines. The first line will have a timestamp of the change followed +by a description of the change, and the second line will give the user who +made the change and the host from which the change was made. On failure, +returns undef, and the caller should call error() to get the error +message. + +=item id() + +Returns the numeric system-generated ID of this ACL. + +=item list() + +Returns all the entries of this ACL. The return value will be a list of +references to pairs of scheme and identifier. For example, for an ACL +containing two entries, both of scheme C and with values +C and C, list() would return: + + ([ 'krb5', 'alice@EXAMPLE.COM' ], [ 'krb5', 'bob@EXAMPLE.COM' ]) + +Returns the empty list on failure. To distinguish between this and the +ACL containing no entries, 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 name() + +Returns the human-readable name of this ACL. + +=item remove(SCHEME, INSTANCE, PRINCIPAL, HOSTNAME [, DATETIME]) + +Remove the given ACL line (given by SCHEME and INSTANCE) from this ACL. +Returns true on success and false on failure. On failure, the caller +should call error() to get the error message. PRINCIPAL, HOSTNAME, and +DATETIME are stored as history information. PRINCIPAL should be the user +who is removing the ACL entry. If DATETIME isn't given, the current time +is used. + +=item rename(NAME) + +Rename this ACL. This changes the name used for human convenience but not +the system-generated ACL ID that is used to reference this ACL. The new +NAME must not be all-numeric, since that would conflict with +system-generated ACL IDs. Returns true on success and false on failure. +On failure, the caller should call error() to get the error message. + +Note that rename() operations are not logged in the ACL history. + +=item show() + +Returns a human-readable description of this ACL, including its +membership. This method should only be used for display of the ACL to +humans. Use the list(), name(), and id() methods instead to get ACL +information for use in other code. On failure, returns undef, and the +caller should call error() to get the error message. + +=back + +=head1 SEE ALSO + +Wallet::ACL::Base(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/ACL/Base.pm b/perl/lib/Wallet/ACL/Base.pm new file mode 100644 index 0000000..b6e4ce3 --- /dev/null +++ b/perl/lib/Wallet/ACL/Base.pm @@ -0,0 +1,125 @@ +# Wallet::ACL::Base -- Parent class for wallet ACL verifiers. +# +# Written by Russ Allbery +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::ACL::Base; +require 5.006; + +use strict; +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'; + +############################################################################## +# Interface +############################################################################## + +# Creates a new persistant verifier, taking a database handle. This parent +# class just creates an empty object and ignores the handle. Child classes +# should override if there are necessary initialization tasks or if the handle +# will be used by the verifier. +sub new { + my $type = shift; + my $self = {}; + bless ($self, $type); + return $self; +} + +# The default check method denies all access. +sub check { + return 0; +} + +# Set or return the error stashed in the object. +sub error { + my ($self, @error) = @_; + if (@error) { + my $error = join ('', @error); + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + $self->{error} = $error; + } + return $self->{error}; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +ACL Allbery verifier verifiers + +=head1 NAME + +Wallet::ACL::Base - Generic parent class for wallet ACL verifiers + +=head1 SYNOPSIS + + package Wallet::ACL::Simple + @ISA = qw(Wallet::ACL::Base); + sub check { + my ($self, $principal, $acl) = @_; + return ($principal eq $acl) ? 1 : 0; + } + +=head1 DESCRIPTION + +Wallet::ACL::Base is the generic parent class for wallet ACL verifiers. +It provides default functions and behavior and all ACL verifiers should +inherit from it. It is not used directly. + +=head1 METHODS + +=over 4 + +=item new() + +Creates a new ACL verifier. The generic function provided here just +creates and blesses an object. + +=item check(PRINCIPAL, ACL) + +This method should always be overridden by child classes. The default +implementation just declines all access. + +=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. + +For the convenience of child classes, this method can also be called with +one or more error strings. If so, those strings are concatenated +together, trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is +stored as the error. Only child classes should call this method with an +error string. + +=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. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/ACL/Krb5.pm b/perl/lib/Wallet/ACL/Krb5.pm new file mode 100644 index 0000000..ed0b7df --- /dev/null +++ b/perl/lib/Wallet/ACL/Krb5.pm @@ -0,0 +1,125 @@ +# Wallet::ACL::Krb5 -- Wallet Kerberos v5 principal ACL verifier. +# +# Written by Russ Allbery +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::ACL::Krb5; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Wallet::ACL::Base; + +@ISA = qw(Wallet::ACL::Base); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.02'; + +############################################################################## +# Interface +############################################################################## + +# The most trivial ACL verifier. Returns true if the provided principal +# matches the ACL. +sub check { + my ($self, $principal, $acl) = @_; + unless ($principal) { + $self->error ('no principal specified'); + return; + } + unless ($acl) { + $self->error ('malformed krb5 ACL'); + return; + } + return ($principal eq $acl) ? 1 : 0; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +ACL krb5 Allbery verifier + +=head1 NAME + +Wallet::ACL::Krb5 - Simple wallet ACL verifier for Kerberos principals + +=head1 SYNOPSIS + + my $verifier = Wallet::ACL::Krb5->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::Krb5 is the simplest wallet ACL verifier, used to verify ACL +lines of type C. The value of such an ACL is a simple Kerberos +principal in its text display form, and the ACL grants access to a given +principal if and only if the principal exactly matches the ACL. + +=head1 METHODS + +=over 4 + +=item new() + +Creates a new ACL verifier. For this verifier, there is no setup work. + +=item check(PRINCIPAL, ACL) + +Returns true if PRINCIPAL matches ACL, false if not, and undef on an error +(see L<"DIAGNOSTICS"> below). + +=item error() + +Returns the error if check() returned undef. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item malformed krb5 ACL + +The ACL parameter to check() was malformed. Currently, this error is only +given if ACL is undefined or the empty string. + +=item no principal specified + +The PRINCIPAL parameter to check() was undefined or the empty string. + +=back + +=head1 SEE ALSO + +Wallet::ACL(3), Wallet::ACL::Base(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/ACL/Krb5/Regex.pm b/perl/lib/Wallet/ACL/Krb5/Regex.pm new file mode 100644 index 0000000..30f5527 --- /dev/null +++ b/perl/lib/Wallet/ACL/Krb5/Regex.pm @@ -0,0 +1,133 @@ +# Wallet::ACL::Krb5::Regex -- Wallet Kerberos v5 principal regex ACL verifier +# +# Written by Russ Allbery +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::ACL::Krb5::Regex; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Wallet::ACL::Krb5; + +@ISA = qw(Wallet::ACL::Krb5); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.01'; + +############################################################################## +# Interface +############################################################################## + +# Returns true if the Perl regular expression specified by the ACL matches +# the provided Kerberos principal. +sub check { + my ($self, $principal, $acl) = @_; + unless ($principal) { + $self->error ('no principal specified'); + return; + } + unless ($acl) { + $self->error ('no ACL specified'); + return; + } + my $regex = eval { qr/$acl/ }; + if ($@) { + $self->error ('malformed krb5-regex ACL'); + return; + } + return ($principal =~ m/$regex/) ? 1 : 0; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +ACL krb5-regex Durkacz Allbery verifier + +=head1 NAME + +Wallet::ACL::Krb5::Regex - Regex wallet ACL verifier for Kerberos principals + +=head1 SYNOPSIS + + my $verifier = Wallet::ACL::Krb5::Regex->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::Krb5::Regex is the wallet ACL verifier used to verify ACL +lines of type C. The value of such an ACL is a Perl regular +expression, and the ACL grants access to a given Kerberos principal if and +only if the regular expression matches that principal. + +=head1 METHODS + +=over 4 + +=item new() + +Creates a new ACL verifier. For this verifier, there is no setup work. + +=item check(PRINCIPAL, ACL) + +Returns true if the Perl regular expression specified by the ACL matches the +PRINCIPAL, false if not, and undef on an error (see L<"DIAGNOSTICS"> below). + +=item error() + +Returns the error if check() returned undef. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item malformed krb5-regex ACL + +The ACL parameter to check() was a malformed Perl regular expression. + +=item no principal specified + +The PRINCIPAL parameter to check() was undefined or the empty string. + +=item no ACL specified + +The ACL parameter to check() was undefined or the empty string. + +=back + +=head1 SEE ALSO + +Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::ACL::Krb5(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Ian Durkacz + +=cut diff --git a/perl/lib/Wallet/ACL/LDAP/Attribute.pm b/perl/lib/Wallet/ACL/LDAP/Attribute.pm new file mode 100644 index 0000000..aea8a72 --- /dev/null +++ b/perl/lib/Wallet/ACL/LDAP/Attribute.pm @@ -0,0 +1,263 @@ +# Wallet::ACL::LDAP::Attribute -- Wallet LDAP attribute ACL verifier. +# +# Written by Russ Allbery +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::ACL::LDAP::Attribute; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Authen::SASL (); +use Net::LDAP qw(LDAP_COMPARE_TRUE); +use Wallet::ACL::Base; +use Wallet::Config; + +@ISA = qw(Wallet::ACL::Base); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.01'; + +############################################################################## +# Interface +############################################################################## + +# Create a new persistant verifier. Load the Net::LDAP module and open a +# persistant LDAP server connection that we'll use for later calls. +sub new { + my $type = shift; + my $host = $Wallet::Config::LDAP_HOST; + my $base = $Wallet::Config::LDAP_BASE; + unless ($host and defined ($base) and $Wallet::Config::LDAP_CACHE) { + die "LDAP attribute ACL support not configured\n"; + } + + # Ensure the required Perl modules are available and bind to the directory + # server. Catch any errors with a try/catch block. + my $ldap; + eval { + local $ENV{KRB5CCNAME} = $Wallet::Config::LDAP_CACHE; + my $sasl = Authen::SASL->new (mechanism => 'GSSAPI'); + $ldap = Net::LDAP->new ($host, onerror => 'die'); + my $mesg = eval { $ldap->bind (undef, sasl => $sasl) }; + }; + if ($@) { + my $error = $@; + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + die "LDAP attribute ACL support not available: $error\n"; + } + + # We successfully bound, so create our object and return it. + my $self = { ldap => $ldap }; + bless ($self, $type); + return $self; +} + +# Check whether a given principal has the required LDAP attribute. We first +# map the principal to a DN by doing a search for that principal (and bailing +# if we get more than one entry). Then, we do a compare to see if that DN has +# the desired attribute and value. +# +# If the ldap_map_principal sub is defined in Wallet::Config, call it on the +# principal first to map it to the value for which we'll search. +# +# The connection is configured to die on any error, so we do all the work in a +# try/catch block to report errors. +sub check { + my ($self, $principal, $acl) = @_; + undef $self->{error}; + unless ($principal) { + $self->error ('no principal specified'); + return; + } + my ($attr, $value); + if ($acl) { + ($attr, $value) = split ('=', $acl, 2); + } + unless (defined ($attr) and defined ($value)) { + $self->error ('malformed ldap-attr ACL'); + return; + } + my $ldap = $self->{ldap}; + + # Map the principal name to an attribute value for our search if we're + # doing a custom mapping. + if (defined &Wallet::Config::ldap_map_principal) { + eval { $principal = Wallet::Config::ldap_map_principal ($principal) }; + if ($@) { + $self->error ("mapping principal to LDAP failed: $@"); + return; + } + } + + # Now, map the user to a DN by doing a search. + my $entry; + eval { + my $fattr = $Wallet::Config::LDAP_FILTER_ATTR || 'krb5PrincipalName'; + my $filter = "($fattr=$principal)"; + my $base = $Wallet::Config::LDAP_BASE; + my @options = (base => $base, filter => $filter, attrs => [ 'dn' ]); + my $search = $ldap->search (@options); + if ($search->count == 1) { + $entry = $search->pop_entry; + } elsif ($search->count > 1) { + die $search->count . " LDAP entries found for $principal"; + } + }; + if ($@) { + $self->error ("cannot search for $principal in LDAP: $@"); + return; + } + return 0 unless $entry; + + # We have a user entry. We can now check whether that user has the + # desired attribute and value. + my $result; + eval { + my $mesg = $ldap->compare ($entry, attr => $attr, value => $value); + $result = $mesg->code; + }; + if ($@) { + $self->error ("cannot check LDAP attribute $attr for $principal: $@"); + return; + } + return ($result == LDAP_COMPARE_TRUE) ? 1 : 0; +} + +1; + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +ACL Allbery verifier LDAP PRINCIPAL's DN ldap-attr + +=head1 NAME + +Wallet::ACL::LDAP::Attribute - Wallet ACL verifier for LDAP attribute compares + +=head1 SYNOPSIS + + my $verifier = Wallet::ACL::LDAP::Attribute->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 checks whether the LDAP record for the entry +corresponding to a principal contains an attribute with a particular +value. It is used to verify ACL lines of type C. The value of +such an 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 has that attribute set to that value. + +To use this object, several configuration parameters must be set. See +L for details on those configuration parameters and +information about how to set wallet configuration. + +=head1 METHODS + +=over 4 + +=item new() + +Creates a new ACL verifier. Opens and binds the connection to the LDAP +server. + +=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 its LDAP entry contains +that attribute with that value. + +=item error() + +Returns the error if check() returned undef. + +=back + +=head1 DIAGNOSTICS + +The new() method may fail with one of the following exceptions: + +=over 4 + +=item LDAP attribute ACL support not available: %s + +Attempting to connect or bind to the LDAP server failed. + +=item LDAP attribute ACL support not configured + +The required configuration parameters were not set. See Wallet::Config(3) +for the required configuration parameters and how to set them. + +=back + +Verifying an LDAP attribute ACL may fail with the following errors +(returned by the error() method): + +=over 4 + +=item cannot check LDAP attribute %s for %s: %s + +The LDAP compare to check for the required attribute failed. The +attribute may have been misspelled, or there may be LDAP directory +permission issues. This error indicates that PRINCIPAL's entry was +located in LDAP, but the check failed during the compare to verify the +attribute value. + +=item cannot search for %s in LDAP: %s + +Searching for PRINCIPAL (possibly after ldap_map_principal() mapping) +failed. This is often due to LDAP directory permissions issues. This +indicates a failure during the mapping of PRINCIPAL to an LDAP DN. + +=item malformed ldap-attr ACL + +The ACL parameter to check() was malformed. Usually this means that +either the attribute or the value were empty or the required C<=> sign +separating them was missing. + +=item mapping principal to LDAP failed: %s + +There was an ldap_map_principal() function defined in the wallet +configuration, but calling it for the PRINCIPAL argument failed. + +=item no principal specified + +The PRINCIPAL parameter to check() was undefined or the empty string. + +=back + +=head1 SEE ALSO + +Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::Config(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/ACL/NetDB.pm b/perl/lib/Wallet/ACL/NetDB.pm new file mode 100644 index 0000000..b76d4ed --- /dev/null +++ b/perl/lib/Wallet/ACL/NetDB.pm @@ -0,0 +1,267 @@ +# Wallet::ACL::NetDB -- Wallet NetDB role ACL verifier. +# +# Written by Russ Allbery +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::ACL::NetDB; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Wallet::ACL::Base; +use Wallet::Config; + +@ISA = qw(Wallet::ACL::Base); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.05'; + +############################################################################## +# Interface +############################################################################## + +# Creates a new persistant verifier. Load the Net::Remctl module and open a +# persistant remctl connection that we'll use for later calls. +sub new { + my $type = shift; + my $host = $Wallet::Config::NETDB_REMCTL_HOST; + unless ($host and $Wallet::Config::NETDB_REMCTL_CACHE) { + die "NetDB ACL support not configured\n"; + } + eval { require Net::Remctl }; + if ($@) { + my $error = $@; + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + die "NetDB ACL support not available: $error\n"; + } + local $ENV{KRB5CCNAME} = $Wallet::Config::NETDB_REMCTL_CACHE; + my $remctl = Net::Remctl->new; + + # Net::Remctl 2.12 and later will support passing in an empty string for + # the principal. Until then, be careful not to pass principal unless it + # was specified. + my $port = $Wallet::Config::NETDB_REMCTL_PORT || 0; + my $principal = $Wallet::Config::NETDB_REMCTL_PRINCIPAL; + my $status; + if (defined $principal) { + $status = $remctl->open ($host, $port, $principal); + } else { + $status = $remctl->open ($host, $port); + } + unless ($status) { + die "cannot connect to NetDB remctl interface: ", $remctl->error, "\n"; + } + my $self = { remctl => $remctl }; + bless ($self, $type); + return $self; +} + +# Check whether the given principal has one of the user, administrator, or +# admin team roles in NetDB for the given host. Returns 1 if it does, 0 if it +# doesn't, and undef, setting the error, if there's some failure in making the +# remctl call. +sub check { + my ($self, $principal, $acl) = @_; + unless ($principal) { + $self->error ('no principal specified'); + return; + } + unless ($acl) { + $self->error ('malformed netdb ACL'); + return; + } + my $remctl = $self->{remctl}; + if ($Wallet::Config::NETDB_REALM) { + $principal =~ s/\@\Q$Wallet::Config::NETDB_REALM\E\z//; + } + unless ($remctl->command ('netdb', 'node-roles', $principal, $acl)) { + $self->error ('cannot check NetDB ACL: ' . $remctl->error); + return; + } + my ($roles, $output, $status, $error); + do { + $output = $remctl->output; + if ($output->type eq 'output') { + if ($output->stream == 1) { + $roles .= $output->data; + } else { + $error .= $output->data; + } + } elsif ($output->type eq 'error') { + $self->error ('cannot check NetDB ACL: ' . $output->data); + return; + } elsif ($output->type eq 'status') { + $status = $output->status; + } else { + $self->error ('malformed NetDB remctl token: ' . $output->type); + return; + } + } while ($output->type eq 'output'); + if ($status == 0) { + $roles ||= ''; + my @roles = split (' ', $roles); + for my $role (@roles) { + return 1 if $role eq 'admin'; + return 1 if $role eq 'team'; + return 1 if $role eq 'user'; + } + return 0; + } else { + if ($error) { + chomp $error; + $error =~ s/\n/ /g; + $self->error ("error checking NetDB ACL: $error"); + } else { + $self->error ("error checking NetDB ACL"); + } + return; + } +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +ACL NetDB remctl DNS DHCP Allbery netdb verifier + +=head1 NAME + +Wallet::ACL::NetDB - Wallet ACL verifier for NetDB roles + +=head1 SYNOPSIS + + my $verifier = Wallet::ACL::NetDB->new; + my $status = $verifier->check ($principal, $node); + 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::NetDB checks a principal against the NetDB roles for a given +host. It is used to verify ACL lines of type C. The value of such +an ACL is a node, and the ACL grants access to a given principal if and +only if that principal has one of the roles user, admin, or team for that +node. + +To use this object, several configuration parameters must be set. See +L for details on those configuration parameters and +information about how to set wallet configuration. + +=head1 METHODS + +=over 4 + +=item new() + +Creates a new ACL verifier. Opens the remctl connection to the NetDB +server and authenticates. + +=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 is a node, +and PRINCIPAL will be granted access if it (with the realm stripped off if +configured) has the user, admin, or team role for that node. + +=item error() + +Returns the error if check() returned undef. + +=back + +=head1 DIAGNOSTICS + +The new() method may fail with one of the following exceptions: + +=over 4 + +=item NetDB ACL support not available: %s + +The Net::Remctl Perl module, required for NetDB ACL support, could not be +loaded. + +=item NetDB ACL support not configured + +The required configuration parameters were not set. See Wallet::Config(3) +for the required configuration parameters and how to set them. + +=item cannot connect to NetDB remctl interface: %s + +Connecting to the NetDB remctl interface failed with the given error +message. + +=back + +Verifying a NetDB ACL may fail with the following errors (returned by the +error() method): + +=over 4 + +=item cannot check NetDB ACL: %s + +Issuing the remctl command to get the roles for the given principal failed +or returned an error. + +=item error checking NetDB ACL: %s + +The NetDB remctl interface that returns the roles for a user returned an +error message or otherwise returned failure. + +=item malformed netdb ACL + +The ACL parameter to check() was malformed. Currently, this error is only +given if ACL is undefined or the empty string. + +=item malformed NetDB remctl token: %s + +The Net::Remctl Perl library returned a malformed token. This should +never happen and indicates a bug in Net::Remctl. + +=item no principal specified + +The PRINCIPAL parameter to check() was undefined or the empty string. + +=back + +=head1 CAVEATS + +The list of possible NetDB roles that should be considered sufficient to +grant access is not currently configurable. + +=head1 SEE ALSO + +Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3), Wallet::Config(3), +wallet-backend(8) + +NetDB is a free software system for managing DNS, DHCP, and related +machine information for large organizations. For more information on +NetDB, see L. + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/ACL/NetDB/Root.pm b/perl/lib/Wallet/ACL/NetDB/Root.pm new file mode 100644 index 0000000..6c95c6e --- /dev/null +++ b/perl/lib/Wallet/ACL/NetDB/Root.pm @@ -0,0 +1,128 @@ +# Wallet::ACL::NetDB::Root -- Wallet NetDB role ACL verifier (root instances). +# +# Written by Russ Allbery +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::ACL::NetDB::Root; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Wallet::ACL::NetDB; +use Wallet::Config; + +@ISA = qw(Wallet::ACL::NetDB); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.02'; + +############################################################################## +# Interface +############################################################################## + +# Override the check method of Wallet::ACL::NetDB 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) = @_; + 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 NetDB DNS DHCP Allbery verifier + +=head1 NAME + +Wallet::ACL::NetDB::Root - Wallet ACL verifier for NetDB roles (root instances) + +=head1 SYNOPSIS + + my $verifier = Wallet::ACL::NetDB::Root->new; + my $status = $verifier->check ($principal, $node); + 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::NetDB::Root works identically to Wallet::ACL::NetDB except +that it requires the principal to be a root instance (in other words, to +be in the form /root@) and strips the C portion +from the principal before checking against NetDB roles. As with the base +NetDB ACL verifier, the value of a C ACL is a node, and the +ACL grants access to a given principal if and only if the that principal +(with C stripped) has one of the roles user, admin, or team for +that node. + +To use this object, the same configuration parameters must be set as for +Wallet::ACL::NetDB. 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 is a node, +and PRINCIPAL will be granted access if it has an instance of C and +if (with C stripped off and the realm stripped off if configured) +has the user, admin, or team role for that node. + +=back + +=head1 DIAGNOSTICS + +Same as for Wallet::ACL::NetDB. + +=head1 CAVEATS + +The instance to strip is not currently configurable. + +The list of possible NetDB roles that should be considered sufficient to +grant access is not currently configurable. + +=head1 SEE ALSO + +Net::Remctl(3), Wallet::ACL(3), Wallet::ACL::Base(3), +Wallet::ACL::NetDB(3), Wallet::Config(3), wallet-backend(8) + +NetDB is a free software system for managing DNS, DHCP, and related +machine information for large organizations. For more information on +NetDB, see L. + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Admin.pm b/perl/lib/Wallet/Admin.pm new file mode 100644 index 0000000..3a05284 --- /dev/null +++ b/perl/lib/Wallet/Admin.pm @@ -0,0 +1,379 @@ +# Wallet::Admin -- Wallet system administrative interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010, 2011, 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Admin; +require 5.006; + +use strict; +use vars qw($VERSION); + +use Wallet::ACL; +use Wallet::Schema; + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.07'; + +# The last non-DBIx::Class version of Wallet::Schema. If a database has no +# DBIx::Class versioning, we artificially install this version number before +# starting the upgrade process so that the automated DBIx::Class upgrade will +# work properly. +our $BASE_VERSION = '0.07'; + +############################################################################## +# Constructor, destructor, and accessors +############################################################################## + +# Create a new wallet administrator object. Opens a connection to the +# database that will be used for all of the wallet configuration information. +# Throw an exception if anything goes wrong. +sub new { + my ($class) = @_; + my $schema = Wallet::Schema->connect; + my $self = { schema => $schema }; + bless ($self, $class); + return $self; +} + +# Returns the database handle (used mostly for testing). +sub dbh { + my ($self) = @_; + return $self->{schema}->storage->dbh; +} + +# Returns the DBIx::Class-based database schema object. +sub schema { + my ($self) = @_; + return $self->{schema}; +} + +# Set or return the error stashed in the object. +sub error { + my ($self, @error) = @_; + if (@error) { + my $error = join ('', @error); + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + $self->{error} = $error; + } + return $self->{error}; +} + +# Disconnect the database handle on object destruction to avoid warnings. +sub DESTROY { + my ($self) = @_; + $self->{schema}->storage->dbh->disconnect; +} + +############################################################################## +# Database initialization +############################################################################## + +# Initializes the database by populating it with our schema and then creates +# and returns a new wallet server object. This is used only for initial +# database creation. Takes the Kerberos principal who will be the default +# administrator so that we can create an initial administrator ACL. Returns +# true on success and false on failure, setting the object error. +sub initialize { + my ($self, $user) = @_; + + # Deploy the database schema from DDL files, if they exist. If not then + # we automatically get the database from the Schema modules. + $self->{schema}->deploy ({}, $Wallet::Config::DB_DDL_DIRECTORY); + if ($@) { + $self->error ($@); + return; + } + $self->default_data; + + # Create a default admin ACL. + my $acl = Wallet::ACL->create ('ADMIN', $self->{schema}, $user, + 'localhost'); + unless ($acl->add ('krb5', $user, $user, 'localhost')) { + $self->error ($acl->error); + return; + } + + return 1; +} + +# Load default data into various tables. We'd like to do this more directly +# in the schema definitions, but not yet seeing a good way to do that. +sub default_data { + my ($self) = @_; + + # 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' ], + ]); + warn "default AclScheme not installed" unless defined $r1; + + # types default rows. + my @record = ([ qw/ty_name ty_class/ ], + [ 'file', 'Wallet::Object::File' ], + [ 'keytab', 'Wallet::Object::Keytab' ], + [ 'wa-keyring', 'Wallet::Object::WAKeyring' ]); + ($r1) = $self->{schema}->resultset('Type')->populate (\@record); + warn "default Type not installed" unless defined $r1; + + # enctypes default rows. + @record = ([ qw/en_name/ ], + [ 'aes128-cts-hmac-sha1-96' ], + [ 'aes256-cts-hmac-sha1-96' ], + [ 'arcfour-hmac-md5' ], + [ 'des-cbc-crc' ], + [ 'des3-cbc-sha1' ]); + ($r1) = $self->{schema}->resultset('Enctype')->populate (\@record); + warn "default Enctype not installed" unless defined $r1; + + return 1; +} + +# The same as initialize, but also drops any existing tables first before +# creating the schema. Takes the same arguments. Returns true on success and +# false on failure. +sub reinitialize { + my ($self, $user) = @_; + return unless $self->destroy; + return $self->initialize ($user); +} + +# Drop the database, including all of its data. Returns true on success and +# false on failure. +sub destroy { + my ($self) = @_; + + # Get an actual DBI handle and use it to delete all tables. + my $dbh = $self->dbh; + my @tables = qw/acls acl_entries acl_history acl_schemes enctypes + flags keytab_enctypes keytab_sync objects object_history + sync_targets types dbix_class_schema_versions/; + for my $table (@tables) { + my $sql = "DROP TABLE IF EXISTS $table"; + $dbh->do ($sql); + } + + return 1; +} + +# Save a DDL of the database in every supported database server. Returns +# true on success and false on failure. +sub backup { + my ($self, $oldversion) = @_; + + my @dbs = qw/MySQL SQLite PostgreSQL/; + my $version = $Wallet::Schema::VERSION; + $self->{schema}->create_ddl_dir (\@dbs, $version, + $Wallet::Config::DB_DDL_DIRECTORY, + $oldversion); + + return 1; +} + +# Upgrade the database to the latest schema version. Returns true on success +# and false on failure. +sub upgrade { + my ($self) = @_; + + # Check to see if the database is versioned. If not, install the + # versioning table and default version. + if (!$self->{schema}->get_db_version) { + $self->{schema}->install ($BASE_VERSION); + } + + # Suppress warnings that actually are just informational messages. + local $SIG{__WARN__} = sub { + my ($warn) = @_; + return if $warn =~ m{Upgrade not necessary}; + return if $warn =~ m{Attempting upgrade}; + warn $warn; + }; + + # Perform the actual upgrade. + if ($self->{schema}->get_db_version) { + $self->{schema}->upgrade_directory ($Wallet::Config::DB_DDL_DIRECTORY); + eval { $self->{schema}->upgrade; }; + } + if ($@) { + $self->error ($@); + return; + } + + return 1; +} + +############################################################################## +# Object registration +############################################################################## + +# Given an object type and class name, add a new class mapping to that +# database for the given object type. This is used to register new object +# types. Returns true on success, false on failure, and sets the internal +# error on failure. +sub register_object { + my ($self, $type, $class) = @_; + eval { + my $guard = $self->{schema}->txn_scope_guard; + my %record = (ty_name => $type, + ty_class => $class); + $self->{schema}->resultset('Type')->create (\%record); + $guard->commit; + }; + if ($@) { + $self->error ("cannot register $class for $type: $@"); + return; + } + return 1; +} + +# Given an ACL verifier scheme and class name, add a new class mapping to that +# database for the given ACL verifier scheme. This is used to register new +# ACL schemes. Returns true on success, false on failure, and sets the +# internal error on failure. +sub register_verifier { + my ($self, $scheme, $class) = @_; + eval { + my $guard = $self->{schema}->txn_scope_guard; + my %record = (as_name => $scheme, + as_class => $class); + $self->{schema}->resultset('AclScheme')->create (\%record); + $guard->commit; + }; + if ($@) { + $self->error ("cannot register $class for $scheme: $@"); + return; + } + return 1; +} + +1; +__DATA__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +Wallet::Admin - Wallet system administrative interface + +=for stopwords +ACL hostname Allbery verifier + +=head1 SYNOPSIS + + use Wallet::Admin; + my $admin = Wallet::Admin->new; + unless ($admin->initialize ('user/admin@EXAMPLE.COM')) { + die $admin->error; + } + +=head1 DESCRIPTION + +Wallet::Admin implements the administrative interface to the wallet server +and database. It is normally instantiated and used by B, a +thin wrapper around this object that provides a command-line interface to +its actions. + +To use this object, several configuration variables must be set (at least +the database configuration). For information on those variables and how +to set them, see L. For more information on the normal +user interface to the wallet server, see L. + +=head1 CLASS METHODS + +=over 4 + +=item new() + +Creates a new wallet administrative object and connects to the database. +On any error, this method throws an exception. + +=back + +=head1 INSTANCE METHODS + +For all methods that can fail, the caller should call error() after a +failure to get the error message. + +=over 4 + +=item destroy () + +Destroys the database, deleting all of its data and all of the tables used +by the wallet server. Returns true on success and false on failure. + +=item 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. + +=item initialize(PRINCIPAL) + +Initializes the database as configured in Wallet::Config and loads the +wallet database schema. Then, creates an ACL with the name ADMIN and adds +an ACL entry of scheme C and instance PRINCIPAL to that ACL. This +bootstraps the authorization system and lets that Kerberos identity make +further changes to the ADMIN ACL and the rest of the wallet database. +Returns true on success and false on failure. + +initialize() uses C as the hostname and PRINCIPAL as the user +when logging the history of the ADMIN ACL creation and for any subsequent +actions on the object it returns. + +=item register_object (TYPE, CLASS) + +Register in the database a mapping from the object type TYPE to the class +CLASS. Returns true on success and false on failure (including when the +verifier is already registered). + +=item register_verifier (SCHEME, CLASS) + +Register in the database a mapping from the ACL scheme SCHEME to the class +CLASS. Returns true on success and false on failure (including when the +verifier is already registered). + +=item reinitialize (PRINCIPAL) + +Performs the same actions as initialize(), but first drops any existing +wallet database tables from the database, allowing this function to be +called on a prior wallet database. All data stored in the database will +be deleted and a fresh set of wallet database tables will be created. +This method is equivalent to calling destroy() followed by initialize(). +Returns true on success and false on failure. + +=item upgrade () + +Upgrades the database to the latest schema version, preserving data as +much as possible. Returns true on success and false on failure. + +=back + +=head1 SEE ALSO + +wallet-admin(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Config.pm b/perl/lib/Wallet/Config.pm new file mode 100644 index 0000000..5b0ab1c --- /dev/null +++ b/perl/lib/Wallet/Config.pm @@ -0,0 +1,826 @@ +# Wallet::Config -- Configuration handling for the wallet server. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2010, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Config; +require 5.006; + +use strict; +use vars qw($PATH $VERSION); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.05'; + +# Path to the config file to load. +$PATH = $ENV{WALLET_CONFIG} || '/etc/wallet/wallet.conf'; + +=head1 NAME + +Wallet::Config - Configuration handling for the wallet server + +=for stopwords +DBI DSN SQLite subdirectories KEYTAB keytab kadmind KDC add-ons kadmin DNS +SRV kadmin keytabs remctl backend lowercased NETDB ACL NetDB unscoped +usernames rekey hostnames Allbery wallet-backend keytab-backend Heimdal +rekeys WebAuth WEBAUTH keyring LDAP DN GSS-API integrations + +=head1 SYNOPSIS + + use Wallet::Config; + my $driver = $Wallet::Config::DB_DRIVER; + my $info; + if (defined $Wallet::Config::DB_INFO) { + $info = $Wallet::Config::DB_INFO; + } else { + $info = "database=$Wallet::Config::DB_NAME"; + $info .= ";host=$Wallet::Config::DB_HOST" + if $Wallet::Config::DB_HOST; + $info .= ";port=$Wallet::Config::DB_PORT" + if $Wallet::Config::DB_PORT; + } + my $dsn = "dbi:$driver:$info"; + my $user = $Wallet::Config::DB_USER; + my $password = $Wallet::Config::DB_PASSWORD; + my $dbh = DBI->connect ($dsn, $user, $password); + +=head1 DESCRIPTION + +Wallet::Config encapsulates all of the site-specific configuration for the +wallet server. It is implemented as a Perl class that declares and sets +the defaults for various configuration variables and then, if it exists, +loads the file specified by the WALLET_CONFIG environment variable or +F if that environment variable isn't set. That +file should contain any site-specific overrides to the defaults, and at +least some parameters must be set. + +This file must be valid Perl. To set a variable, use the syntax: + + $VARIABLE = ; + +where VARIABLE is the variable name (always in all-capital letters) and + is the value. If setting a variable to a string and not a number, +you should normally enclose in C<''>. For example, to set the +variable DB_DRIVER to C, use: + + $DB_DRIVER = 'MySQL'; + +Always remember the initial dollar sign (C<$>) and ending semicolon +(C<;>). Those familiar with Perl syntax can of course use the full range +of Perl expressions. + +This configuration file should end with the line: + + 1; + +This ensures that Perl doesn't think there is an error when loading the +file. + +=head1 DATABASE CONFIGURATION + +=over 4 + +=item DB_DDL_DIRECTORY + +Specifies the directory used to dump the database schema in formats for +each possible database server. This also includes diffs between schema +versions, for upgrades. The default value is F, +which matches the default installation location. + +=cut + +our $DB_DDL_DIRECTORY = '/usr/local/share/wallet'; + +=item DB_DRIVER + +Sets the Perl database driver to use for the wallet database. Common +values would be C or C. Less common values would be +C, C, or C. The appropriate DBD::* Perl module for +the chosen driver must be installed and will be dynamically loaded by the +wallet. For more information, see L. + +This variable must be set. + +=cut + +our $DB_DRIVER; + +=item DB_INFO + +Sets the remaining contents for the DBI DSN (everything after the driver). +Using this variable provides full control over the connect string passed +to DBI. When using SQLite, set this variable to the path to the SQLite +database. If this variable is set, DB_NAME, DB_HOST, and DB_PORT are +ignored. For more information, see L and the documentation for the +database driver you're using. + +Either DB_INFO or DB_NAME must be set. If you don't need to pass any +additional information to DBI, set DB_INFO to the empty string (C<''>). + +=cut + +our $DB_INFO; + +=item DB_NAME + +If DB_INFO is not set, specifies the database name. The third part of the +DBI connect string will be set to C, possibly with a +host and port appended if DB_HOST and DB_PORT are set. For more +information, see L and the documentation for the database driver +you're using. + +Either DB_INFO or DB_NAME must be set. + +=cut + +our $DB_NAME; + +=item DB_HOST + +If DB_INFO is not set, specifies the database host. C<;host=DB_HOST> will +be appended to the DBI connect string. For more information, see L +and the documentation for the database driver you're using. + +=cut + +our $DB_HOST; + +=item DB_PORT + +If DB_PORT is not set, specifies the database port. C<;port=DB_PORT> will +be appended to the DBI connect string. If this variable is set, DB_HOST +should also be set. For more information, see L and the +documentation for the database driver you're using. + +=cut + +our $DB_PORT; + +=item DB_USER + +Specifies the user for database authentication. Some database backends, +particularly SQLite, do not need this. + +=cut + +our $DB_USER; + +=item DB_PASSWORD + +Specifies the password for database authentication. Some database +backends, particularly SQLite, do not need this. + +=cut + +our $DB_PASSWORD; + +=back + +=head1 DUO OBJECT CONFIGURATION + +These configuration variables only need to be set if you intend to use the +C object type (the Wallet::Object::Duo class). + +=over 4 + +=item DUO_AGENT + +If this configuration variable is set, its value should be an object that +is call-compatible with LWP::UserAgent. This object will be used instead +of LWP::UserAgent to make API calls to Duo. This is primarily useful for +testing, allowing replacement of the user agent with a mock implementation +so that a test can run without needing a Duo account. + +=cut + +our $DUO_AGENT; + +=item DUO_KEY_FILE + +The path to a file in JSON format that contains the key and hostname data +for the Duo Admin API integration used to manage integrations via wallet. +This file should be in the format expected by the C parameter +to the Net::Duo::Admin constructor. See L for more +information. + +DUO_KEY_FILE must be set to use Duo objects. + +=cut + +our $DUO_KEY_FILE; + +=item DUO_TYPE + +The type of integration to create. Currently, only one type of integration +can be created by one wallet configuration. This restriction may be relaxed +in the future. The default value is C to create UNIX integrations. + +=cut + +our $DUO_TYPE = 'unix'; + +=back + +=head1 FILE OBJECT CONFIGURATION + +These configuration variables only need to be set if you intend to use the +C object type (the Wallet::Object::File class). + +=over 4 + +=item FILE_BUCKET + +The directory into which to store file objects. File objects will be +stored in subdirectories of this directory. See L +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. + +FILE_BUCKET must be set to use file objects. + +=cut + +our $FILE_BUCKET; + +=item FILE_MAX_SIZE + +The maximum size of data that can be stored in a file object in bytes. If +this configuration variable is set, an attempt to store data larger than +this limit will be rejected. + +=cut + +our $FILE_MAX_SIZE; + +=back + +=head1 KEYTAB OBJECT CONFIGURATION + +These configuration variables only need to be set if you intend to use the +C object type (the Wallet::Object::Keytab class). + +=over 4 + +=item KEYTAB_FILE + +Specifies the keytab to use to authenticate to B. The principal +whose key is stored in this keytab must have the ability to create, +modify, inspect, and delete any principals that should be managed by the +wallet. (In MIT Kerberos F parlance, this is C +privileges.) + +KEYTAB_FILE must be set to use keytab objects. + +=cut + +our $KEYTAB_FILE; + +=item KEYTAB_FLAGS + +These flags, if any, are passed to the C command when creating a +new principal in the Kerberos KDC. To not pass any flags, set +KEYTAB_FLAGS to the empty string. The default value is C<-clearpolicy>, +which clears any password strength policy from principals created by the +wallet. (Since the wallet randomizes the keys, password strength checking +is generally pointless and may interact poorly with the way C works when third-party add-ons for password strength checking +are used.) + +=cut + +our $KEYTAB_FLAGS = '-clearpolicy'; + +=item KEYTAB_HOST + +Specifies the host on which the kadmin service is running. This setting +overrides the C setting in the [realms] section of +F and any DNS SRV records and allows the wallet to run on a +system that doesn't have a Kerberos configuration for the wallet's realm. + +=cut + +our $KEYTAB_HOST; + +=item KEYTAB_KADMIN + +The path to the B command-line client. The default value is +C, which will cause the wallet to search for B on its +default PATH. + +=cut + +our $KEYTAB_KADMIN = 'kadmin'; + +=item KEYTAB_KRBTYPE + +The Kerberos KDC implementation type, either C or C +(case-insensitive). KEYTAB_KRBTYPE must be set to use keytab objects. + +=cut + +our $KEYTAB_KRBTYPE; + +=item KEYTAB_PRINCIPAL + +The principal whose key is stored in KEYTAB_FILE. The wallet will +authenticate as this principal to the kadmin service. + +KEYTAB_PRINCIPAL must be set to use keytab objects, at least until +B is smart enough to use the first principal found in the keytab +it's using for authentication. + +=cut + +our $KEYTAB_PRINCIPAL; + +=item KEYTAB_REALM + +Specifies the realm in which to create Kerberos principals. The keytab +object implementation can only work in a single realm for a given wallet +installation and the keytab object names are stored without realm. +KEYTAB_REALM is added when talking to the KDC via B. + +KEYTAB_REALM must be set to use keytab objects. C doesn't always +default to the local realm. + +=cut + +our $KEYTAB_REALM; + +=item KEYTAB_TMP + +A directory into which the wallet can write keytabs temporarily while +processing C commands from clients. The keytabs are written into +this directory with predictable names, so this should not be a system +temporary directory such as F or F. It's best to create a +directory solely for this purpose that's owned by the user the wallet +server will run as. + +KEYTAB_TMP must be set to use keytab objects. + +=cut + +our $KEYTAB_TMP; + +=back + +=head2 Retrieving Existing Keytabs + +Heimdal provides the choice, over the network protocol, of either +downloading the existing keys for a principal or generating new random +keys. MIT Kerberos does not; downloading a keytab over the kadmin +protocol always rekeys the principal. + +For MIT Kerberos, the keytab object backend therefore optionally supports +retrieving existing keys, and hence keytabs, for Kerberos principals by +contacting the KDC via remctl and talking to B. This is +enabled by setting the C flag on keytab objects. To configure +that support, set the following variables. + +This is not required for Heimdal; for Heimdal, setting the C +flag is all that's needed. + +=over 4 + +=item KEYTAB_REMCTL_CACHE + +Specifies the ticket cache to use when retrieving existing keytabs from +the KDC. This is only used to implement support for the C +flag. The ticket cache must be for a principal with access to run +C via remctl on KEYTAB_REMCTL_HOST. + +=cut + +our $KEYTAB_REMCTL_CACHE; + +=item KEYTAB_REMCTL_HOST + +The host to which to connect with remctl to retrieve existing keytabs. +This is only used to implement support for the C flag. This +host must provide the C command and KEYTAB_REMCTL_CACHE +must also be set to a ticket cache for a principal with access to run that +command. + +=cut + +our $KEYTAB_REMCTL_HOST; + +=item KEYTAB_REMCTL_PRINCIPAL + +The service principal to which to authenticate when retrieving existing +keytabs. This is only used to implement support for the C +flag. If this variable is not set, the default is formed by prepending +C to KEYTAB_REMCTL_HOST. (Note that KEYTAB_REMCTL_HOST is not +lowercased first.) + +=cut + +our $KEYTAB_REMCTL_PRINCIPAL; + +=item KEYTAB_REMCTL_PORT + +The port on KEYTAB_REMCTL_HOST to which to connect with remctl to retrieve +existing keytabs. This is only used to implement support for the +C flag. If this variable is not set, the default remctl port +will be used. + +=cut + +our $KEYTAB_REMCTL_PORT; + +=back + +=head1 WEBAUTH KEYRING OBJECT CONFIGURATION + +These configuration variables only need to be set if you intend to use the +C object type (the Wallet::Object::WAKeyring class). + +=over 4 + +=item WAKEYRING_BUCKET + +The directory into which to store WebAuth keyring objects. WebAuth +keyring objects will be stored in subdirectories of this directory. See +L 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. + +WAKEYRING_BUCKET must be set to use WebAuth keyring objects. + +=cut + +our $WAKEYRING_BUCKET; + +=item WAKEYRING_REKEY_INTERVAL + +The interval, in seconds, at which new keys are generated in a keyring. +The object implementation will try to arrange for there to be keys added +to the keyring separated by this interval. + +It's useful to provide some interval to install the keyring everywhere +that it's used before the key becomes inactive. Every keyring will +therefore normally have at least three keys: one that's currently active, +one that becomes valid in the future but less than +WAKEYRING_REKEY_INTERVAL from now, and one that becomes valid between one +and two of those intervals into the future. This means that one has twice +this interval to distribute the keyring everywhere it is used. + +Internally, this is implemented by adding a new key that becomes valid in +twice this interval from the current time if the newest key becomes valid +at or less than this interval in the future. + +The default value is 60 * 60 * 24 (one day). + +=cut + +our $WAKEYRING_REKEY_INTERVAL = 60 * 60 * 24; + +=item WAKEYRING_PURGE_INTERVAL + +The interval, in seconds, from the key creation date after which keys are +removed from the keyring. This is used to clean up old keys and finish +key rotation. Keys won't be removed unless there are more than three keys +in the keyring to try to keep a misconfiguration from removing all valid +keys. + +The default value is 60 * 60 * 24 * 90 (90 days). + +=cut + +our $WAKEYRING_PURGE_INTERVAL = 60 * 60 * 24 * 90; + +=back + +=head1 LDAP ACL CONFIGURATION + +These configuration variables are only needed if you intend to use the +C ACL type (the Wallet::ACL::LDAP::Attribute class). They +specify the LDAP server and additional connection and data model +information required for the wallet to check for the existence of +attributes. + +=over 4 + +=item LDAP_HOST + +The LDAP server name to use to verify LDAP ACLs. This variable must be +set to use LDAP ACLs. + +=cut + +our $LDAP_HOST; + +=item LDAP_BASE + +The base DN under which to search for the entry corresponding to a +principal. Currently, the wallet always does a full subtree search under +this base DN. This variable must be set to use LDAP ACLs. + +=cut + +our $LDAP_BASE; + +=item LDAP_FILTER_ATTR + +The attribute used to find the entry corresponding to a principal. The +LDAP entry containing this attribute with a value equal to the principal +will be found and checked for the required attribute and value. If this +variable is not set, the default is C. + +=cut + +our $LDAP_FILTER_ATTR; + +=item LDAP_CACHE + +Specifies the Kerberos ticket cache to use when connecting to the LDAP +server. GSS-API authentication is always used; there is currently no +support for any other type of bind. The ticket cache must be for a +principal with access to verify the values of attributes that will be used +with this ACL type. This variable must be set to use LDAP ACLs. + +=cut + +our $LDAP_CACHE; + +=back + +Finally, depending on the structure of the LDAP directory being queried, +there may not be any attribute in the directory whose value exactly +matches the Kerberos principal. The attribute designated by +LDAP_FILTER_ATTR may instead hold a transformation of the principal name +(such as the principal with the local realm stripped off, or rewritten +into an LDAP DN form). If this is the case, define a Perl function named +ldap_map_principal. This function will be called whenever an LDAP +attribute ACL is being verified. It will take one argument, the +principal, and is expected to return the value to search for in the LDAP +directory server. + +For example, if the principal name without the local realm is stored in +the C attribute in the directory, set LDAP_FILTER_ATTR to C and +then define ldap_map_attribute as follows: + + sub ldap_map_principal { + my ($principal) = @_; + $principal =~ s/\@EXAMPLE\.COM$//; + return $principal; + } + +Note that this example only removes the local realm (here, EXAMPLE.COM). +Any principal from some other realm will be left fully qualified, and then +presumably will not be found in the directory. + +=head1 NETDB ACL CONFIGURATION + +These configuration variables are only needed if you intend to use the +C ACL type (the Wallet::ACL::NetDB class). They specify the remctl +connection information for retrieving user roles from NetDB and the local +realm to remove from principals (since NetDB normally expects unscoped +local usernames). + +=over 4 + +=item NETDB_REALM + +The wallet uses fully-qualified principal names (including the realm), but +NetDB normally expects local usernames without the realm. If this +variable is set, the given realm will be stripped from any principal names +before passing them to NetDB. Principals in other realms will be passed +to NetDB without modification. + +=cut + +our $NETDB_REALM; + +=item NETDB_REMCTL_CACHE + +Specifies the ticket cache to use when querying the NetDB remctl interface +for user roles. The ticket cache must be for a principal with access to +run C via remctl on KEYTAB_REMCTL_HOST. This variable +must be set to use NetDB ACLs. + +=cut + +our $NETDB_REMCTL_CACHE; + +=item NETDB_REMCTL_HOST + +The host to which to connect with remctl to query NetDB for user roles. +This host must provide the C command and +NETDB_REMCTL_CACHE must also be set to a ticket cache for a principal with +access to run that command. This variable must be set to use NetDB ACLs. + +=cut + +our $NETDB_REMCTL_HOST; + +=item NETDB_REMCTL_PRINCIPAL + +The service principal to which to authenticate when querying NetDB for +user roles. If this variable is not set, the default is formed by +prepending C to NETDB_REMCTL_HOST. (Note that NETDB_REMCTL_HOST is +not lowercased first.) + +=cut + +our $NETDB_REMCTL_PRINCIPAL; + +=item NETDB_REMCTL_PORT + +The port on NETDB_REMCTL_HOST to which to connect with remctl to query +NetDB for user roles. If this variable is not set, the default remctl +port will be used. + +=cut + +our $NETDB_REMCTL_PORT; + +=back + +=head1 DEFAULT OWNERS + +By default, only users in the ADMIN ACL can create new objects in the +wallet. To allow other users to create new objects, define a Perl +function named default_owner. This function will be called whenever a +non-ADMIN user tries to create a new object and will be passed the type +and name of the object. It should return undef if there is no default +owner for that object. If there is, it should return a list containing +the name to use for the ACL and then zero or more anonymous arrays of two +elements each giving the type and identifier for each ACL entry. + +For example, the following simple function says to use a default owner +named C with one entry of type C and identifier +C for the object with type C and name +C: + + sub default_owner { + my ($type, $name) = @_; + if ($type eq 'keytab' and $name eq 'host/example.com') { + return ('default', [ 'krb5', 'rra@example.com' ]); + } else { + return; + } + } + +Of course, normally this function is used for more complex mappings. Here +is a more complete example. For objects of type keytab corresponding to +various types of per-machine principals, return a default owner that sets +as owner anyone with a NetDB role for that system and the system's host +principal. This permits authorization management using NetDB while also +allowing the system to bootstrap itself once the host principal has been +downloaded and rekey itself using the old host principal. + + sub default_owner { + my ($type, $name) = @_; + my %allowed = map { $_ => 1 } + qw(HTTP cifs host imap ldap nfs pop sieve smtp webauth); + my $realm = 'example.com'; + return unless $type eq 'keytab'; + return unless $name =~ m%/%; + my ($service, $instance) = split ('/', $name, 2); + return unless $allowed{$service}; + my $acl_name = "host/$instance"; + my @acl = ([ 'netdb', $instance ], + [ 'krb5', "host/$instance\@$realm" ]); + return ($acl_name, @acl); + } + +The auto-created ACL used for the owner of the new object will, in the +above example, be named C> where I is the +fully-qualified name of the system as derived from the keytab being +requested. + +If the name of the ACL returned by the default_owner function matches an +ACL that already exists in the wallet database, the existing ACL will be +compared to the default ACL returned by the default_owner function. If +the existing ACL has the same entries as the one returned by +default_owner, creation continues if the user is authorized by that ACL. +If they don't match, creation of the object is rejected, since the +presence of an existing ACL may indicate that something different is being +done with this object. + +=head1 NAMING ENFORCEMENT + +By default, wallet permits administrators to create objects of any name +(unless the object backend rejects the name). However, naming standards +for objects can be enforced, even for administrators, by defining a Perl +function in the configuration file named verify_name. If such a function +exists, it will be called for any object creation and will be passed the +type of object, the object name, and the identity of the person doing the +creation. If it returns undef or the empty string, object creation will +be allowed. If it returns anything else, object creation is rejected and +the return value is used as the error message. + +This function is also called for naming audits done via Wallet::Report +to find any existing objects that violate a (possibly updated) naming +policy. In this case, the third argument (the identity of the person +creating the object) will be undef. As a general rule, if the third +argument is undef, the function should apply the most liberal accepted +naming policy so that the audit returns only objects that violate all +naming policies, but some sites may wish different results for their audit +reports. + +Please note that this return status is backwards from what one would +normally expect. A false value is success; a true value is failure with +an error message. + +For example, the following verify_name function would ensure that any +keytab objects for particular principals have fully-qualified hostnames: + + sub verify_name { + my ($type, $name, $user) = @_; + my %host_based = map { $_ => 1 } + qw(HTTP cifs host imap ldap nfs pop sieve smtp webauth); + return unless $type eq 'keytab'; + return unless $name =~ m%/%; + my ($service, $instance) = split ('/', $name, 2); + return unless $host_based{$service}; + return "host name $instance must be fully qualified" + unless $instance =~ /\./; + return; + } + +Objects that aren't of type C or which aren't for a host-based key +have no naming requirements enforced by this example. + +=head1 ACL NAMING ENFORCEMENT + +Similar to object names, by default wallet permits administrators to +create ACLs with any name. However, naming standards for ACLs can be +enforced by defining a Perl function in the configuration file named +verify_acl_name. If such a function exists, it will be called for any ACL +creation or rename and will be passed given the new ACL name and the +identity of the person doing the creation. If it returns undef or the +empty string, object creation will be allowed. If it returns anything +else, object creation is rejected and the return value is used as the +error message. + +This function is also called for naming audits done via Wallet::Report to +find any existing objects that violate a (possibly updated) naming policy. +In this case, the second argument (the identity of the person creating the +ACL) will be undef. As a general rule, if the second argument is undef, +the function should apply the most liberal accepted naming policy so that +the audit returns only ACLs that violate all naming policies, but some +sites may wish different results for their audit reports. + +Please note that this return status is backwards from what one would +normally expect. A false value is success; a true value is failure with +an error message. + +For example, the following verify_acl_name function would ensure that any +ACLs created contain a slash and the part before the slash be one of +C, C, C, or C. + + sub verify_acl_name { + my ($name, $user) = @_; + return 'ACL names must contain a slash' unless $name =~ m,/,; + my ($first, $rest) = split ('/', $name, 2); + my %types = map { $_ => 1 } qw(host group user service); + unless ($types{$first}) { + return "unknown ACL type $first"; + } + return; + } + +Obvious improvements could be made, such as checking that the part after +the slash for a C ACL looked like a host name and the part after a +slash for a C ACL look like a user name. + +=head1 ENVIRONMENT + +=over 4 + +=item WALLET_CONFIG + +If this environment variable is set, it is taken to be the path to the +wallet configuration file to load instead of F. + +=back + +=cut + +# Now, load the configuration file so that it can override the defaults. +if (-r $PATH) { + do $PATH or die (($@ || $!) . "\n"); +} + +1; +__END__ + +=head1 SEE ALSO + +DBI(3), Wallet::Object::Keytab(3), Wallet::Server(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Database.pm b/perl/lib/Wallet/Database.pm new file mode 100644 index 0000000..031be9e --- /dev/null +++ b/perl/lib/Wallet/Database.pm @@ -0,0 +1,123 @@ +# Wallet::Database -- Wallet system database connection management. +# +# This module is a thin wrapper around DBIx::Class to handle determination +# of the database configuration settings automatically on connect. The +# intention is that Wallet::Database objects can be treated in all respects +# like DBIx::Class objects in the rest of the code. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010, 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Database; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Wallet::Schema; +use Wallet::Config; + +@ISA = qw(Wallet::Schema); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.04'; + +############################################################################## +# Core overrides +############################################################################## + +# Override DBI::connect to supply our own connect string, username, and +# password and to set some standard options. Takes no arguments other than +# the implicit class argument. +sub connect { + my ($class) = @_; + unless ($Wallet::Config::DB_DRIVER + and (defined ($Wallet::Config::DB_INFO) + or defined ($Wallet::Config::DB_NAME))) { + die "database connection information not configured\n"; + } + my $dsn = "DBI:$Wallet::Config::DB_DRIVER:"; + if (defined $Wallet::Config::DB_INFO) { + $dsn .= $Wallet::Config::DB_INFO; + } else { + $dsn .= "database=$Wallet::Config::DB_NAME"; + $dsn .= ";host=$Wallet::Config::DB_HOST" if $Wallet::Config::DB_HOST; + $dsn .= ";port=$Wallet::Config::DB_PORT" if $Wallet::Config::DB_PORT; + } + my $user = $Wallet::Config::DB_USER; + my $pass = $Wallet::Config::DB_PASSWORD; + my %attrs = (PrintError => 0, RaiseError => 1); + my $dbh = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) }; + if ($@) { + die "cannot connect to database: $@\n"; + } + return $dbh; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +Wallet::Dabase - Wrapper module for wallet database connections + +=for stopwords +DBI RaiseError PrintError AutoCommit Allbery + +=head1 SYNOPSIS + + use Wallet::Database; + my $dbh = Wallet::Database->connect; + +=head1 DESCRIPTION + +Wallet::Database is a thin wrapper module around DBI that takes care of +building a connect string and setting database options based on wallet +configuration. The only overridden method is connect(). All other +methods should work the same as in DBI and Wallet::Database objects should +be usable exactly as if they were DBI objects. + +connect() will obtain the database connection information from the wallet +configuration; see L for more details. It will also +automatically set the RaiseError attribute to true and the PrintError and +AutoCommit attributes to false, matching the assumptions made by the +wallet database code. + +=head1 CLASS METHODS + +=over 4 + +=item connect() + +Opens a new database connection and returns the database object. On any +failure, throws an exception. Unlike the DBI method, connect() takes no +arguments; all database connection information is derived from the wallet +configuration. + +=back + +=head1 SEE ALSO + +DBI(3), Wallet::Config(3) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Kadmin.pm b/perl/lib/Wallet/Kadmin.pm new file mode 100644 index 0000000..4ea7920 --- /dev/null +++ b/perl/lib/Wallet/Kadmin.pm @@ -0,0 +1,240 @@ +# Wallet::Kadmin -- Kerberos administration API for wallet keytab backend. +# +# Written by Jon Robertson +# Copyright 2009, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Kadmin; +require 5.006; + +use strict; +use vars qw($VERSION); + +use Wallet::Config (); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.03'; + +############################################################################## +# Utility functions for child classes +############################################################################## + +# Read the entirety of a possibly binary file and return the contents, +# deleting the file after reading it. If reading the file fails, set the +# error message and return undef. +sub read_keytab { + my ($self, $file) = @_; + local *TMPFILE; + unless (open (TMPFILE, '<', $file)) { + $self->error ("cannot open temporary file $file: $!"); + return; + } + local $/; + undef $!; + my $data = ; + if ($!) { + $self->error ("cannot read temporary file $file: $!"); + unlink $file; + return; + } + close TMPFILE; + unlink $file; + return $data; +} + +############################################################################## +# Public methods +############################################################################## + +# Create a new kadmin object, by finding the type requested in the wallet +# config and passing off to the proper module. Returns the object directly +# from the specific Wallet::Kadmin::* module. +sub new { + my ($class) = @_; + my $kadmin; + if (not $Wallet::Config::KEYTAB_KRBTYPE) { + die "keytab object implementation not configured\n"; + } elsif (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'mit') { + require Wallet::Kadmin::MIT; + $kadmin = Wallet::Kadmin::MIT->new; + } elsif (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'heimdal') { + require Wallet::Kadmin::Heimdal; + $kadmin = Wallet::Kadmin::Heimdal->new; + } else { + my $type = $Wallet::Config::KEYTAB_KRBTYPE; + die "unknown KEYTAB_KRBTYPE setting: $type\n"; + } + + return $kadmin; +} + +# Set or return the error stashed in the object. +sub error { + my ($self, @error) = @_; + if (@error) { + my $error = join ('', @error); + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + $self->{error} = $error; + } + return $self->{error}; +} + +# Set a callback to be called for forked kadmin processes. This does nothing +# by default but may be overridden by subclasses that need special behavior +# (such as the current Wallet::Kadmin::MIT module). +sub fork_callback { } + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +backend Kadmin keytabs keytab Heimdal API kadmind kadmin KDC ENCTYPE +enctypes enctype Allbery + +=head1 NAME + +Wallet::Kadmin - Kerberos administration API for wallet keytab backend + +=head1 SYNOPSIS + + my $kadmin = Wallet::Kadmin->new; + $kadmin->create ('host/foo.example.com'); + my $data = $kadmin->keytab_rekey ('host/foo.example.com', + 'aes256-cts-hmac-sha1-96'); + $data = $kadmin->keytab ('host/foo.example.com'); + my $exists = $kadmin->exists ('host/oldshell.example.com'); + $kadmin->destroy ('host/oldshell.example.com') if $exists; + +=head1 DESCRIPTION + +Wallet::Kadmin is a wrapper and base class for modules that provide an +interface for wallet to do Kerberos administration, specifically create +and delete principals and create keytabs for a principal. Each subclass +administers a specific type of Kerberos implementation, such as MIT +Kerberos or Heimdal, providing a standard set of API calls used to +interact with that implementation's kadmin interface. + +The class uses Wallet::Config to find which type of kadmin interface is in +use and then returns an object to use for interacting with that interface. +See L for details on how to +configure this module. + +=head1 CLASS METHODS + +=over 4 + +=item new() + +Finds the proper Kerberos implementation and calls the new() constructor +for that implementation's module, returning the resulting object. If the +implementation is not recognized or set, die with an error message. + +=back + +=head1 INSTANCE METHODS + +These methods are provided by any object returned by new(), regardless of +the underlying kadmin interface. They are implemented by the child class +appropriate for the configured Kerberos implementation. + +=over 4 + +=item create(PRINCIPAL) + +Adds a new principal with a given name. The principal is created with a +random password, and any other flags set by Wallet::Config. Returns true +on success and false on failure. If the principal already exists, return +true as we are bringing our expectations in line with reality. + +=item destroy(PRINCIPAL) + +Removes a principal with the given name. Returns true on success or false +on failure. If the principal does not exist, return true as we are +bringing our expectations in line with reality. + +=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. + +For the convenience of child classes, this method can also be called with +one or more error strings. If so, those strings are concatenated +together, trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is +stored as the error. Only child classes should call this method with an +error string. + +=item exists(PRINCIPAL) + +Returns true if the given principal exists in the KDC and C<0> if it +doesn't. If an error is encountered in checking whether the principal +exists, exists() returns undef. + +=item fork_callback(CALLBACK) + +If the module has to fork an external process for some reason, such as a +kadmin command-line client, the sub CALLBACK will be called in the child +process before running the program. This can be used to, for example, +properly clean up shared database handles. + +=item keytab(PRINCIPAL) + +keytab() creates a keytab for the given principal, storing it in the given +file. A keytab is an on-disk store for the key or keys for a Kerberos +principal. Keytabs are used by services to verify incoming authentication +from clients or by automated processes that need to authenticate to +Kerberos. To create a keytab, the principal has to have previously been +created in the Kerberos KDC. Returns the keytab as binary data on success +and undef on failure. + +=item keytab_rekey(PRINCIPAL [, ENCTYPE ...]) + +Like keytab(), but randomizes the key for the principal before generating +the keytab and writes it to the given file. This will invalidate any +existing keytabs for that principal. This method can also limit the +encryption types of the keys for that principal via the optional ENCTYPE +arguments. The enctype values must be enctype strings recognized by the +Kerberos implementation (strings like C or +C). If none are given, the KDC defaults will be used. +Returns the keytab as binary data on success and undef on failure. + +=back + +The following methods are utility methods to aid with child class +implementation and should only be called by child classes. + +=over 4 + +=item read_keytab(FILE) + +Reads the contents of the keytab stored in FILE into memory and returns it +as binary data. On failure, returns undef and sets the object error. + +=back + +=head1 SEE ALSO + +kadmin(8), Wallet::Config(3), Wallet::Object::Keytab(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHORS + +Jon Robertson and Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Kadmin/Heimdal.pm b/perl/lib/Wallet/Kadmin/Heimdal.pm new file mode 100644 index 0000000..42de8e0 --- /dev/null +++ b/perl/lib/Wallet/Kadmin/Heimdal.pm @@ -0,0 +1,314 @@ +# Wallet::Kadmin::Heimdal -- Wallet Kerberos administration API for Heimdal. +# +# Written by Jon Robertson +# Copyright 2009, 2010, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Kadmin::Heimdal; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Heimdal::Kadm5 qw(KRB5_KDB_DISALLOW_ALL_TIX); +use Wallet::Config (); +use Wallet::Kadmin (); + +@ISA = qw(Wallet::Kadmin); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.04'; + +############################################################################## +# Utility functions +############################################################################## + +# Add the realm to the end of the principal if no realm is currently present. +sub canonicalize_principal { + my ($self, $principal) = @_; + if ($Wallet::Config::KEYTAB_REALM && $principal !~ /\@/) { + $principal .= '@' . $Wallet::Config::KEYTAB_REALM; + } + return $principal; +} + +# Generate a long random password. +# +# Please note: This is not a cryptographically secure password! It's used +# only because the Heimdal kadmin interface requires a password on create. +# The keys will be set before the principal is ever set active, so it will +# never be possible to use the password. It just needs to be random in case +# password quality checks are applied to it. +# +# Make the password reasonably long and include a variety of character classes +# so that it should pass any password strength checking. +sub insecure_random_password { + my ($self) = @_; + my @classes = ( + 'abcdefghijklmnopqrstuvwxyz', + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', + '0123456789', + '~`!@#$%^&*()-_+={[}]|:;<,>.?/' + ); + my $password = q{}; + for my $i (1..20) { + my $class = $i % scalar (@classes); + my $alphabet = $classes[$class]; + my $letter = substr ($alphabet, int (rand (length $alphabet)), 1); + $password .= $letter; + } + return $password; +} + +############################################################################## +# Public interfaces +############################################################################## + +# Check whether a given principal already exists in Kerberos. Returns true if +# so, false otherwise. +sub exists { + my ($self, $principal) = @_; + $principal = $self->canonicalize_principal ($principal); + my $kadmin = $self->{client}; + my $princdata = eval { $kadmin->getPrincipal ($principal) }; + if ($@) { + $self->error ("error getting principal: $@"); + return; + } + return $princdata ? 1 : 0; +} + +# Create a principal in Kerberos. If there is an error, return undef and set +# the error. Return 1 on success or the principal already existing. +sub create { + my ($self, $principal) = @_; + $principal = $self->canonicalize_principal ($principal); + my $exists = eval { $self->exists ($principal) }; + if ($@) { + $self->error ("error adding principal $principal: $@"); + return; + } + return 1 if $exists; + + # The way Heimdal::Kadm5 works, we create a principal object, create the + # actual principal set inactive, then randomize it and activate it. We + # have to set a password, even though we're about to replace it with + # random keys, but since the principal is created inactive, it doesn't + # have to be a very good one. + my $kadmin = $self->{client}; + eval { + my $princdata = $kadmin->makePrincipal ($principal); + my $attrs = $princdata->getAttributes; + $attrs |= KRB5_KDB_DISALLOW_ALL_TIX; + $princdata->setAttributes ($attrs); + my $password = $self->insecure_random_password; + $kadmin->createPrincipal ($princdata, $password, 0); + $kadmin->randKeyPrincipal ($principal); + $kadmin->enablePrincipal ($principal); + }; + if ($@) { + $self->error ("error adding principal $principal: $@"); + return; + } + return 1; +} + +# Create a keytab for a principal. Returns the keytab as binary data or undef +# on failure, setting the error. +sub keytab { + my ($self, $principal) = @_; + $principal = $self->canonicalize_principal ($principal); + my $kadmin = $self->{client}; + my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; + unlink $file; + my $princdata = eval { $kadmin->getPrincipal ($principal) }; + if ($@) { + $self->error ("error creating keytab for $principal: $@"); + return; + } elsif (!$princdata) { + $self->error ("error creating keytab for $principal: principal does" + . " not exist"); + return; + } + eval { $kadmin->extractKeytab ($princdata, $file) }; + if ($@) { + $self->error ("error creating keytab for principal: $@"); + return; + } + return $self->read_keytab ($file); +} + +# Create a keytab for a principal, randomizing the keys for that principal at +# the same time. Takes the principal and an optional list of encryption types +# to which to limit the keytab. Return the keytab data on success and undef +# on failure. If the keytab creation fails, sets the error. +sub keytab_rekey { + my ($self, $principal, @enctypes) = @_; + $principal = $self->canonicalize_principal ($principal); + + # The way Heimdal works, you can only remove enctypes from a principal, + # not add them back in. So we need to run randkeyPrincipal first each + # time to restore all possible enctypes and then whittle them back down + # to those we have been asked for this time. + my $kadmin = $self->{client}; + eval { $kadmin->randKeyPrincipal ($principal) }; + if ($@) { + $self->error ("error creating keytab for $principal: could not" + . " reinit enctypes: $@"); + return; + } + my $princdata = eval { $kadmin->getPrincipal ($principal) }; + if ($@) { + $self->error ("error creating keytab for $principal: $@"); + return; + } elsif (!$princdata) { + $self->error ("error creating keytab for $principal: principal does" + . " not exist"); + return; + } + + # Now actually remove any non-requested enctypes, if we requested any. + if (@enctypes) { + my $alltypes = $princdata->getKeytypes; + my %wanted = map { $_ => 1 } @enctypes; + for my $key (@{ $alltypes }) { + my $keytype = $key->[0]; + next if exists $wanted{$keytype}; + eval { $princdata->delKeytypes ($keytype) }; + if ($@) { + $self->error ("error removing keytype $keytype from the" + . " keytab: $@"); + return; + } + } + eval { $kadmin->modifyPrincipal ($princdata) }; + if ($@) { + $self->error ("error saving principal modifications: $@"); + return; + } + } + + # Create the keytab. + my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; + unlink $file; + eval { $kadmin->extractKeytab ($princdata, $file) }; + if ($@) { + $self->error ("error creating keytab for principal: $@"); + return; + } + return $self->read_keytab ($file); +} + +# Delete a principal from Kerberos. Return true if successful, false +# otherwise. If the deletion fails, sets the error. If the principal doesn't +# exist, return success; we're bringing reality in line with our expectations. +sub destroy { + my ($self, $principal) = @_; + $principal = $self->canonicalize_principal ($principal); + my $exists = eval { $self->exists ($principal) }; + if ($@) { + $self->error ("error checking principal existance: $@"); + return; + } elsif (not $exists) { + return 1; + } + my $kadmin = $self->{client}; + my $retval = eval { $kadmin->deletePrincipal ($principal) }; + if ($@) { + $self->error ("error deleting $principal: $@"); + return; + } + return 1; +} + +# Create a new Wallet::Kadmin::Heimdal object and its underlying +# Heimdal::Kadm5 object. +sub new { + my ($class) = @_; + unless (defined ($Wallet::Config::KEYTAB_PRINCIPAL) + and defined ($Wallet::Config::KEYTAB_FILE) + and defined ($Wallet::Config::KEYTAB_REALM)) { + die "keytab object implementation not configured\n"; + } + unless (defined ($Wallet::Config::KEYTAB_TMP)) { + die "KEYTAB_TMP configuration variable not set\n"; + } + my @options = (RaiseError => 1, + Principal => $Wallet::Config::KEYTAB_PRINCIPAL, + Realm => $Wallet::Config::KEYTAB_REALM, + Keytab => $Wallet::Config::KEYTAB_FILE); + if ($Wallet::Config::KEYTAB_HOST) { + push (@options, Server => $Wallet::Config::KEYTAB_HOST); + } + my $client = Heimdal::Kadm5::Client->new (@options); + my $self = { client => $client }; + bless ($self, $class); + return $self; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +keytabs keytab kadmin KDC API Allbery Heimdal unlinked + +=head1 NAME + +Wallet::Kadmin::Heimdal - Wallet Kerberos administration API for Heimdal + +=head1 SYNOPSIS + + my $kadmin = Wallet::Kadmin::Heimdal->new; + $kadmin->create ('host/foo.example.com'); + $kadmin->keytab_rekey ('host/foo.example.com', 'keytab', + 'aes256-cts-hmac-sha1-96'); + my $data = $kadmin->keytab ('host/foo.example.com'); + my $exists = $kadmin->exists ('host/oldshell.example.com'); + $kadmin->destroy ('host/oldshell.example.com') if $exists; + +=head1 DESCRIPTION + +Wallet::Kadmin::Heimdal implements the Wallet::Kadmin API for Heimdal, +providing an interface to create and delete principals and create keytabs. +It provides the API documented in L for a Heimdal KDC. + +To use this class, several configuration parameters must be set. See +L for details. + +=head1 FILES + +=over 4 + +=item KEYTAB_TMP/keytab. + +The keytab is created in this file and then read into memory. KEYTAB_TMP +is set in the wallet configuration, and is the process ID of the +current process. The file is unlinked after being read. + +=back + +=head1 SEE ALSO + +kadmin(8), Wallet::Config(3), Wallet::Kadmin(3), +Wallet::Object::Keytab(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHORS + +Russ Allbery and Jon Robertson . + +=cut diff --git a/perl/lib/Wallet/Kadmin/MIT.pm b/perl/lib/Wallet/Kadmin/MIT.pm new file mode 100644 index 0000000..1ae01bf --- /dev/null +++ b/perl/lib/Wallet/Kadmin/MIT.pm @@ -0,0 +1,323 @@ +# Wallet::Kadmin::MIT -- Wallet Kerberos administration API for MIT. +# +# Written by Russ Allbery +# Pulled into a module by Jon Robertson +# Copyright 2007, 2008, 2009, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Kadmin::MIT; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Wallet::Config (); +use Wallet::Kadmin (); + +@ISA = qw(Wallet::Kadmin); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.03'; + +############################################################################## +# kadmin Interaction +############################################################################## + +# Make sure that principals are well-formed and don't contain characters that +# will cause us problems when talking to kadmin. Takes a principal and +# returns true if it's okay, false otherwise. Note that we do not permit +# realm information here. +sub valid_principal { + my ($self, $principal) = @_; + return scalar ($principal =~ m,^[\w-]+(/[\w_.-]+)?\z,); +} + +# Run a kadmin command and capture the output. Returns the output, either as +# a list of lines or, in scalar context, as one string. The exit status of +# kadmin is often worthless. +sub kadmin { + my ($self, $command) = @_; + unless (defined ($Wallet::Config::KEYTAB_PRINCIPAL) + and defined ($Wallet::Config::KEYTAB_FILE) + and defined ($Wallet::Config::KEYTAB_REALM)) { + die "keytab object implementation not configured\n"; + } + my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', '-t', + $Wallet::Config::KEYTAB_FILE, '-q', $command); + push (@args, '-s', $Wallet::Config::KEYTAB_HOST) + if $Wallet::Config::KEYTAB_HOST; + push (@args, '-r', $Wallet::Config::KEYTAB_REALM) + if $Wallet::Config::KEYTAB_REALM; + my $pid = open (KADMIN, '-|'); + if (not defined $pid) { + $self->error ("cannot fork: $!"); + return; + } elsif ($pid == 0) { + $self->{fork_callback} () if $self->{fork_callback}; + unless (open (STDERR, '>&STDOUT')) { + warn "wallet: cannot dup stdout: $!\n"; + exit 1; + } + unless (exec ($Wallet::Config::KEYTAB_KADMIN, @args)) { + warn "wallet: cannot run $Wallet::Config::KEYTAB_KADMIN: $!\n"; + exit 1; + } + } + local $_; + my @output; + while () { + if (/^wallet: cannot /) { + s/^wallet: //; + $self->error ($_); + return; + } + push (@output, $_) unless /Authenticating as principal/; + } + close KADMIN; + return wantarray ? @output : join ('', @output); +} + +############################################################################## +# Public interfaces +############################################################################## + +# Set a callback to be called for forked kadmin processes. +sub fork_callback { + my ($self, $callback) = @_; + $self->{fork_callback} = $callback; +} + +# Check whether a given principal already exists in Kerberos. Returns true if +# so, false otherwise. Returns undef if kadmin fails, with the error already +# set by kadmin. +sub exists { + my ($self, $principal) = @_; + return unless $self->valid_principal ($principal); + if ($Wallet::Config::KEYTAB_REALM) { + $principal .= '@' . $Wallet::Config::KEYTAB_REALM; + } + my $output = $self->kadmin ("getprinc $principal"); + if (!defined $output) { + return; + } elsif ($output =~ /^get_principal: /) { + return 0; + } else { + return 1; + } +} + +# Create a principal in Kerberos. Sets the error and returns undef on failure, +# and returns 1 on either success or the principal already existing. +sub create { + my ($self, $principal) = @_; + unless ($self->valid_principal ($principal)) { + $self->error ("invalid principal name $principal"); + return; + } + return 1 if $self->exists ($principal); + if ($Wallet::Config::KEYTAB_REALM) { + $principal .= '@' . $Wallet::Config::KEYTAB_REALM; + } + my $flags = $Wallet::Config::KEYTAB_FLAGS || ''; + my $output = $self->kadmin ("addprinc -randkey $flags $principal"); + if (!defined $output) { + return; + } elsif ($output =~ /^add_principal: (.*)/m) { + $self->error ("error adding principal $principal: $1"); + return; + } + return 1; +} + +# Retrieve an existing keytab from the KDC via a remctl call. The KDC needs +# to be running the keytab-backend script and support the keytab retrieve +# remctl command. In addition, the user must have configured us with the path +# to a ticket cache and the host to which to connect with remctl. Returns the +# keytab on success and undef on failure. +sub keytab { + my ($self, $principal) = @_; + my $host = $Wallet::Config::KEYTAB_REMCTL_HOST; + unless ($host and $Wallet::Config::KEYTAB_REMCTL_CACHE) { + $self->error ('keytab unchanging support not configured'); + return; + } + eval { require Net::Remctl }; + if ($@) { + $self->error ("keytab unchanging support not available: $@"); + return; + } + if ($principal !~ /\@/ && $Wallet::Config::KEYTAB_REALM) { + $principal .= '@' . $Wallet::Config::KEYTAB_REALM; + } + local $ENV{KRB5CCNAME} = $Wallet::Config::KEYTAB_REMCTL_CACHE; + my $port = $Wallet::Config::KEYTAB_REMCTL_PORT || 0; + my $remctl_princ = $Wallet::Config::KEYTAB_REMCTL_PRINCIPAL || ''; + my @command = ('keytab', 'retrieve', $principal); + my $result = Net::Remctl::remctl ($host, $port, $remctl_princ, @command); + if ($result->error) { + $self->error ("cannot retrieve keytab for $principal: ", + $result->error); + return; + } elsif ($result->status != 0) { + my $error = $result->stderr; + $error =~ s/\s+$//; + $error =~ s/\n/ /g; + $self->error ("cannot retrieve keytab for $principal: $error"); + return; + } else { + return $result->stdout; + } +} + +# Create a keytab for a principal, randomizing the keys for that principal +# in the process. Takes the principal and an optional list of encryption +# types to which to limit the keytab. Return the keytab data on success +# and undef otherwise. If the keytab creation fails, sets the error. +sub keytab_rekey { + my ($self, $principal, @enctypes) = @_; + unless ($self->valid_principal ($principal)) { + $self->error ("invalid principal name: $principal"); + return; + } + if ($Wallet::Config::KEYTAB_REALM) { + $principal .= '@' . $Wallet::Config::KEYTAB_REALM; + } + my $file = $Wallet::Config::KEYTAB_TMP . "/keytab.$$"; + unlink $file; + my $command = "ktadd -q -k $file"; + if (@enctypes) { + @enctypes = map { /:/ ? $_ : "$_:normal" } @enctypes; + $command .= ' -e "' . join (' ', @enctypes) . '"'; + } + my $output = $self->kadmin ("$command $principal"); + if (!defined $output) { + return; + } elsif ($output =~ /^(?:kadmin|ktadd): (.*)/m) { + $self->error ("error creating keytab for $principal: $1"); + return; + } + return $self->read_keytab ($file); +} + +# Delete a principal from Kerberos. Return true if successful, false +# otherwise. If the deletion fails, sets the error. If the principal doesn't +# exist, return success; we're bringing reality in line with our expectations. +sub destroy { + my ($self, $principal) = @_; + unless ($self->valid_principal ($principal)) { + $self->error ("invalid principal name: $principal"); + } + my $exists = $self->exists ($principal); + if (!defined $exists) { + return; + } elsif (not $exists) { + return 1; + } + if ($Wallet::Config::KEYTAB_REALM) { + $principal .= '@' . $Wallet::Config::KEYTAB_REALM; + } + my $output = $self->kadmin ("delprinc -force $principal"); + if (!defined $output) { + return; + } elsif ($output =~ /^delete_principal: (.*)/m) { + $self->error ("error deleting $principal: $1"); + return; + } + return 1; +} + +# Create a new MIT kadmin object. Very empty for the moment, but later it +# will probably fill out if we go to using a module rather than calling +# kadmin directly. +sub new { + my ($class) = @_; + unless (defined ($Wallet::Config::KEYTAB_TMP)) { + die "KEYTAB_TMP configuration variable not set\n"; + } + my $self = {}; + bless ($self, $class); + return $self; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +rekeying rekeys remctl backend keytabs keytab kadmin KDC API Allbery +unlinked + +=head1 NAME + +Wallet::Kadmin::MIT - Wallet Kerberos administration API for MIT + +=head1 SYNOPSIS + + my $kadmin = Wallet::Kadmin::MIT->new; + $kadmin->create ('host/foo.example.com'); + my $data = $kadmin->keytab_rekey ('host/foo.example.com', + 'aes256-cts-hmac-sha1-96'); + $data = $kadmin->keytab ('host/foo.example.com'); + my $exists = $kadmin->exists ('host/oldshell.example.com'); + $kadmin->destroy ('host/oldshell.example.com') if $exists; + +=head1 DESCRIPTION + +Wallet::Kadmin::MIT implements the Wallet::Kadmin API for MIT Kerberos, +providing an interface to create and delete principals and create keytabs. +It provides the API documented in L for an MIT Kerberos +KDC. + +MIT Kerberos does not provide any method via the kadmin network protocol +to retrieve a keytab for a principal without rekeying it, so the keytab() +method (as opposed to keytab_rekey(), which rekeys the principal) is +implemented using a remctl backend. For that method (used for unchanging +keytab objects) to work, the necessary wallet configuration and remctl +interface on the KDC must be set up. + +To use this class, several configuration parameters must be set. See +L for details. + +=head1 FILES + +=over 4 + +=item KEYTAB_TMP/keytab. + +The keytab is created in this file and then read into memory. KEYTAB_TMP +is set in the wallet configuration, and is the process ID of the +current process. The file is unlinked after being read. + +=back + +=head1 LIMITATIONS + +Currently, this implementation calls an external B program rather +than using a native Perl module and therefore requires B be +installed and parses its output. It may miss some error conditions if the +output of B ever changes. + +=head1 SEE ALSO + +kadmin(8), Wallet::Config(3), Wallet::Kadmin(3), +Wallet::Object::Keytab(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHORS + +Russ Allbery and Jon Robertson . + +=cut diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm new file mode 100644 index 0000000..8debac9 --- /dev/null +++ b/perl/lib/Wallet/Object/Base.pm @@ -0,0 +1,1015 @@ +# Wallet::Object::Base -- Parent class for any object stored in the wallet. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Object::Base; +require 5.006; + +use strict; +use vars qw($VERSION); + +use DBI; +use POSIX qw(strftime); +use Text::Wrap qw(wrap); +use Wallet::ACL; + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.06'; + +############################################################################## +# Constructors +############################################################################## + +# Initialize an object from the database. Verifies that the object already +# exists with the given type, and if it does, returns a new blessed object of +# the specified class. Stores the database handle to use, the name, and the +# type in the object. If the object doesn't exist, returns undef. This will +# probably be usable as-is by most object types. +sub new { + my ($class, $type, $name, $schema) = @_; + my %search = (ob_type => $type, + ob_name => $name); + my $object = $schema->resultset('Object')->find (\%search); + die "cannot find ${type}:${name}\n" + unless ($object and $object->ob_name eq $name); + my $self = { + schema => $schema, + name => $name, + type => $type, + }; + bless ($self, $class); + return $self; +} + +# Create a new object in the database of the specified name and type, setting +# the ob_created_* fields accordingly, and returns a new blessed object of the +# specified class. Stores the database handle to use, the name, and the type +# in the object. Subclasses may need to override this to do additional setup. +sub create { + my ($class, $type, $name, $schema, $user, $host, $time) = @_; + $time ||= time; + die "invalid object type\n" unless $type; + die "invalid object name\n" unless $name; + my $guard = $schema->txn_scope_guard; + eval { + my %record = (ob_type => $type, + ob_name => $name, + ob_created_by => $user, + ob_created_from => $host, + ob_created_on => strftime ('%Y-%m-%d %T', + localtime $time)); + $schema->resultset('Object')->create (\%record); + + %record = (oh_type => $type, + oh_name => $name, + oh_action => 'create', + oh_by => $user, + oh_from => $host, + oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + $schema->resultset('ObjectHistory')->create (\%record); + + $guard->commit; + }; + if ($@) { + die "cannot create object ${type}:${name}: $@\n"; + } + my $self = { + schema => $schema, + name => $name, + type => $type, + }; + bless ($self, $class); + return $self; +} + +############################################################################## +# Utility functions +############################################################################## + +# Set or return the error stashed in the object. +sub error { + my ($self, @error) = @_; + if (@error) { + my $error = join ('', @error); + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + $self->{error} = $error; + } + return $self->{error}; +} + +# Returns the type of the object. +sub type { + my ($self) = @_; + return $self->{type}; +} + +# Returns the name of the object. +sub name { + my ($self) = @_; + return $self->{name}; +} + +# Record a global object action for this object. Takes the action (which must +# be one of get or store), and the trace information: user, host, and time. +# Returns true on success and false on failure, setting error appropriately. +# +# This function commits its transaction when complete and should not be called +# inside another transaction. +sub log_action { + my ($self, $action, $user, $host, $time) = @_; + unless ($action =~ /^(get|store)\z/) { + $self->error ("invalid history action $action"); + return; + } + + # We have two traces to record, one in the object_history table and one in + # the object record itself. Commit both changes as a transaction. We + # assume that AutoCommit is turned off. + my $guard = $self->{schema}->txn_scope_guard; + eval { + my %record = (oh_type => $self->{type}, + oh_name => $self->{name}, + oh_action => $action, + oh_by => $user, + oh_from => $host, + oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + $self->{schema}->resultset('ObjectHistory')->create (\%record); + + my %search = (ob_type => $self->{type}, + ob_name => $self->{name}); + my $object = $self->{schema}->resultset('Object')->find (\%search); + if ($action eq 'get') { + $object->ob_downloaded_by ($user); + $object->ob_downloaded_from ($host); + $object->ob_downloaded_on (strftime ('%Y-%m-%d %T', + localtime $time)); + } elsif ($action eq 'store') { + $object->ob_stored_by ($user); + $object->ob_stored_from ($host); + $object->ob_stored_on (strftime ('%Y-%m-%d %T', + localtime $time)); + } + $object->update; + $guard->commit; + }; + if ($@) { + my $id = $self->{type} . ':' . $self->{name}; + $self->error ("cannot update history for $id: $@"); + return; + } + return 1; +} + +# Record a setting change for this object. Takes the field, the old value, +# the new value, and the trace information (user, host, and time). The field +# may have the special value "type_data " in which case the value after +# the whitespace is used as the type_field value. +# +# This function does not commit and does not catch exceptions. It should +# normally be called as part of a larger transaction that implements the +# setting change and should be committed with that change. +sub log_set { + my ($self, $field, $old, $new, $user, $host, $time) = @_; + my $type_field; + if ($field =~ /^type_data\s+/) { + ($field, $type_field) = split (' ', $field, 2); + } + my %fields = map { $_ => 1 } + qw(owner acl_get acl_store acl_show acl_destroy acl_flags expires + comment flags type_data); + unless ($fields{$field}) { + die "invalid history field $field"; + } + + my %record = (oh_type => $self->{type}, + oh_name => $self->{name}, + oh_action => 'set', + oh_field => $field, + oh_type_field => $type_field, + oh_old => $old, + oh_new => $new, + oh_by => $user, + oh_from => $host, + oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + $self->{schema}->resultset('ObjectHistory')->create (\%record); +} + +############################################################################## +# Get/set values +############################################################################## + +# Set a particular attribute. Takes the attribute to set and its new value. +# Returns undef on failure and true on success. +sub _set_internal { + my ($self, $attr, $value, $user, $host, $time) = @_; + if ($attr !~ /^[a-z_]+\z/) { + $self->error ("invalid attribute $attr"); + return; + } + $time ||= time; + my $name = $self->{name}; + my $type = $self->{type}; + if ($self->flag_check ('locked')) { + $self->error ("cannot modify ${type}:${name}: object is locked"); + return; + } + + my $guard = $self->{schema}->txn_scope_guard; + eval { + my %search = (ob_type => $type, + ob_name => $name); + my $object = $self->{schema}->resultset('Object')->find (\%search); + my $old = $object->get_column ("ob_$attr"); + + $object->update ({ "ob_$attr" => $value }); + $self->log_set ($attr, $old, $value, $user, $host, $time); + $guard->commit; + }; + if ($@) { + my $id = $self->{type} . ':' . $self->{name}; + $self->error ("cannot set $attr on $id: $@"); + return; + } + return 1; +} + +# Get a particular attribute. Returns the attribute value or undef if the +# value isn't set or on a database error. The two cases can be distinguished +# by whether $self->{error} is set. +sub _get_internal { + my ($self, $attr) = @_; + undef $self->{error}; + if ($attr !~ /^[a-z_]+\z/) { + $self->error ("invalid attribute $attr"); + return; + } + $attr = 'ob_' . $attr; + my $name = $self->{name}; + my $type = $self->{type}; + my $value; + eval { + my %search = (ob_type => $type, + ob_name => $name); + my $object = $self->{schema}->resultset('Object')->find (\%search); + $value = $object->get_column ($attr); + }; + if ($@) { + $self->error ($@); + return; + } + return $value; +} + +# Get or set an ACL on an object. Takes the type of ACL and, if setting, the +# new ACL identifier. If setting it, trace information must also be provided. +sub acl { + my ($self, $type, $id, $user, $host, $time) = @_; + if ($type !~ /^(get|store|show|destroy|flags)\z/) { + $self->error ("invalid ACL type $type"); + return; + } + my $attr = "acl_$type"; + if ($id) { + my $acl; + eval { $acl = Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + return $self->_set_internal ($attr, $acl->id, $user, $host, $time); + } elsif (defined $id) { + return $self->_set_internal ($attr, undef, $user, $host, $time); + } else { + return $self->_get_internal ($attr); + } +} + +# Get or set an attribute on an object. Takes the name of the attribute and, +# if setting, the values and trace information. The values must be provided +# as a reference to an array, even if there is only one value. +# +# Attributes are used by backends for backend-specific information (such as +# enctypes for a keytab). The default implementation rejects all attribute +# names as unknown. +sub attr { + my ($self, $attr, $values, $user, $host, $time) = @_; + $self->error ("unknown attribute $attr"); + return; +} + +# Format the object attributes for inclusion in show(). The default +# implementation just returns the empty string. +sub attr_show { + my ($self) = @_; + return ''; +} + +# Get or set the comment value of an object. If setting it, trace information +# must also be provided. +sub comment { + my ($self, $comment, $user, $host, $time) = @_; + if ($comment) { + return $self->_set_internal ('comment', $comment, $user, $host, $time); + } elsif (defined $comment) { + return $self->_set_internal ('comment', undef, $user, $host, $time); + } else { + return $self->_get_internal ('comment'); + } +} + +# Get or set the expires value of an object. Expects an expiration time in +# seconds since epoch. If setting the expiration, trace information must also +# be provided. +sub expires { + my ($self, $expires, $user, $host, $time) = @_; + if ($expires) { + if ($expires !~ /^\d{4}-\d\d-\d\d( \d\d:\d\d:\d\d)?\z/) { + $self->error ("malformed expiration time $expires"); + return; + } + return $self->_set_internal ('expires', $expires, $user, $host, $time); + } elsif (defined $expires) { + return $self->_set_internal ('expires', undef, $user, $host, $time); + } else { + return $self->_get_internal ('expires'); + } +} + +# Get or set the owner of an object. If setting it, trace information must +# also be provided. +sub owner { + my ($self, $owner, $user, $host, $time) = @_; + if ($owner) { + my $acl; + eval { $acl = Wallet::ACL->new ($owner, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + return $self->_set_internal ('owner', $acl->id, $user, $host, $time); + } elsif (defined $owner) { + return $self->_set_internal ('owner', undef, $user, $host, $time); + } else { + return $self->_get_internal ('owner'); + } +} + +############################################################################## +# Flags +############################################################################## + +# Check whether a flag is set on the object. Returns true if set, 0 if not +# set, and undef on error. +sub flag_check { + my ($self, $flag) = @_; + my $name = $self->{name}; + my $type = $self->{type}; + my $schema = $self->{schema}; + my $value; + eval { + my %search = (fl_type => $type, + fl_name => $name, + fl_flag => $flag); + my $flag = $schema->resultset('Flag')->find (\%search); + if (not defined $flag) { + $value = 0; + } else { + $value = $flag->fl_flag; + } + }; + if ($@) { + $self->error ("cannot check flag $flag for ${type}:${name}: $@"); + return; + } else { + return ($value) ? 1 : 0; + } +} + +# Clear a flag on an object. Takes the flag and trace information. Returns +# true on success and undef on failure. +sub flag_clear { + my ($self, $flag, $user, $host, $time) = @_; + $time ||= time; + my $name = $self->{name}; + my $type = $self->{type}; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; + eval { + my %search = (fl_type => $type, + fl_name => $name, + fl_flag => $flag); + my $flag = $schema->resultset('Flag')->find (\%search); + unless (defined $flag) { + die "flag not set\n"; + } + $flag->delete; + $self->log_set ('flags', $flag->fl_flag, undef, $user, $host, $time); + $guard->commit; + }; + if ($@) { + $self->error ("cannot clear flag $flag on ${type}:${name}: $@"); + return; + } + return 1; +} + +# List the flags on an object. Returns a list of flag names, which may be +# empty. On error, returns the empty list. The caller should call error() in +# this case to determine if an error occurred. +sub flag_list { + my ($self) = @_; + undef $self->{error}; + my @flags; + eval { + my %search = (fl_type => $self->{type}, + fl_name => $self->{name}); + my %attrs = (order_by => 'fl_flag'); + my @flags_rs = $self->{schema}->resultset('Flag')->search (\%search, + \%attrs); + for my $flag (@flags_rs) { + push (@flags, $flag->fl_flag); + } + }; + if ($@) { + my $id = $self->{type} . ':' . $self->{name}; + $self->error ("cannot retrieve flags for $id: $@"); + return; + } else { + return @flags; + } +} + +# Set a flag on an object. Takes the flag and trace information. Returns +# true on success and undef on failure. +sub flag_set { + my ($self, $flag, $user, $host, $time) = @_; + $time ||= time; + my $name = $self->{name}; + my $type = $self->{type}; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; + eval { + my %search = (fl_type => $type, + fl_name => $name, + fl_flag => $flag); + my $flag = $schema->resultset('Flag')->find (\%search); + if (defined $flag) { + die "flag already set\n"; + } + $flag = $schema->resultset('Flag')->create (\%search); + $self->log_set ('flags', undef, $flag->fl_flag, $user, $host, $time); + $guard->commit; + }; + if ($@) { + $self->error ("cannot set flag $flag on ${type}:${name}: $@"); + return; + } + return 1; +} + +############################################################################## +# History +############################################################################## + +# Expand a given ACL id to add its name, for readability. Returns the +# original id alone if there was a problem finding the name. +sub format_acl_id { + my ($self, $id) = @_; + my $name = $id; + + my %search = (ac_id => $id); + my $acl_rs = $self->{schema}->resultset('Acl')->find (\%search); + if (defined $acl_rs) { + $name = $acl_rs->ac_name . " ($id)"; + } + + return $name; +} + +# Return the formatted history for a given object or undef on error. +# Currently always returns the complete history, but eventually will need to +# provide some way of showing only recent entries. +sub history { + my ($self) = @_; + my $output = ''; + eval { + my %search = (oh_type => $self->{type}, + oh_name => $self->{name}); + my %attrs = (order_by => 'oh_on'); + my @history = $self->{schema}->resultset('ObjectHistory') + ->search (\%search, \%attrs); + + for my $history_rs (@history) { + $output .= sprintf ("%s %s ", $history_rs->oh_on->ymd, + $history_rs->oh_on->hms); + + my $old = $history_rs->oh_old; + my $new = $history_rs->oh_new; + my $action = $history_rs->oh_action; + my $field = $history_rs->oh_field; + + if ($action eq 'set' and $field eq 'flags') { + if (defined ($new)) { + $output .= "set flag $new"; + } elsif (defined ($old)) { + $output .= "clear flag $old"; + } + } elsif ($action eq 'set' and $field eq 'type_data') { + my $attr = $history_rs->oh_type_field; + if (defined ($old) and defined ($new)) { + $output .= "set attribute $attr to $new (was $old)"; + } elsif (defined ($old)) { + $output .= "remove $old from attribute $attr"; + } elsif (defined ($new)) { + $output .= "add $new to attribute $attr"; + } + } elsif ($action eq 'set' + and ($field eq 'owner' or $field =~ /^acl_/)) { + $old = $self->format_acl_id ($old) if defined ($old); + $new = $self->format_acl_id ($new) if defined ($new); + if (defined ($old) and defined ($new)) { + $output .= "set $field to $new (was $old)"; + } elsif (defined ($new)) { + $output .= "set $field to $new"; + } elsif (defined ($old)) { + $output .= "unset $field (was $old)"; + } + } elsif ($action eq 'set') { + if (defined ($old) and defined ($new)) { + $output .= "set $field to $new (was $old)"; + } elsif (defined ($new)) { + $output .= "set $field to $new"; + } elsif (defined ($old)) { + $output .= "unset $field (was $old)"; + } + } else { + $output .= $action; + } + $output .= sprintf ("\n by %s from %s\n", $history_rs->oh_by, + $history_rs->oh_from); + } + }; + if ($@) { + my $id = $self->{type} . ':' . $self->{name}; + $self->error ("cannot read history for $id: $@"); + return; + } + return $output; +} + +############################################################################## +# Object manipulation +############################################################################## + +# The get methods must always be overridden by the subclass. +sub get { die "Do not instantiate Wallet::Object::Base directly\n"; } + +# 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 { + my ($self, $data, $user, $host, $time) = @_; + my $id = $self->{type} . ':' . $self->{name}; + if ($self->flag_check ('locked')) { + $self->error ("cannot store $id: object is locked"); + return; + } + $self->error ("cannot store $id: object type is immutable"); + return; +} + +# The default show function. This may be adequate for many types; types that +# have additional data should call this method, grab the results, and then add +# their data on to the end. +sub show { + my ($self) = @_; + my $name = $self->{name}; + my $type = $self->{type}; + my @attrs = ([ ob_type => 'Type' ], + [ ob_name => 'Name' ], + [ ob_owner => 'Owner' ], + [ ob_acl_get => 'Get ACL' ], + [ ob_acl_store => 'Store ACL' ], + [ ob_acl_show => 'Show ACL' ], + [ ob_acl_destroy => 'Destroy ACL' ], + [ ob_acl_flags => 'Flags ACL' ], + [ ob_expires => 'Expires' ], + [ ob_comment => 'Comment' ], + [ ob_created_by => 'Created by' ], + [ ob_created_from => 'Created from' ], + [ ob_created_on => 'Created on' ], + [ ob_stored_by => 'Stored by' ], + [ ob_stored_from => 'Stored from' ], + [ ob_stored_on => 'Stored on' ], + [ ob_downloaded_by => 'Downloaded by' ], + [ ob_downloaded_from => 'Downloaded from' ], + [ ob_downloaded_on => 'Downloaded on' ]); + my $fields = join (', ', map { $_->[0] } @attrs); + my @data; + my $object_rs; + eval { + my %search = (ob_type => $type, + ob_name => $name); + $object_rs = $self->{schema}->resultset('Object')->find (\%search); + }; + if ($@) { + $self->error ("cannot retrieve data for ${type}:${name}: $@"); + return; + } + my $output = ''; + my @acls; + + # Format the results. We use a hack to insert the flags before the first + # trace field since they're not a field in the object in their own right. + # The comment should be word-wrapped at 80 columns. + for my $i (0 .. $#attrs) { + my $field = $attrs[$i][0]; + my $fieldtext = $attrs[$i][1]; + next unless my $value = $object_rs->get_column ($field); + + if ($field eq 'ob_comment' && length ($value) > 79 - 17) { + local $Text::Wrap::columns = 80; + local $Text::Wrap::unexpand = 0; + $value = wrap (' ' x 17, ' ' x 17, $value); + $value =~ s/^ {17}//; + } + if ($field eq 'ob_created_by') { + my @flags = $self->flag_list; + if (not @flags and $self->error) { + return; + } + if (@flags) { + $output .= sprintf ("%15s: %s\n", 'Flags', "@flags"); + } + my $attr_output = $self->attr_show; + if (not defined $attr_output) { + return; + } + $output .= $attr_output; + } + if ($field =~ /^ob_(owner|acl_)/) { + my $acl = eval { Wallet::ACL->new ($value, $self->{schema}) }; + if ($acl and not $@) { + $value = $acl->name || $value; + push (@acls, [ $acl, $value ]); + } + } + $output .= sprintf ("%15s: %s\n", $fieldtext, $value); + } + if (@acls) { + my %seen; + @acls = grep { !$seen{$_->[1]}++ } @acls; + for my $acl (@acls) { + $output .= "\n" . $acl->[0]->show; + } + } + return $output; +} + +# The default destroy function only destroys the database metadata. Generally +# subclasses need to override this to destroy whatever additional information +# is stored about this object. +sub destroy { + my ($self, $user, $host, $time) = @_; + $time ||= time; + my $name = $self->{name}; + my $type = $self->{type}; + if ($self->flag_check ('locked')) { + $self->error ("cannot destroy ${type}:${name}: object is locked"); + return; + } + my $guard = $self->{schema}->txn_scope_guard; + eval { + + # Remove any flags that may exist for the record. + my %search = (fl_type => $type, + fl_name => $name); + $self->{schema}->resultset('Flag')->search (\%search)->delete; + + # Remove any object records + %search = (ob_type => $type, + ob_name => $name); + $self->{schema}->resultset('Object')->search (\%search)->delete; + + # And create a new history object for the destroy action. + my %record = (oh_type => $type, + oh_name => $name, + oh_action => 'destroy', + oh_by => $user, + oh_from => $host, + oh_on => strftime ('%Y-%m-%d %T', localtime $time)); + $self->{schema}->resultset('ObjectHistory')->create (\%record); + $guard->commit; + }; + if ($@) { + $self->error ("cannot destroy ${type}:${name}: $@"); + return; + } + return 1; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +Wallet::Object::Base - Generic parent class for wallet objects + +=for stopwords +DBH HOSTNAME DATETIME ACL backend metadata timestamp Allbery wallet-backend +backend-specific subclasses + +=head1 SYNOPSIS + + package Wallet::Object::Simple; + @ISA = qw(Wallet::Object::Base); + sub get { + my ($self, $user, $host, $time) = @_; + $self->log_action ('get', $user, $host, $time) or return; + return "Some secure data"; + } + +=head1 DESCRIPTION + +Wallet::Object::Base is the generic parent class for wallet objects (data +types that can be stored in the wallet system). It provides default +functions and behavior, including handling generic object settings. All +handlers for objects stored in the wallet should inherit from it. It is +not used directly. + +=head1 PUBLIC CLASS METHODS + +The following methods are called by the rest of the wallet system and +should be implemented by all objects stored in the wallet. They should be +called with the desired wallet object class as the first argument +(generally using the Wallet::Object::Type->new syntax). + +=over 4 + +=item new(TYPE, NAME, DBH) + +Creates a new object with the given object type and name, based on data +already in the database. This method will only succeed if an object of +the given TYPE and NAME is already present in the wallet database. If no +such object exits, throws an exception. Otherwise, returns an object +blessed into the class used for the new() call (so subclasses can leave +this method alone and not override it). + +Takes a Wallet::Schema object, which is stored in the object and used +for any further operations. + +=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME]) + +Similar to new() but instead creates a new entry in the database. This +method will throw an exception if an entry for that type and name already +exists in the database or if creating the database record fails. +Otherwise, a new database entry will be created with that type and name, +no owner, no ACLs, no expiration, no flags, and with created by, from, and +on set to the PRINCIPAL, HOSTNAME, and DATETIME parameters. If DATETIME +isn't given, the current time is used. The database handle is treated as +with new(). + +=back + +=head1 PUBLIC INSTANCE METHODS + +The following methods may be called on instantiated wallet objects. +Normally, the only methods that a subclass will need to override are +get(), store(), show(), and destroy(). + +If the locked flag is set on an object, no actions may be performed on +that object except for the flag methods and show(). All other actions +will be rejected with an error saying the object is locked. + +=over 4 + +=item acl(TYPE [, ACL, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves a given object ACL as a numeric ACL ID. TYPE must be +one of C, C, C, C, or C, corresponding +to the ACLs kept on an object. If no other arguments are given, returns +the current ACL setting as an ACL ID or undef if that ACL isn't set. If +other arguments are given, change that ACL to ACL and return true on +success and false on failure. Pass in the empty string for ACL to clear +the ACL. The other arguments are used for logging and history and should +indicate the user and host from which the change is made and the time of +the change. + +=item attr(ATTRIBUTE [, VALUES, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves a given object attribute. Attributes are used to store +backend-specific information for a particular object type and ATTRIBUTE +must be an attribute type known to the underlying object implementation. +The default implementation of this method rejects all attributes as +unknown. + +If no other arguments besides ATTRIBUTE are given, returns the values of +that attribute, if any, as a list. On error, returns the empty list. To +distinguish between an error and an empty return, call error() afterward. +It is guaranteed to return undef unless there was an error. + +If other arguments are given, sets the given ATTRIBUTE values to VALUES, +which must be a reference to an array (even if only one value is being +set). Pass a reference to an empty array to clear the attribute values. +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. Returns true on success and false on failure. + +=item attr_show() + +Returns a formatted text description of the type-specific attributes of +the object, or undef on error. The default implementation of this method +always returns the empty string. If there are any type-specific +attributes set, this method should return that metadata, formatted as key: +value pairs with the keys right-aligned in the first 15 characters, +followed by a space, a colon, and the value. + +=item comment([COMMENT, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves the comment associated with an object. If no arguments +are given, returns the current comment or undef if no comment is set. If +arguments are given, change the comment to COMMENT and return true on +success and false on failure. Pass in the empty string for COMMENT to +clear the comment. + +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. + +=item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) + +Destroys the object by removing all record of it from the database. The +Wallet::Object::Base implementation handles the generic database work, but +any subclass should override this method to do any deletion of files or +entries in external databases and any other database entries and then call +the parent method to handle the generic database cleanup. Returns true on +success and false on failure. The arguments are used for logging and +history and should indicate the user and host from which the change is +made and the time of the change. + +=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. + +For the convenience of child classes, this method can also be called with +one or more error strings. If so, those strings are concatenated +together, trailing newlines are removed, any text of the form S> at the end of the message is stripped off, and the result is +stored as the error. Only child classes should call this method with an +error string. + +=item expires([EXPIRES, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves the expiration date of an object. If no arguments are +given, returns the current expiration or undef if no expiration is set. +If arguments are given, change the expiration to EXPIRES and return true +on success and false on failure. EXPIRES must be in the format +C, although the time portion may be omitted. Pass in +the empty string for EXPIRES to clear the expiration date. + +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. + +=item flag_check(FLAG) + +Check whether the given flag is set on an object. Returns true if set, +C<0> if not set, and undef on error. + +=item flag_clear(FLAG, PRINCIPAL, HOSTNAME [, DATETIME]) + +Clears FLAG on an object. Returns true on success and false on failure. +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. + +=item flag_list() + +List the flags set on an object. If no flags are set, returns the empty +list. On failure, returns an empty list. To distinguish between the +empty response and an error, the caller should call error() after an empty +return. It is guaranteed to return undef if there was no error. + +=item flag_set(FLAG, PRINCIPAL, HOSTNAME [, DATETIME]) + +Sets FLAG on an object. Returns true on success and false on failure. +The other arguments are used for logging and history and should indicate +the user and host from which the change is made and the time of the +change. + +=item get(PRINCIPAL, HOSTNAME [, DATETIME]) + +An object implementation must override this method with one that returns +either the data of the object or undef on some error, using the provided +arguments to update history information. The Wallet::Object::Base +implementation just throws an exception. + +=item history() + +Returns the formatted history for the object. There will be two lines for +each action on the object. The first line has the timestamp of the action +and the action, and the second line gives the user who performed the +action and the host from which they performed it (based on the trace +information passed into the other object methods). + +=item name() + +Returns the object's name. + +=item owner([OWNER, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves the owner of an object as a numeric ACL ID. If no +arguments are given, returns the current owner ACL ID or undef if none is +set. If arguments are given, change the owner to OWNER and return true on +success and false on failure. Pass in the empty string for OWNER to clear +the owner. The other arguments are used for logging and history and +should indicate the user and host from which the change is made and the +time of the change. + +=item show() + +Returns a formatted text description of the object suitable for human +display, or undef on error. All of the base metadata about the object, +formatted as key: value pairs with the keys aligned in the first 15 +characters followed by a space, a colon, and the value. The attr_show() +method of the object is also called and any formatted output it returns +will be included. If any ACLs or an owner are set, after this data there +is a blank line and then the information for each unique ACL, separated by +blank lines. + +=item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME]) + +Store user-supplied data into the given object. This may not be supported +by all backends (for instance, backends that automatically generate the +data will not support this). The default implementation rejects all +store() calls with an error message saying that the object is immutable. + +=item type() + +Returns the object's type. + +=back + +=head1 UTILITY METHODS + +The following instance methods should not be called externally but are +provided for subclasses to call to implement some generic actions. + +=over 4 + +=item log_action (ACTION, PRINCIPAL, HOSTNAME, DATETIME) + +Updates the history tables and trace information appropriately for ACTION, +which should be either C or C. No other changes are made to +the database, just updates of the history table and trace fields with the +provided data about who performed the action and when. + +This function commits its transaction when complete and therefore should +not be called inside another transaction. Normally it's called as a +separate transaction after the data is successfully stored or retrieved. + +=item log_set (FIELD, OLD, NEW, PRINCIPAL, HOSTNAME, DATETIME) + +Updates the history tables for the change in a setting value for an +object. FIELD should be one of C, C, C, +C, C, C, C, C, or a +value starting with C followed by a space and a type-specific +field name. The last form is the most common form used by a subclass. +OLD is the previous value of the field or undef if the field was unset, +and NEW is the new value of the field or undef if the field should be +unset. + +This function does not commit and does not catch database exceptions. It +should normally be called as part of a larger transaction that implements +the change in the setting. + +=back + +=head1 SEE ALSO + +wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Object/Duo.pm b/perl/lib/Wallet/Object/Duo.pm new file mode 100644 index 0000000..e5773c8 --- /dev/null +++ b/perl/lib/Wallet/Object/Duo.pm @@ -0,0 +1,331 @@ +# Wallet::Object::Duo -- Duo integration object implementation for the wallet. +# +# Written by Russ Allbery +# Copyright 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Object::Duo; +require 5.006; + +use strict; +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::Base; + +@ISA = qw(Wallet::Object::Base); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.01'; + +############################################################################## +# Core methods +############################################################################## + +# Override attr_show to display the Duo integration key attribute. +sub attr_show { + my ($self) = @_; + my $output = ''; + 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; + } + return sprintf ("%15s: %s\n", 'Duo key', $key); +} + +# Override new to start by creating a Net::Duo::Admin object for subsequent +# calls. +sub new { + my ($class, $type, $name, $schema) = @_; + + # We have to have a Duo integration key file set. + if (not $Wallet::Config::DUO_KEY_FILE) { + die "duo object implementation not configured\n"; + } + my $key_file = $Wallet::Config::DUO_KEY_FILE; + my $agent = $Wallet::Config::DUO_AGENT; + + # Construct the Net::Duo::Admin object. + require Net::Duo::Admin; + my $duo = Net::Duo::Admin->new ( + { + key_file => $key_file, + user_agent => $agent, + } + ); + + # Construct the object. + my $self = $class->SUPER::new ($type, $name, $schema); + $self->{duo} = $duo; + return $self; +} + +# Override create to start by creating a new integration in Duo, and only +# create the entry in the database if that succeeds. Error handling isn't +# 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) = @_; + + # We have to have a Duo integration key file set. + if (not $Wallet::Config::DUO_KEY_FILE) { + die "duo object implementation not configured\n"; + } + my $key_file = $Wallet::Config::DUO_KEY_FILE; + my $agent = $Wallet::Config::DUO_AGENT; + + # Construct the Net::Duo::Admin object. + require Net::Duo::Admin; + my $duo = Net::Duo::Admin->new ( + { + key_file => $key_file, + user_agent => $agent, + } + ); + + # Create the object in Duo. + require Net::Duo::Admin::Integration; + my %data = ( + name => $name, + notes => 'Managed by wallet', + type => $Wallet::Config::DUO_TYPE, + ); + my $integration = Net::Duo::Admin::Integration->create ($duo, \%data); + + # Create the object in wallet. + my @trace = ($creator, $host, $time); + my $self = $class->SUPER::create ($type, $name, $schema, @trace); + $self->{duo} = $duo; + + # Add the integration key to the object metadata. + my $guard = $self->{schema}->txn_scope_guard; + eval { + my %record = ( + du_name => $name, + du_key => $integration->integration_key, + ); + $self->{schema}->resultset ('Duo')->create (\%record); + $guard->commit; + }; + if ($@) { + my $id = $self->{type} . ':' . $self->{name}; + $self->error ("cannot set Duo key for $id: $@"); + return; + } + + # Done. Return the object. + return $self; +} + +# Override destroy to delete the integration out of Duo as well. +sub destroy { + my ($self, $user, $host, $time) = @_; + my $id = $self->{type} . ':' . $self->{name}; + if ($self->flag_check ('locked')) { + $self->error ("cannot destroy $id: object is locked"); + return; + } + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; + eval { + my %search = (du_name => $self->{name}); + my $row = $schema->resultset ('Duo')->find (\%search); + my $key = $row->get_column ('du_key'); + my $int = Net::Duo::Admin::Integration->new ($self->{duo}, $key); + $int->delete; + $row->delete; + $guard->commit; + }; + if ($@) { + $self->error ($@); + return; + } + return $self->SUPER::destroy ($user, $host, $time); +} + +# Our get implementation. Retrieve the integration information from Duo and +# construct the configuration file expected by the Duo 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); + 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 - Duo integration object implementation for wallet + +=head1 SYNOPSIS + + my @name = qw(duo host.example.com); + my @trace = ($user, $host, time); + my $object = Wallet::Object::Duo->create (@name, $schema, @trace); + my $config = $object->get (@trace); + $object->destroy (@trace); + +=head1 DESCRIPTION + +Wallet::Object::Duo is a representation of Duo integrations the wallet. +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. + +Currently, only one configured integration type can be managed by the +wallet, and 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 for details on supported configuration parameters and +information about how to set wallet configuration. + +=head1 METHODS + +This object mostly inherits from Wallet::Object::Base. 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 is a class method and should be called on the Wallet::Object::Duo +class. It creates a new object with the given TYPE and NAME (TYPE is +normally C 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. The new integration's type is controlled by the DUO_TYPE +configuration variable, which defaults to C. See L +for more information. + +If create() fails, it throws an exception. + +=item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) + +Destroys a Duo integration object by removing it from the database and +deleting the integration from Duo. If deleting the Duo integration fails, +destroy() fails. Returns true on success and false on failure. The +caller should call error() to get the error message after a failure. +PRINCIPAL, HOSTNAME, and DATETIME are stored as history information. +PRINCIPAL should be the user who is destroying the object. If DATETIME +isn't given, the current time is used. + +=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 = + skey = + host = + +The C 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. +Currently, only one Duo integration type is supported as well. Further +development should expand the available integration types, possibly as +additional wallet object types. + +=head1 SEE ALSO + +Net::Duo(3), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Object/File.pm b/perl/lib/Wallet/Object/File.pm new file mode 100644 index 0000000..4afef04 --- /dev/null +++ b/perl/lib/Wallet/Object/File.pm @@ -0,0 +1,242 @@ +# Wallet::Object::File -- File object implementation for the wallet. +# +# Written by Russ Allbery +# Copyright 2008, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Object::File; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Digest::MD5 qw(md5_hex); +use Wallet::Config (); +use Wallet::Object::Base; + +@ISA = qw(Wallet::Object::Base); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.03'; + +############################################################################## +# File naming +############################################################################## + +# Returns the path into which that file 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::FILE_BUCKET) { + $self->error ('file support not configured'); + return; + } + unless ($name) { + $self->error ('file 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::FILE_BUCKET/$hash"; + unless (-d $parent || mkdir ($parent, 0700)) { + $self->error ("cannot create file bucket $hash: $!"); + return; + } + return "$Wallet::Config::FILE_BUCKET/$hash/$name"; +} + +############################################################################## +# Core methods +############################################################################## + +# Override destroy to delete the file as well. +sub destroy { + my ($self, $user, $host, $time) = @_; + my $id = $self->{type} . ':' . $self->{name}; + my $path = $self->file_path; + if (defined ($path) && -f $path && !unlink ($path)) { + $self->error ("cannot delete $id: $!"); + return; + } + return $self->SUPER::destroy ($user, $host, $time); +} + +# Return the contents of the file. +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 $path = $self->file_path; + return unless $path; + unless (open (FILE, '<', $path)) { + $self->error ("cannot get $id: object has not been stored"); + return; + } + local $/; + my $data = ; + unless (close FILE) { + $self->error ("cannot get $id: $!"); + return; + } + $self->log_action ('get', $user, $host, $time); + return $data; +} + +# Store the file on the wallet server. +sub store { + my ($self, $data, $user, $host, $time) = @_; + $time ||= time; + my $id = $self->{type} . ':' . $self->{name}; + if ($self->flag_check ('locked')) { + $self->error ("cannot store $id: object is locked"); + return; + } + if ($Wallet::Config::FILE_MAX_SIZE) { + my $max = $Wallet::Config::FILE_MAX_SIZE; + if (length ($data) > $max) { + $self->error ("data exceeds maximum of $max bytes"); + return; + } + } + my $path = $self->file_path; + return unless $path; + unless (open (FILE, '>', $path)) { + $self->error ("cannot store $id: $!"); + return; + } + unless (print FILE ($data) and close FILE) { + $self->error ("cannot store $id: $!"); + close FILE; + return; + } + $self->log_action ('store', $user, $host, $time); + return 1; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +Wallet::Object::File - File 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::Keytab->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::File is a representation of simple file objects in the +wallet. 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 file object is deleted. A file object must be stored before +it can be retrieved with get. + +To use this object, the configuration option specifying where on the +wallet server to store file objects must be set. See L +for details on this configuration parameter and information about how to +set wallet configuration. + +=head1 METHODS + +This object mostly inherits from Wallet::Object::Base. 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 destroy(PRINCIPAL, HOSTNAME [, DATETIME]) + +Destroys a file object by removing it from the database and deleting the +corresponding file on the wallet server. Returns true on success and +false on failure. The caller should call error() to get the error message +after a failure. PRINCIPAL, HOSTNAME, and DATETIME are stored as history +information. PRINCIPAL should be the user who is destroying the object. +If DATETIME isn't given, the current time is used. + +=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. + +=item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME]) + +Store DATA as the current contents of the file object. Any existing data +will be overwritten. Returns true on success and false on failure. The +caller should call error() to get the error message after a failure. +PRINCIPAL, HOSTNAME, and DATETIME are stored as history information. +PRINCIPAL should be the user who is destroying the object. If DATETIME +isn't given, the current time is used. + +If FILE_MAX_SIZE is set in the wallet configuration, a store() of DATA +larger than that configuration setting will be rejected. + +=back + +=head1 FILES + +=over 4 + +=item FILE_BUCKET// + +Files are stored on the wallet server under the directory FILE_BUCKET as +set in the wallet configuration. is the first two characters of +the hex-encoded MD5 hash of the wallet file object name, used to not put +too many files in the same directory. is the name of the file +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 file object names. +However, due to limitations in the B server usually used to run +B, file 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 file object name. + +=head1 SEE ALSO + +remctld(8), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Object/Keytab.pm b/perl/lib/Wallet/Object/Keytab.pm new file mode 100644 index 0000000..24c3302 --- /dev/null +++ b/perl/lib/Wallet/Object/Keytab.pm @@ -0,0 +1,513 @@ +# Wallet::Object::Keytab -- Keytab object implementation for the wallet. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2009, 2010, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Object::Keytab; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Wallet::Config (); +use Wallet::Object::Base; +use Wallet::Kadmin; + +@ISA = qw(Wallet::Object::Base); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.09'; + +############################################################################## +# Enctype restriction +############################################################################## + +# Set the enctype restrictions for a keytab. Called by attr() and takes a +# reference to the encryption types to set. Returns true on success and false +# on failure, setting the object error if it fails. +sub enctypes_set { + my ($self, $enctypes, $user, $host, $time) = @_; + $time ||= time; + my @trace = ($user, $host, $time); + my $name = $self->{name}; + my %enctypes = map { $_ => 1 } @$enctypes; + my $guard = $self->{schema}->txn_scope_guard; + eval { + # Find all enctypes for the given keytab. + my %search = (ke_name => $name); + my @enctypes = $self->{schema}->resultset('KeytabEnctype') + ->search (\%search); + my (@current); + for my $enctype_rs (@enctypes) { + push (@current, $enctype_rs->ke_enctype); + } + + # Use the existing enctypes and the enctypes we should have to match + # against ones that need to be removed, and note those that already + # exist. + for my $enctype (@current) { + if ($enctypes{$enctype}) { + delete $enctypes{$enctype}; + } else { + %search = (ke_name => $name, + ke_enctype => $enctype); + $self->{schema}->resultset('KeytabEnctype')->find (\%search) + ->delete; + $self->log_set ('type_data enctypes', $enctype, undef, @trace); + } + } + + # When inserting new enctypes, we unfortunately have to do the + # consistency check against the enctypes table ourselves, since SQLite + # doesn't enforce integrity constraints. We do this in sorted order + # to make it easier to test. + for my $enctype (sort keys %enctypes) { + my %search = (en_name => $enctype); + my $enctype_rs = $self->{schema}->resultset('Enctype') + ->find (\%search); + unless (defined $enctype_rs) { + die "unknown encryption type $enctype\n"; + } + my %record = (ke_name => $name, + ke_enctype => $enctype); + $self->{schema}->resultset('KeytabEnctype')->create (\%record); + $self->log_set ('type_data enctypes', undef, $enctype, @trace); + } + $guard->commit; + }; + if ($@) { + $self->error ($@); + return; + } + return 1; +} + +# Return a list of the encryption types current set for a keytab. Called by +# attr() or get(). Returns the empty list on failure or on an empty list of +# enctype restrictions, but sets the object error on failure so the caller +# should use that to determine success. +sub enctypes_list { + my ($self) = @_; + my @enctypes; + eval { + my %search = (ke_name => $self->{name}); + my %attrs = (order_by => 'ke_enctype'); + my @enctypes_rs = $self->{schema}->resultset('KeytabEnctype') + ->search (\%search, \%attrs); + for my $enctype_rs (@enctypes_rs) { + push (@enctypes, $enctype_rs->ke_enctype); + } + }; + if ($@) { + $self->error ($@); + return; + } + return @enctypes; +} + +############################################################################## +# Synchronization +############################################################################## + +# Set a synchronization target or clear the targets if $targets is an +# empty list. Returns true on success and false on failure. +# +# Currently, no synchronization targets are supported, but we preserve the +# ability to clear synchronization and the basic structure of the code so +# that they can be added later. +sub sync_set { + my ($self, $targets, $user, $host, $time) = @_; + $time ||= time; + my @trace = ($user, $host, $time); + if (@$targets > 1) { + $self->error ('only one synchronization target supported'); + return; + } elsif (@$targets) { + my $target = $targets->[0]; + $self->error ("unsupported synchronization target $target"); + return; + } else { + my $guard = $self->{schema}->txn_scope_guard; + eval { + my $name = $self->{name}; + my %search = (ks_name => $name); + my $sync_rs = $self->{schema}->resultset('KeytabSync') + ->find (\%search); + if (defined $sync_rs) { + my $target = $sync_rs->ks_target; + $sync_rs->delete; + $self->log_set ('type_data sync', $target, undef, @trace); + } + $guard->commit; + }; + if ($@) { + $self->error ($@); + return; + } + } + return 1; +} + +# Return a list of the current synchronization targets. Returns the empty +# list on failure or on an empty list of enctype restrictions, but sets +# the object error on failure so the caller should use that to determine +# success. +sub sync_list { + my ($self) = @_; + my @targets; + eval { + my %search = (ks_name => $self->{name}); + my %attrs = (order_by => 'ks_target'); + my @syncs = $self->{schema}->resultset('KeytabSync')->search (\%search, + \%attrs); + for my $sync_rs (@syncs) { + push (@targets, $sync_rs->ks_target); + } + }; + if ($@) { + $self->error ($@); + return; + } + return @targets; +} + +############################################################################## +# Core methods +############################################################################## + +# Override attr to support setting the enctypes and sync attributes. Note +# that the sync attribute has no supported targets at present and hence will +# always return an error, but the code is still here so that it doesn't have +# to be rewritten once a new sync target is added. +sub attr { + my ($self, $attribute, $values, $user, $host, $time) = @_; + $time ||= time; + my @trace = ($user, $host, $time); + my %known = map { $_ => 1 } qw(enctypes sync); + undef $self->{error}; + unless ($known{$attribute}) { + $self->error ("unknown attribute $attribute"); + return; + } + if ($values) { + if ($attribute eq 'enctypes') { + return $self->enctypes_set ($values, $user, $host, $time); + } elsif ($attribute eq 'sync') { + return $self->sync_set ($values, $user, $host, $time); + } + } else { + if ($attribute eq 'enctypes') { + return $self->enctypes_list; + } elsif ($attribute eq 'sync') { + return $self->sync_list; + } + } +} + +# Override attr_show to display the enctypes and sync attributes. +sub attr_show { + my ($self) = @_; + my $output = ''; + my @targets = $self->attr ('sync'); + if (not @targets and $self->error) { + return; + } elsif (@targets) { + $output .= sprintf ("%15s: %s\n", 'Synced with', "@targets"); + } + my @enctypes = $self->attr ('enctypes'); + if (not @enctypes and $self->error) { + return; + } elsif (@enctypes) { + $output .= sprintf ("%15s: %s\n", 'Enctypes', $enctypes[0]); + shift @enctypes; + for my $enctype (@enctypes) { + $output .= (' ' x 17) . $enctype . "\n"; + } + } + return $output; +} + +# Override new to start by creating a handle for the kadmin module we're +# using. +sub new { + my ($class, $type, $name, $schema) = @_; + my $self = { + schema => $schema, + kadmin => undef, + }; + bless $self, $class; + my $kadmin = Wallet::Kadmin->new (); + $self->{kadmin} = $kadmin; + + $self = $class->SUPER::new ($type, $name, $schema); + $self->{kadmin} = $kadmin; + return $self; +} + +# Override create to start by creating the principal in Kerberos and only +# create the entry in the database if that succeeds. Error handling isn't +# 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) = @_; + my $self = { + schema => $schema, + kadmin => undef, + }; + bless $self, $class; + my $kadmin = Wallet::Kadmin->new (); + $self->{kadmin} = $kadmin; + + if (not $kadmin->create ($name)) { + die $kadmin->error, "\n"; + } + $self = $class->SUPER::create ($type, $name, $schema, $creator, $host, + $time); + $self->{kadmin} = $kadmin; + return $self; +} + +# Override destroy to delete the principal out of Kerberos as well. +sub destroy { + my ($self, $user, $host, $time) = @_; + my $id = $self->{type} . ':' . $self->{name}; + if ($self->flag_check ('locked')) { + $self->error ("cannot destroy $id: object is locked"); + return; + } + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; + eval { + my %search = (ks_name => $self->{name}); + my $sync_rs = $schema->resultset('KeytabSync')->search (\%search); + $sync_rs->delete_all if defined $sync_rs; + + %search = (ke_name => $self->{name}); + my $enctype_rs = $schema->resultset('KeytabEnctype')->search (\%search); + $enctype_rs->delete_all if defined $enctype_rs; + + $guard->commit; + }; + if ($@) { + $self->error ($@); + return; + } + my $kadmin = $self->{kadmin}; + if (not $kadmin->destroy ($self->{name})) { + $self->error ($kadmin->error); + return; + } + return $self->SUPER::destroy ($user, $host, $time); +} + +# Our get implementation. Generate a keytab into a temporary file and then +# 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); + } + return $result; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +keytab API KDC keytabs HOSTNAME DATETIME enctypes enctype DBH metadata +unmanaged kadmin Allbery unlinked + +=head1 NAME + +Wallet::Object::Keytab - Keytab object implementation for wallet + +=head1 SYNOPSIS + + my @name = qw(keytab host/shell.example.com); + my @trace = ($user, $host, time); + my $object = Wallet::Object::Keytab->create (@name, $schema, @trace); + my $keytab = $object->get (@trace); + $object->destroy (@trace); + +=head1 DESCRIPTION + +Wallet::Object::Keytab is a representation of Kerberos keytab objects in +the wallet. It implements the wallet object API and provides the +necessary glue to create principals in a Kerberos KDC, create and return +keytabs for those principals, and delete them out of Kerberos when the +wallet object is destroyed. + +A keytab is an on-disk store for the key or keys for a Kerberos principal. +Keytabs are used by services to verify incoming authentication from +clients or by automated processes that need to authenticate to Kerberos. +To create a keytab, the principal has to be created in Kerberos and then a +keytab is generated and stored in a file on disk. + +This implementation generates a new random key (and hence invalidates all +existing keytabs) each time the keytab is retrieved with the get() method. + +To use this object, several configuration parameters must be set. See +L for details on those configuration parameters and +information about how to set wallet configuration. + +=head1 METHODS + +This object mostly inherits from Wallet::Object::Base. 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 attr(ATTRIBUTE [, VALUES, PRINCIPAL, HOSTNAME [, DATETIME]]) + +Sets or retrieves a given object attribute. The following attribute is +supported: + +=over 4 + +=item enctypes + +Restricts the generated keytab to a specific set of encryption types. The +values of this attribute must be enctype strings recognized by Kerberos +(strings like C or C). Encryption +types must also be present in the list of supported enctypes stored in the +database database or the attr() method will reject them. Note that the +salt should not be included; since the salt is irrelevant for keytab keys, +it will always be set to the default by the wallet. + +If this attribute is set, the principal will be restricted to that +specific enctype list when get() is called for that keytab. If it is not +set, the default set in the KDC will be used. + +This attribute is ignored if the C flag is set on a keytab. +Keytabs retrieved with C set will contain all keys present in +the KDC for that Kerberos principal and therefore may contain different +enctypes than those requested by this attribute. + +=item sync + +This attribute is intended to set a list of external systems with which +data about this keytab is synchronized, but there are no supported targets +currently. However, there is support for clearing this attribute or +returning its current value. + +=back + +If no other arguments besides ATTRIBUTE are given, returns the values of +that attribute, if any, as a list. On error, returns the empty list. To +distinguish between an error and an empty return, call error() afterward. +It is guaranteed to return undef unless there was an error. + +If other arguments are given, sets the given ATTRIBUTE values to VALUES, +which must be a reference to an array (even if only one value is being +set). Pass a reference to an empty array to clear the attribute values. +PRINCIPAL, HOSTNAME, and DATETIME are stored as history information. +PRINCIPAL should be the user who is destroying the object. If DATETIME +isn't given, the current time is used. + +=item create(TYPE, NAME, DBH, PRINCIPAL, HOSTNAME [, DATETIME]) + +This is a class method and should be called on the Wallet::Object::Keytab +class. It creates a new object with the given TYPE and NAME (TYPE is +normally C 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 keytab object is created, the Kerberos principal designated by +NAME is also created in the Kerberos realm determined from the wallet +configuration. If the principal already exists, create() still succeeds +(so that a previously unmanaged principal can be imported into the +wallet). Otherwise, if the Kerberos principal could not be created, +create() fails. The principal is created with the randomized keys. NAME +must not contain the realm; instead, the KEYTAB_REALM configuration +variable should be set. See L for more information. + +If create() fails, it throws an exception. + +=item destroy(PRINCIPAL, HOSTNAME [, DATETIME]) + +Destroys a keytab object by removing it from the database and deleting the +principal out of Kerberos. If deleting the principal fails, destroy() +fails, but destroy() succeeds if the principal didn't exist when it was +called (so that it can be used to clean up stranded entries). Returns +true on success and false on failure. The caller should call error() to +get the error message after a failure. PRINCIPAL, HOSTNAME, and DATETIME +are stored as history information. PRINCIPAL should be the user who is +destroying the object. If DATETIME isn't given, the current time is used. + +=item get(PRINCIPAL, HOSTNAME [, DATETIME]) + +Retrieves a keytab for this object and returns the keytab data or undef on +error. The caller should call error() to get the error message if get() +returns undef. The keytab is created with new randomized keys, +invalidating any existing keytabs for that principal, unless the +unchanging flag is set on the object. 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 KEYTAB_TMP/keytab. + +The keytab is created in this file and then read into memory. KEYTAB_TMP +is set in the wallet configuration, and is the process ID of the +current process. The file is unlinked after being read. + +=back + +=head1 LIMITATIONS + +Only one Kerberos realm is supported for a given wallet implementation and +all keytab objects stored must be in that realm. Keytab names in the +wallet database do not have realm information. + +=head1 SEE ALSO + +kadmin(8), Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Object/WAKeyring.pm b/perl/lib/Wallet/Object/WAKeyring.pm new file mode 100644 index 0000000..f8bd0f7 --- /dev/null +++ b/perl/lib/Wallet/Object/WAKeyring.pm @@ -0,0 +1,370 @@ +# Wallet::Object::WAKeyring -- WebAuth keyring object implementation. +# +# Written by Russ Allbery +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Object::WAKeyring; +require 5.006; + +use strict; +use vars qw(@ISA $VERSION); + +use Digest::MD5 qw(md5_hex); +use Fcntl qw(LOCK_EX); +use Wallet::Config (); +use Wallet::Object::Base; +use WebAuth 3.06 qw(WA_KEY_AES WA_AES_128); + +@ISA = qw(Wallet::Object::Base); + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.01'; + +############################################################################## +# File naming +############################################################################## + +# Returns the path into which that keyring 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::WAKEYRING_BUCKET) { + $self->error ('WebAuth keyring support not configured'); + return; + } + unless ($name) { + $self->error ('WebAuth keyring 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::WAKEYRING_BUCKET/$hash"; + unless (-d $parent || mkdir ($parent, 0700)) { + $self->error ("cannot create keyring bucket $hash: $!"); + return; + } + return "$Wallet::Config::WAKEYRING_BUCKET/$hash/$name"; +} + +############################################################################## +# Core methods +############################################################################## + +# Override destroy to delete the file as well. +sub destroy { + my ($self, $user, $host, $time) = @_; + my $id = $self->{type} . ':' . $self->{name}; + my $path = $self->file_path; + if (defined ($path) && -f $path && !unlink ($path)) { + $self->error ("cannot delete $id: $!"); + return; + } + return $self->SUPER::destroy ($user, $host, $time); +} + +# Update the keyring if needed, and then return the contents of the current +# keyring. +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 $path = $self->file_path; + return unless defined $path; + + # Create a WebAuth context and ensure we can load the relevant modules. + my $wa = eval { WebAuth->new }; + if ($@) { + $self->error ("cannot initialize WebAuth: $@"); + return; + } + + # Check if the keyring already exists. If not, create a new one with a + # single key that's immediately valid and two more that will become valid + # in the future. + # + # If the keyring does already exist, get a lock on the file. At the end + # of this process, we'll do an atomic update and then drop our lock. + # + # FIXME: There are probably better ways to do this. There are some race + # conditions here, particularly with new keyrings. + unless (open (FILE, '+<', $path)) { + my $data; + eval { + my $key = $wa->key_create (WA_KEY_AES, WA_AES_128); + my $ring = $wa->keyring_new ($key); + $key = $wa->key_create (WA_KEY_AES, WA_AES_128); + my $valid = time + $Wallet::Config::WAKEYRING_REKEY_INTERVAL; + $ring->add (time, $valid, $key); + $key = $wa->key_create (WA_KEY_AES, WA_AES_128); + $valid += $Wallet::Config::WAKEYRING_REKEY_INTERVAL; + $ring->add (time, $valid, $key); + $data = $ring->encode; + $ring->write ($path); + }; + if ($@) { + $self->error ("cannot create new keyring"); + return; + }; + $self->log_action ('get', $user, $host, $time); + return $data; + } + unless (flock (FILE, LOCK_EX)) { + $self->error ("cannot get lock on keyring: $!"); + return; + } + + # Read the keyring. + my $ring = eval { WebAuth::Keyring->read ($wa, $path) }; + if ($@) { + $self->error ("cannot read keyring: $@"); + return; + } + + # If the most recent key has a valid-after older than now + + # WAKEYRING_REKEY_INTERVAL, we generate a new key with a valid_after of + # now + 2 * WAKEYRING_REKEY_INTERVAL. + my ($count, $newest) = (0, 0); + for my $entry ($ring->entries) { + $count++; + if ($entry->valid_after > $newest) { + $newest = $entry->valid_after; + } + } + eval { + if ($newest <= time + $Wallet::Config::WAKEYRING_REKEY_INTERVAL) { + my $valid = time + 2 * $Wallet::Config::WAKEYRING_REKEY_INTERVAL; + my $key = $wa->key_create (WA_KEY_AES, WA_AES_128); + $ring->add (time, $valid, $key); + } + }; + if ($@) { + $self->error ("cannot add new key: $@"); + return; + } + + # If there are any keys older than the purge interval, remove them, but + # only do so if we have more than three keys (the one that's currently + # active, the one that's going to come active in the rekey interval, and + # the one that's going to come active after that. + # + # FIXME: Be sure that we don't remove the last currently-valid key. + my $cutoff = time - $Wallet::Config::WAKEYRING_PURGE_INTERVAL; + my $i = 0; + my @purge; + if ($count > 3) { + for my $entry ($ring->entries) { + if ($entry->creation < $cutoff) { + push (@purge, $i); + } + $i++; + } + } + if (@purge && $count - @purge >= 3) { + eval { + for my $key (reverse @purge) { + $ring->remove ($key); + } + }; + if ($@) { + $self->error ("cannot remove old keys: $@"); + return; + } + } + + # Encode the key. + my $data = eval { $ring->encode }; + if ($@) { + $self->error ("cannot encode keyring: $@"); + return; + } + + # Write the new keyring to the path. + eval { $ring->write ($path) }; + if ($@) { + $self->error ("cannot store new keyring: $@"); + return; + } + close FILE; + $self->log_action ('get', $user, $host, $time); + return $data; +} + +# Store the file on the wallet server. +# +# FIXME: Check the provided keyring for validity. +sub store { + my ($self, $data, $user, $host, $time) = @_; + $time ||= time; + my $id = $self->{type} . ':' . $self->{name}; + if ($self->flag_check ('locked')) { + $self->error ("cannot store $id: object is locked"); + return; + } + if ($Wallet::Config::FILE_MAX_SIZE) { + my $max = $Wallet::Config::FILE_MAX_SIZE; + if (length ($data) > $max) { + $self->error ("data exceeds maximum of $max bytes"); + return; + } + } + my $path = $self->file_path; + return unless $path; + unless (open (FILE, '>', $path)) { + $self->error ("cannot store $id: $!"); + return; + } + unless (print FILE ($data) and close FILE) { + $self->error ("cannot store $id: $!"); + close FILE; + return; + } + $self->log_action ('store', $user, $host, $time); + return 1; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +WebAuth keyring keyrings API HOSTNAME DATETIME keytab AES rekey Allbery + +=head1 NAME + +Wallet::Object::WAKeyring - WebAuth keyring object implementation for wallet + +=head1 SYNOPSIS + + my ($user, $host, $time); + my @name = qw(wa-keyring www.stanford.edu); + my @trace = ($user, $host, $time); + my $object = Wallet::Object::WAKeyring->create (@name, $schema, $trace); + my $keyring = $object->get (@trace); + unless ($object->store ($keyring)) { + die $object->error, "\n"; + } + $object->destroy (@trace); + +=head1 DESCRIPTION + +Wallet::Object::WAKeyring is a representation of a WebAuth keyring in the +wallet. It implements the wallet object API and provides the necessary +glue to store a keyring on the wallet server, retrieve it, update the +keyring with new keys automatically as needed, purge old keys +automatically, and delete the keyring when the object is deleted. + +WebAuth keyrings hold one or more keys. Each key has a creation time and +a validity time. The key cannot be used until its validity time has been +reached. This permits safe key rotation: a new key is added with a +validity time in the future, and then the keyring is updated everywhere it +needs to be before that validity time is reached. This wallet object +automatically handles key rotation by adding keys with validity dates in +the future and removing keys with creation dates substantially in the +past. + +To use this object, various configuration options specifying where to +store the keyrings and how to handle key rotation must be set. See +Wallet::Config for details on these configuration parameters and +information about how to set wallet configuration. + +=head1 METHODS + +This object mostly inherits from Wallet::Object::Base. 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 destroy(PRINCIPAL, HOSTNAME [, DATETIME]) + +Destroys a WebAuth keyring object by removing it from the database and +deleting the corresponding file on the wallet server. Returns true on +success and false on failure. The caller should call error() to get the +error message after a failure. PRINCIPAL, HOSTNAME, and DATETIME are +stored as history information. PRINCIPAL should be the user who is +destroying the object. If DATETIME isn't given, the current time is used. + +=item get(PRINCIPAL, HOSTNAME [, DATETIME]) + +Either creates a new WebAuth keyring (if this object has not bee stored or +retrieved before) or does any necessary periodic maintenance on the +keyring and then returns its data. 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. + +If this object has never been stored or retrieved before, a new keyring +will be created with three 128-bit AES keys: one that is immediately +valid, one that will become valid after the rekey interval, and one that +will become valid after twice the rekey interval. + +If keyring data for this object already exists, the creation and validity +dates for each key in the keyring will be examined. If the key with the +validity date the farthest into the future has a date that's less than or +equal to the current time plus the rekey interval, a new 128-bit AES key +will be added to the keyring with a validity time of twice the rekey +interval in the future. Finally, all keys with a creation date older than +the configured purge interval will be removed provided that the keyring +has at least three keys + +=item store(DATA, PRINCIPAL, HOSTNAME [, DATETIME]) + +Store DATA as the current contents of the WebAuth keyring object. Note +that this is not checked for validity, just assumed to be a valid keyring. +Any existing data will be overwritten. Returns true on success and false +on failure. The caller should call error() to get the error message after +a failure. PRINCIPAL, HOSTNAME, and DATETIME are stored as history +information. PRINCIPAL should be the user who is destroying the object. +If DATETIME isn't given, the current time is used. + +If FILE_MAX_SIZE is set in the wallet configuration, a store() of DATA +larger than that configuration setting will be rejected. + +=back + +=head1 FILES + +=over 4 + +=item WAKEYRING_BUCKET// + +WebAuth keyrings are stored on the wallet server under the directory +WAKEYRING_BUCKET as set in the wallet configuration. is the first +two characters of the hex-encoded MD5 hash of the wallet file object name, +used to not put too many files in the same directory. is the name +of the file object with all characters other than alphanumerics, +underscores, and dashes replaced by "%" and the hex code of the character. + +=back + +=head1 SEE ALSO + +Wallet::Config(3), Wallet::Object::Base(3), wallet-backend(8), WebAuth(3) + +This module is part of the wallet system. The current version is available +from . + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Policy/Stanford.pm b/perl/lib/Wallet/Policy/Stanford.pm new file mode 100644 index 0000000..5ac29e0 --- /dev/null +++ b/perl/lib/Wallet/Policy/Stanford.pm @@ -0,0 +1,422 @@ +# Wallet::Policy::Stanford -- Stanford's wallet naming and ownership policy. +# +# Written by Russ Allbery +# Copyright 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Policy::Stanford; + +use 5.008; +use strict; +use warnings; + +use base qw(Exporter); + +# Declare variables that should be set in BEGIN for robustness. +our (@EXPORT_OK, $VERSION); + +# Set $VERSION and everything export-related in a BEGIN block for robustness +# 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); +} + +############################################################################## +# Configuration +############################################################################## + +# These variables are all declared as globals so that they can be overridden +# from wallet.conf if desirable. + +# The domain to append to hostnames to fully-qualify them. +our $DOMAIN = 'stanford.edu'; + +# Groups for file object naming, each mapped to the ACL to use for +# non-host-based objects owned by that group. This default is entirely +# Stanford-specific, even more so than the rest of this file. +our %ACL_FOR_GROUP = ( + 'its-apps' => 'group/its-app-support', + 'its-crc-sg' => 'group/crcsg', + 'its-idg' => 'group/its-idg', + 'its-rc' => 'group/its-rc', + 'its-sa-core' => 'group/its-sa-core', +); + +# Legacy group names for older file objects. +our @GROUPS_LEGACY = qw(apps crcsg gsb idg sysadmin sulair vast); + +# File object types. Each type can have one or more parameters: whether it is +# host-based (host), whether it takes a qualifier after the host or service +# (extra), and whether that qualifier is mandatory (need_extra). +our %FILE_TYPE = ( + config => { extra => 1, need_extra => 1 }, + db => { extra => 1, need_extra => 1 }, + 'gpg-key' => { }, + htpasswd => { host => 1, extra => 1, need_extra => 1 }, + password => { extra => 1, need_extra => 1 }, + 'password-ipmi' => { host => 1 }, + 'password-root' => { host => 1 }, + 'password-tivoli' => { host => 1 }, + properties => { extra => 1 }, + 'ssh-dsa' => { host => 1 }, + 'ssh-rsa' => { host => 1 }, + 'ssl-key' => { host => 1, extra => 1 }, + 'ssl-keypair' => { host => 1, extra => 1 }, + 'ssl-keystore' => { extra => 1 }, + 'ssl-pkcs12' => { extra => 1 }, + 'tivoli-key' => { host => 1 }, +); + +# 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); + +# File object types for the legacy file object naming scheme. +our @FILE_TYPES_LEGACY = qw(config db gpg-key htpasswd password properties + ssh-rsa ssh-dsa ssl-key ssl-keystore ssl-pkcs12 tivoli-key); + +# Host-based Kerberos principal prefixes. +our @KEYTAB_HOST = qw(HTTP afpserver cifs ftp host imap ipp ldap lpr nfs pop + postgres sieve smtp webauth xmpp); + +# The Kerberos realm, used when forming principals for krb5 ACLs. +our $REALM = 'stanford.edu'; + +# A file listing principal names that should be required to use a root +# instance to autocreate any objects. +our $ROOT_REQUIRED = '/etc/remctl/acl/its-idg'; + +############################################################################## +# Implementation +############################################################################## + +# Retrieve an existing ACL and return its members as a list. +# +# $name - Name of the ACL to retrieve +# +# Returns: Members of the ACL as a list of pairs +# The empty list on any failure to retrieve the ACL +sub _acl_members { + my ($name) = @_; + my $schema = eval { Wallet::Schema->connect }; + return if (!$schema || $@); + my $acl = eval { Wallet::ACL->new ($name, $schema) }; + return if (!$acl || $@); + return $acl->list; +} + +# Retrieve an existing ACL and check whether it contains a netdb-root member. +# This is used to check if a default ACL is already present with a netdb-root +# member so that we can return a default owner that matches. We only ever +# increase the ACL from netdb to netdb-root, never degrade it, so this doesn't +# pose a security problem. +# +# On any failure, just return an empty ACL to use the default. +sub _acl_has_netdb_root { + my ($name) = @_; + for my $line (_acl_members($name)) { + return 1 if $line->[0] eq 'netdb-root'; + } + return; +} + +# Map a file object name to a hostname for the legacy file object naming +# scheme and return it. Returns undef if this file object name doesn't map to +# a hostname. +sub _host_for_file_legacy { + my ($name) = @_; + my %allowed = map { $_ => 1 } @FILE_HOST_LEGACY; + my $allowed_regex = '(?:' . join ('|', sort keys %allowed) . ')'; + if ($name !~ /^[^-]+-(.*)-$allowed_regex(?:-.*)?$/) { + return; + } + my $host = $1; + if ($host !~ /\./) { + $host .= q{.} . $DOMAIN; + } + 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 { + my ($name) = @_; + + # If $name doesn't contain /, defer to the legacy naming scheme. + if ($name !~ m{ / }xms) { + return _host_for_file_legacy($name); + } + + # Parse the name and check whether this is a host-based object. + my ($type, $host) = split('/', $name); + return if !$FILE_TYPE{$type}{host}; + return $host; +} + +# Map a keytab object name to a hostname and return it. Returns undef if this +# keytab principal name doesn't map to a hostname. +sub _host_for_keytab { + my ($name) = @_; + my %allowed = map { $_ => 1 } @KEYTAB_HOST; + return unless $name =~ m,/,; + my ($service, $host) = split ('/', $name, 2); + return unless $allowed{$service}; + if ($host !~ /\./) { + $host .= q{.} . $DOMAIN; + } + return $host; +} + +# 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 +# using root instances by default. +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, + ); + + # 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 ($host) { + my $acl_name = "host/$host"; + my @acl; + if ($ENV{REMOTE_USER} =~ m,/root, + || _acl_has_netdb_root ($acl_name)) { + @acl = ([ 'netdb-root', $host ], + [ 'krb5', "host/$host\@$REALM" ]); + } else { + @acl = ([ 'netdb', $host ], + [ 'krb5', "host/$host\@$REALM" ]); + } + return ($acl_name, @acl); + } + } + + # We have no open if this is not a file object. + return if $type ne 'file'; + + # Parse the name of the file object only far enough to get type and group + # (if there is a group). + my ($file_type, $group) = split('/', $name); + + # Host-based file objects should be caught by the above. We certainly + # can't do anything about them here. + return if $FILE_TYPE{$file_type}{host}; + + # If we have a mapping for this group, retrieve the ACL contents. We + # would like to just return the ACL name, but wallet currently requires we + # return the whole ACL. + my $acl = $ACL_FOR_GROUP{$group}; + return if !defined($acl); + my @members = _acl_members($acl); + return if @members == 0; + return ($acl, @members); +} + +# Enforce a naming policy. Host-based keytabs must have fully-qualified +# 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 +# creation using a */root instance. +sub verify_name { + my ($type, $name, $user) = @_; + my %staff; + if (open (STAFF, '<', $ROOT_REQUIRED)) { + local $_; + while () { + s/^\s+//; + s/\s+$//; + next if m,/root\@,; + $staff{$_} = 1; + } + close STAFF; + } + + # Check for a staff member not using their root instance. + if (defined ($user) && $staff{$user}) { + return 'use a */root instance for wallet object creation'; + } + + # Check keytab naming conventions. + if ($type eq 'keytab') { + my %host = map { $_ => 1 } @KEYTAB_HOST; + if ($name !~ m,^[a-zA-Z0-9_-]+/[a-z0-9.-]+$,) { + return "invalid principal name $name"; + } + my ($principal, $instance) + = ($name =~ m,^([a-zA-Z0-9_-]+)/([a-z0-9.-]+)$,); + unless (defined ($principal) && defined ($instance)) { + return "invalid principal name $name"; + } + if ($host{$principal} and $principal ne 'http') { + if ($instance !~ /^[a-z0-9-]+\.[a-z0-9.-]+$/) { + return "host name $instance is not fully qualified"; + } + } elsif ($principal eq 'afs') { + if ($instance !~ /^[a-z0-9-]+\.[a-z0-9.-]+$/) { + return "AFS cell name $instance is not fully qualified"; + } + } elsif ($principal eq 'service') { + if ($instance !~ /^[a-z0-9-]+$/) { + return "invalid service principal name $name"; + } + } elsif ($instance eq 'cgi') { + if ($principal !~ /^[a-z][a-z0-9]{1,7}$/ + and $principal !~ /^(class|dept|group)-[a-z0-9_-]+$/) { + return "invalid CGI principal name $name"; + } + } elsif ($instance eq 'cron') { + if ($principal !~ /^[a-z][a-z0-9]{1,7}$/ + and $principal !~ /^(class|dept|group)-[a-z0-9_-]+$/) { + return "invalid cron principal name $name"; + } + } else { + return "unknown principal type $principal"; + } + } + + # Check file object naming conventions. + if ($type eq 'file') { + 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 ($FILE_TYPE{$type} && $FILE_TYPE{$type}{host}) { + my ($host, $extra) = @name; + if ($host !~ m{ [.] }xms) { + return "host name $host is not fully qualified"; + } + if (defined($extra) && !$FILE_TYPE{$type}{extra}) { + return "extraneous component at end of $name"; + } + if (!defined($extra) && $FILE_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 (!$FILE_TYPE{$type}) { + return "unknown type $type"; + } + if ($FILE_TYPE{$type}{host}) { + return "bad name for host-based file type $type"; + } + + # Check the extra data. + if (defined($extra) && !$FILE_TYPE{$type}{extra}) { + return "extraneous component at end of $name"; + } + if (!defined($extra) && $FILE_TYPE{$type}{need_extra}) { + return "missing component in $name"; + } + return; + } else { + # Legacy naming scheme. + my %groups = map { $_ => 1 } @GROUPS_LEGACY; + my %types = map { $_ => 1 } @FILE_TYPES_LEGACY; + if ($name !~ m,^[a-zA-Z0-9_.-]+$,) { + return "invalid file object $name"; + } + my $group_regex = '(?:' . join ('|', sort keys %groups) . ')'; + my $type_regex = '(?:' . join ('|', sort keys %types) . ')'; + if ($name !~ /^$group_regex-/) { + return "no recognized owning group in $name"; + } elsif ($name !~ /^$group_regex-.*-$type_regex(-.*)?$/) { + return "invalid file object name $name"; + } + } + } + + # Success. + return; +} + +1; + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +Allbery + +=head1 NAME + +Wallet::Policy::Stanford - Stanford's wallet naming and ownership policy + +=head1 SYNOPSIS + + use Wallet::Policy::Stanford; + my ($type, $name, $user) = @_; + + my $error = valid_name($type, $name, $user); + my ($name, @acl) = default_owner($type, $name); + +=head1 DESCRIPTION + +Wallet::Policy::Stanford implements Stanford's wallet naming and ownership +policy as described in F in the wallet distribution. +It is primarily intended as an example for other sites, but it is used at +Stanford to implement that policy. + +This module provides the default_owner() and verify_name() functions that +are part of the wallet configuration interface (as documented in +L). They can be imported directly into a wallet +configuration file from this module or wrapped to apply additional rules. + +=head1 SEE ALSO + +Wallet::Config(3) + +The L +implemented by this module. + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Report.pm b/perl/lib/Wallet/Report.pm new file mode 100644 index 0000000..1085546 --- /dev/null +++ b/perl/lib/Wallet/Report.pm @@ -0,0 +1,680 @@ +# Wallet::Report -- Wallet system reporting interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Report; +require 5.006; + +use strict; +use vars qw($VERSION); + +use Wallet::ACL; +use Wallet::Schema; + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.04'; + +############################################################################## +# Constructor, destructor, and accessors +############################################################################## + +# Create a new wallet report object. Opens a connection to the database that +# will be used for all of the wallet configuration information. Throw an +# exception if anything goes wrong. +sub new { + my ($class) = @_; + my $schema = Wallet::Schema->connect; + my $self = { schema => $schema }; + bless ($self, $class); + return $self; +} + +# Returns the database handle (used mostly for testing). +sub dbh { + my ($self) = @_; + return $self->{schema}->storage->dbh; +} + +# Returns the DBIx::Class-based database schema object. +sub schema { + my ($self) = @_; + return $self->{schema}; +} + +# Set or return the error stashed in the object. +sub error { + my ($self, @error) = @_; + if (@error) { + my $error = join ('', @error); + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + $self->{error} = $error; + } + return $self->{error}; +} + +# Disconnect the database handle on object destruction to avoid warnings. +sub DESTROY { + my ($self) = @_; + $self->{schema}->storage->dbh->disconnect; +} + +############################################################################## +# Object reports +############################################################################## + +# Return the SQL statement to find every object in the database. +sub objects_all { + my ($self) = @_; + my @objects; + + my %search = (); + my %options = (order_by => [ qw/ob_type ob_name/ ], + select => [ qw/ob_type ob_name/ ]); + + return (\%search, \%options); +} + +# Return the SQL statement and the search field required to find all objects +# matching a specific type. +sub objects_type { + my ($self, $type) = @_; + my @objects; + + my %search = (ob_type => $type); + my %options = (order_by => [ qw/ob_type ob_name/ ], + select => [ qw/ob_type ob_name/ ]); + + return (\%search, \%options); +} + +# Return the SQL statement and search field required to find all objects owned +# by a given ACL. If the requested owner is null, we ignore this and do a +# different search for IS NULL. If the requested owner does not actually +# match any ACLs, set an error and return undef. +sub objects_owner { + my ($self, $owner) = @_; + my @objects; + + my %search; + my %options = (order_by => [ qw/ob_type ob_name/ ], + select => [ qw/ob_type ob_name/ ]); + + if (lc ($owner) eq 'null') { + %search = (ob_owner => undef); + } else { + my $acl = eval { Wallet::ACL->new ($owner, $self->{schema}) }; + return unless $acl; + %search = (ob_owner => $acl->id); + } + + return (\%search, \%options); +} + +# Return the SQL statement and search field required to find all objects that +# have a specific flag set. +sub objects_flag { + my ($self, $flag) = @_; + my @objects; + + my %search = ('flags.fl_flag' => $flag); + my %options = (join => 'flags', + prefetch => 'flags', + order_by => [ qw/ob_type ob_name/ ], + select => [ qw/ob_type ob_name/ ]); + + return (\%search, \%options); +} + +# Return the SQL statement and search field required to find all objects that +# a given ACL has any permissions on. This expands from objects_owner in that +# it will also match any records that have the ACL set for get, store, show, +# destroy, or flags. If the requested owner does not actually match any ACLs, +# set an error and return the empty string. +sub objects_acl { + my ($self, $search) = @_; + my @objects; + + my $schema = $self->{schema}; + my $acl = eval { Wallet::ACL->new ($search, $schema) }; + return unless $acl; + + my @search = ({ ob_owner => $acl->id }, + { ob_acl_get => $acl->id }, + { ob_acl_store => $acl->id }, + { ob_acl_show => $acl->id }, + { ob_acl_destroy => $acl->id }, + { ob_acl_flags => $acl->id }); + my %options = (order_by => [ qw/ob_type ob_name/ ], + select => [ qw/ob_type ob_name/ ]); + + return (\@search, \%options); +} + +# Return the SQL statement to find all objects that have been created but +# have never been retrieved (via get). +sub objects_unused { + my ($self) = @_; + my @objects; + + my %search = (ob_downloaded_on => undef); + 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 +# 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 { + my ($self, $type, @args) = @_; + undef $self->{error}; + + # Get the search and options array refs from specific functions. + my ($search_ref, $options_ref); + if (!defined $type || $type eq '') { + ($search_ref, $options_ref) = $self->objects_all; + } else { + if ($type ne 'unused' && @args != 1) { + $self->error ("object searches require one argument to search"); + } elsif ($type eq 'type') { + ($search_ref, $options_ref) = $self->objects_type (@args); + } elsif ($type eq 'owner') { + ($search_ref, $options_ref) = $self->objects_owner (@args); + } elsif ($type eq 'flag') { + ($search_ref, $options_ref) = $self->objects_flag (@args); + } elsif ($type eq 'acl') { + ($search_ref, $options_ref) = $self->objects_acl (@args); + } elsif ($type eq 'unused') { + ($search_ref, $options_ref) = $self->objects_unused (@args); + } else { + $self->error ("do not know search type: $type"); + } + return unless $search_ref; + } + + # Perform the search and return on any errors. + my @objects; + my $schema = $self->{schema}; + eval { + my @objects_rs = $schema->resultset('Object')->search ($search_ref, + $options_ref); + for my $object_rs (@objects_rs) { + push (@objects, [ $object_rs->ob_type, $object_rs->ob_name ]); + } + }; + if ($@) { + $self->error ("cannot list objects: $@"); + return; + } + + return @objects; +} + +############################################################################## +# ACL reports +############################################################################## + +# Returns the SQL statement required to find and return all ACLs in the +# database. +sub acls_all { + my ($self) = @_; + my @acls; + + my $schema = $self->{schema}; + my %search = (); + my %options = (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 SQL statement required to find all empty ACLs in the database. +sub acls_empty { + my ($self) = @_; + my @acls; + + my $schema = $self->{schema}; + my %search = (ae_id => undef); + 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 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. +sub acls_entry { + my ($self, $type, $identifier) = @_; + my @acls; + + my $schema = $self->{schema}; + my %search = (ae_scheme => $type, + ae_identifier => { like => '%'.$identifier.'%' }); + my %options = (join => 'acl_entries', + prefetch => 'acl_entries', + order_by => [ qw/ac_id/ ], + select => [ qw/ac_id ac_name/ ], + distinct => 1); + + 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 SQL statement required to find unused ACLs. +sub acls_unused { + my ($self) = @_; + my @acls; + + my $schema = $self->{schema}; + my %search = ( + #'acls_owner.ob_owner' => undef, + #'acls_get.ob_owner' => undef, + #'acls_store.ob_owner' => undef, + #'acls_show.ob_owner' => undef, + #'acls_destroy.ob_owner' => undef, + #'acls_flags.ob_owner' => undef, + ); + my %options = (#join => [ qw/acls_owner acls_get acls_store acls_show acls_destroy acls_flags/ ], + order_by => [ qw/ac_id/ ], + select => [ qw/ac_id ac_name/ ]); + + eval { + my @acls_rs = $schema->resultset('Acl')->search (\%search, \%options); + + # FIXME: Almost certainly a way of doing this with the search itself. + for my $acl_rs (@acls_rs) { + next if $acl_rs->acls_owner->first; + next if $acl_rs->acls_get->first; + next if $acl_rs->acls_store->first; + next if $acl_rs->acls_show->first; + next if $acl_rs->acls_destroy->first; + next if $acl_rs->acls_flags->first; + push (@acls, [ $acl_rs->ac_id, $acl_rs->ac_name ]); + } + }; + + if ($@) { + $self->error ("cannot list ACLs: $@"); + return; + } + return (@acls); +} + +# Obtain a textual representation of the membership of an ACL, returning undef +# on error and setting the internal error. +sub acl_membership { + my ($self, $id) = @_; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + my @members = map { "$_->[0] $_->[1]" } $acl->list; + if (!@members && $acl->error) { + $self->error ($acl->error); + return; + } + return join ("\n", @members); +} + +# Duplicate ACL detection unfortunately needs to do something more complex +# than just return a SQL statement, so it's handled differently than other +# reports. All the work is done here and the results returned as a list of +# sets of duplicates. +sub acls_duplicate { + my ($self) = @_; + my @acls = sort map { $_->[1] } $self->acls; + return if (!@acls && $self->{error}); + return if @acls < 2; + my %result; + for my $i (0 .. ($#acls - 1)) { + my $members = $self->acl_membership ($acls[$i]); + return unless defined $members; + for my $j (($i + 1) .. $#acls) { + my $check = $self->acl_membership ($acls[$j]); + return unless defined $check; + if ($check eq $members) { + $result{$acls[$i]} ||= []; + push (@{ $result{$acls[$i]} }, $acls[$j]); + } + } + } + my @result; + for my $acl (sort keys %result) { + push (@result, [ $acl, sort @{ $result{$acl} } ]); + } + return @result; +} + +# Returns a list of all ACLs stored in the wallet database as a list of pairs +# of ACL IDs and ACL names, possibly limited by some criteria. 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. +sub acls { + my ($self, $type, @args) = @_; + undef $self->{error}; + + # Find the ACLs for any given search. + my @acls; + if (!defined $type || $type eq '') { + @acls = $self->acls_all; + } else { + if ($type eq 'duplicate') { + return $self->acls_duplicate; + } elsif ($type eq 'entry') { + if (@args == 0) { + $self->error ('ACL searches require an argument to search'); + return; + } else { + @acls = $self->acls_entry (@args); + } + } elsif ($type eq 'empty') { + @acls = $self->acls_empty; + } elsif ($type eq 'unused') { + @acls = $self->acls_unused; + } else { + $self->error ("unknown search type: $type"); + return; + } + } + return @acls; +} + +# Returns all ACL entries contained in owner ACLs for matching objects. +# Objects are specified by type and name, which may be SQL wildcard +# expressions. Each list member will be a pair of ACL scheme and ACL +# identifier, with duplicates removed. On error and for no matching entries, +# the empty list will be returned. To distinguish between an empty return and +# an error, call error(), which will return undef if there was no error. +sub owners { + my ($self, $type, $name) = @_; + undef $self->{error}; + my $schema = $self->{schema}; + + my @owners; + eval { + my %search = ( + 'acls_owner.ob_type' => { like => $type }, + 'acls_owner.ob_name' => { like => $name }); + my %options = ( + join => { 'acls' => 'acls_owner' }, + order_by => [ qw/ae_scheme ae_identifier/ ], + distinct => 1, + ); + + my @acls_rs = $schema->resultset('AclEntry')->search (\%search, + \%options); + for my $acl_rs (@acls_rs) { + my $scheme = $acl_rs->ae_scheme; + my $identifier = $acl_rs->ae_identifier; + push (@owners, [ $scheme, $identifier ]); + } + }; + if ($@) { + $self->error ("cannot report on owners: $@"); + return; + } + return @owners; +} + +############################################################################## +# Auditing +############################################################################## + +# Audit the database for violations of local policy. Returns a list of +# objects (as type and name pairs) or a list of ACLs (as ID and name pairs). +# On error and for no matching entries, the empty list will be returned. To +# distinguish between an empty return and an error, call error(), which will +# return undef if there was no error. +sub audit { + my ($self, $type, $audit) = @_; + undef $self->{error}; + unless (defined ($type) and defined ($audit)) { + $self->error ("type and audit not specified"); + return; + } + if ($type eq 'objects') { + if ($audit eq 'name') { + return unless defined &Wallet::Config::verify_name; + my @objects = $self->objects; + my @results; + for my $object (@objects) { + my ($type, $name) = @$object; + my $error = Wallet::Config::verify_name ($type, $name); + push (@results, $object) if $error; + } + return @results; + } else { + $self->error ("unknown object audit: $audit"); + return; + } + } elsif ($type eq 'acls') { + if ($audit eq 'name') { + return unless defined &Wallet::Config::verify_acl_name; + my @acls = $self->acls; + my @results; + for my $acl (@acls) { + my $error = Wallet::Config::verify_acl_name ($acl->[1]); + push (@results, $acl) if $error; + } + return @results; + } else { + $self->error ("unknown acl audit: $audit"); + return; + } + } else { + $self->error ("unknown audit type: $type"); + return; + } +} + +1; +__DATA__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +Wallet::Report - Wallet system reporting interface + +=for stopwords +ACL ACLs wildcard Allbery SQL tuples + +=head1 SYNOPSIS + + use Wallet::Report; + my $report = Wallet::Report->new; + my @objects = $report->objects ('type', 'keytab'); + for my $object (@objects) { + print "@$object\n"; + } + @objects = $report->audit ('objects', 'name'); + +=head1 DESCRIPTION + +Wallet::Report provides a mechanism to generate lists and reports on the +contents of the wallet database. The format of the results returned +depend on the type of search, but will generally be returned as a list of +tuples identifying objects, ACLs, or ACL entries. + +To use this object, several configuration variables must be set (at least +the database configuration). For information on those variables and how +to set them, see L. For more information on the normal +user interface to the wallet server, see L. + +=head1 CLASS METHODS + +=over 4 + +=item new() + +Creates a new wallet report object and connects to the database. On any +error, this method throws an exception. + +=back + +=head1 INSTANCE METHODS + +For all methods that can fail, the caller should call error() after a +failure to get the error message. For all methods that return lists, if +they return an empty list, the caller should call error() to distinguish +between an empty report and an error. + +=over 4 + +=item acls([ TYPE [, SEARCH ... ]]) + +Returns a list of all ACLs matching a search type and string in the +database, or all ACLs if no search information is given. There are +currently four search types. C returns sets of duplicate ACLs +(ones with exactly the same entries). C takes no arguments and +will return only those ACLs that have no entries within them. C +takes two arguments, an entry scheme and a (possibly partial) entry +identifier, and will return any ACLs containing an entry with that scheme +and with an identifier containing that value. C returns all ACLs +that are not referenced by any object. + +The return value for everything except C is a list of +references to pairs of ACL ID and name. For example, if there are two +ACLs in the database, one with name C and ID 1 and one with name +C and ID 3, acls() with no arguments would return: + + ([ 1, 'ADMIN' ], [ 3, 'group/admins' ]) + +The return value for the C search is sets of ACL names that are +duplicates (have the same entries). For example, if C, C, and +C are all duplicates, and C and C are also duplicates, the +result would be: + + ([ 'd1', 'd2', 'd3' ], [ 'o1', 'o2' ]) + +Returns the empty list on failure. An error can be distinguished from +empty search results by calling error(). error() is guaranteed to return +the error message if there was an error and undef if there was no error. + +=item audit(TYPE, AUDIT) + +Audits the wallet database for violations of local policy. TYPE is the +general class of thing to audit, and AUDIT is the specific audit to +perform. TYPE may be either C or C. Currently, the only +implemented audit is C. This returns a list of all objects, as +references to pairs of type and name, or ACLs, as references to pairs of +ID and name, that are not accepted by the verify_name() or +verify_acl_name() function defined in the wallet configuration. See +L for more information. + +Returns the empty list on failure. An error can be distinguished from +empty search results by calling error(). error() is guaranteed to return +the error message if there was an error and undef if there was no error. + +=item 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. + +=item objects([ TYPE [, SEARCH ... ]]) + +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, with a given type, +will return only those entries where the type matches the given type. +C, with a given owner, will only return those objects owned by the +given ACL name or ID. C, with a given flag name, will only return +those items with a flag set to the given value. C operates like +C, 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 will +return all entries for which a get command has never been issued. + +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 +and with values C and C, objects() with no +arguments would return: + + ([ 'keytab', 'host/example.com' ], [ 'keytab', 'foo' ]) + +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 +matching TYPE and NAME, which are interpreted as SQL patterns using C<%> +as a wildcard. The return value is a list of references to pairs of +schema and identifier, with duplicates removed. + +Returns the empty list on failure. To distinguish between this and no +matches, 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. + +=back + +=head1 SEE ALSO + +Wallet::Config(3), Wallet::Server(3) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery and Jon Robertson . + +=cut diff --git a/perl/lib/Wallet/Schema.pm b/perl/lib/Wallet/Schema.pm new file mode 100644 index 0000000..74b4c99 --- /dev/null +++ b/perl/lib/Wallet/Schema.pm @@ -0,0 +1,354 @@ +# Database schema and connector for the wallet system. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema; + +use strict; +use warnings; + +use Wallet::Config; + +use base 'DBIx::Class::Schema'; + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +our $VERSION = '0.09'; + +__PACKAGE__->load_namespaces; +__PACKAGE__->load_components (qw/Schema::Versioned/); + +############################################################################## +# Core overrides +############################################################################## + +# Override DBI::connect to supply our own connect string, username, and +# password and to set some standard options. Takes no arguments other than +# the implicit class argument. +sub connect { + my ($class) = @_; + unless ($Wallet::Config::DB_DRIVER + and (defined ($Wallet::Config::DB_INFO) + or defined ($Wallet::Config::DB_NAME))) { + die "database connection information not configured\n"; + } + my $dsn = "DBI:$Wallet::Config::DB_DRIVER:"; + if (defined $Wallet::Config::DB_INFO) { + $dsn .= $Wallet::Config::DB_INFO; + } else { + $dsn .= "database=$Wallet::Config::DB_NAME"; + $dsn .= ";host=$Wallet::Config::DB_HOST" if $Wallet::Config::DB_HOST; + $dsn .= ";port=$Wallet::Config::DB_PORT" if $Wallet::Config::DB_PORT; + } + my $user = $Wallet::Config::DB_USER; + my $pass = $Wallet::Config::DB_PASSWORD; + my %attrs = (PrintError => 0, RaiseError => 1); + my $schema = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) }; + if ($@) { + die "cannot connect to database: $@\n"; + } + return $schema; +} + +1; + +__END__ + +############################################################################## +# Documentation +############################################################################## + +=for stopwords +RaiseError PrintError AutoCommit ACL verifier API APIs enums keytab backend +enctypes DBI Allbery + +=head1 NAME + +Wallet::Schema - Database schema and connector for the wallet system + +=head1 SYNOPSIS + + use Wallet::Schema; + my $schema = Wallet::Schema->connect; + +=head1 DESCRIPTION + +This class encapsulates the database schema for the wallet system. The +documentation you're reading explains and comments the schema. The +class runs using the DBIx::Class module. + +connect() will obtain the database connection information from the wallet +configuration; see L for more details. It will also +automatically set the RaiseError attribute to true and the PrintError and +AutoCommit attributes to false, matching the assumptions made by the +wallet database code. + +=head1 SCHEMA + +=head2 Normalization Tables + +Holds the supported object types and their corresponding Perl classes: + + create table types + (ty_name varchar(16) primary key, + ty_class varchar(64)); + insert into types (ty_name, ty_class) + values ('file', 'Wallet::Object::File'); + insert into types (ty_name, ty_class) + values ('keytab', 'Wallet::Object::Keytab'); + +Holds the supported ACL schemes and their corresponding Perl classes: + + create table acl_schemes + (as_name varchar(32) primary key, + as_class varchar(64)); + insert into acl_schemes (as_name, as_class) + values ('krb5', 'Wallet::ACL::Krb5'); + insert into acl_schemes (as_name, as_class) + values ('krb5-regex', 'Wallet::ACL::Krb5::Regex'); + insert into acl_schemes (as_name, as_class) + values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute'); + 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'); + +If you have extended the wallet to support additional object types or +additional ACL schemes, you will want to add additional rows to these +tables mapping those types or schemes to Perl classes that implement the +object or ACL verifier APIs. + +=head2 ACL Tables + +A wallet ACL consists of zero or more ACL entries, each of which is a +scheme and an identifier. The scheme identifies the check that should be +performed and the identifier is additional scheme-specific information. +Each ACL references entries in the following table: + + create table acls + (ac_id integer auto_increment primary key, + ac_name varchar(255) not null, + unique (ac_name)); + +This just keeps track of unique ACL identifiers. The data is then stored +in: + + create table acl_entries + (ae_id integer not null references acls(ac_id), + ae_scheme varchar(32) + not null references acl_schemes(as_name), + ae_identifier varchar(255) not null, + primary key (ae_id, ae_scheme, ae_identifier)); + create index ae_id on acl_entries (ae_id); + +ACLs may be referred to in the API via either the numeric ID or the +human-readable name, but internally ACLs are always referenced by numeric +ID so that they can be renamed without requiring complex data +modifications. + +Currently, the ACL named C (case-sensitive) is special-cased in the +Wallet::Server code and granted global access. + +Every change made to any ACL in the database will be recorded in this +table. + + create table acl_history + (ah_id integer auto_increment primary key, + ah_acl integer not null, + ah_action varchar(16) not null, + ah_scheme varchar(32) default null, + ah_identifier varchar(255) default null, + ah_by varchar(255) not null, + ah_from varchar(255) not null, + ah_on datetime not null); + create index ah_acl on acl_history (ah_acl); + +ah_action must be one of C, C, C, or C +(enums aren't used for compatibility with databases other than MySQL). +For a change of type create or destroy, only the action and the trace +records (by, from, and on) are stored. For a change to the lines of an +ACL, the scheme and identifier of the line that was added or removed is +included. Note that changes to the ACL name are not recorded; ACLs are +always tracked by system-generated ID, so name changes are purely +cosmetic. + +ah_by stores the authenticated identity that made the change, ah_from +stores the host from which they made the change, and ah_on stores the time +the change was made. + +=head2 Object Tables + +Each object stored in the wallet is represented by an entry in the objects +table: + + create table objects + (ob_type varchar(16) + not null references types(ty_name), + ob_name varchar(255) not null, + ob_owner integer default null references acls(ac_id), + ob_acl_get integer default null references acls(ac_id), + ob_acl_store integer default null references acls(ac_id), + ob_acl_show integer default null references acls(ac_id), + ob_acl_destroy integer default null references acls(ac_id), + ob_acl_flags integer default null references acls(ac_id), + ob_expires datetime default null, + ob_created_by varchar(255) not null, + ob_created_from varchar(255) not null, + ob_created_on datetime not null, + ob_stored_by varchar(255) default null, + ob_stored_from varchar(255) default null, + ob_stored_on datetime default null, + ob_downloaded_by varchar(255) default null, + ob_downloaded_from varchar(255) default null, + ob_downloaded_on datetime default null, + ob_comment varchar(255) default null, + primary key (ob_name, ob_type)); + create index ob_owner on objects (ob_owner); + create index ob_expires on objects (ob_expires); + +Object names are not globally unique but only unique within their type, so +the table has a joint primary key. Each object has an owner and then up +to five more specific ACLs. The owner provides permission for get, store, +and show operations if no more specific ACL is set. It does not provide +permission for destroy or flags. + +The ob_acl_flags ACL controls who can set flags on this object. Each +object may have zero or more flags associated with it: + + create table flags + (fl_type varchar(16) + not null references objects(ob_type), + fl_name varchar(255) + not null references objects(ob_name), + fl_flag enum('locked', 'unchanging') + not null, + primary key (fl_type, fl_name, fl_flag)); + create index fl_object on flags (fl_type, fl_name); + +Every change made to any object in the wallet database will be recorded in +this table: + + create table object_history + (oh_id integer auto_increment primary key, + oh_type varchar(16) + not null references objects(ob_type), + oh_name varchar(255) + not null references objects(ob_name), + oh_action varchar(16) not null, + oh_field varchar(16) default null, + oh_type_field varchar(255) default null, + oh_old varchar(255) default null, + oh_new varchar(255) default null, + oh_by varchar(255) not null, + oh_from varchar(255) not null, + oh_on datetime not null); + create index oh_object on object_history (oh_type, oh_name); + +oh_action must be one of C, C, C, C, or +C. oh_field must be one of C, C, C, +C, C, C, C, C, or +C. Enums aren't used for compatibility with databases other +than MySQL. + +For a change of type create, get, store, or destroy, only the action and +the trace records (by, from, and on) are stored. For changes to columns +or to the flags table, oh_field takes what attribute is changed, oh_from +takes the previous value converted to a string and oh_to takes the next +value similarly converted to a string. The special field value +"type_data" is used when type-specific data is changed, and in that case +(and only that case) some type-specific name for the data being changed is +stored in oh_type_field. + +When clearing a flag, oh_old will have the name of the flag and oh_new +will be null. When setting a flag, oh_old will be null and oh_new will +have the name of the flag. + +oh_by stores the authenticated identity that made the change, oh_from +stores the host from which they made the change, and oh_on stores the time +the change was made. + +=head2 Duo Backend Data + +Duo integration objects store some additional metadata about the +integration to aid in synchronization with Duo. + + create table duo + (du_name varchar(255) + not null references objects(ob_name), + du_key varchar(255) not null); + create index du_key on duo (du_key); + +du_key holds the Duo integration key, which is the unique name of the +integration within Duo. Additional data may be added later to represent +the other possible settings within Duo. + +=head2 Keytab Backend Data + +The keytab backend has stub support for synchronizing keys with an +external system, although no external systems are currently supported. +The permitted external systems are listed in a normalization table: + + create table sync_targets + (st_name varchar(255) primary key); + +and then the synchronization targets for a given keytab are stored in this +table: + + create table keytab_sync + (ks_name varchar(255) + not null references objects(ob_name), + ks_target varchar(255) + not null references sync_targets(st_name), + primary key (ks_name, ks_target)); + create index ks_name on keytab_sync (ks_name); + +The keytab backend supports restricting the allowable enctypes for a given +keytab. The permitted enctypes are listed in a normalization table: + + create table enctypes + (en_name varchar(255) primary key); + +and then the restrictions for a given keytab are stored in this table: + + create table keytab_enctypes + (ke_name varchar(255) + not null references objects(ob_name), + ke_enctype varchar(255) + not null references enctypes(en_name), + primary key (ke_name, ke_enctype)); + create index ke_name on keytab_enctypes (ke_name); + +To use this functionality, you will need to populate the enctypes table +with the enctypes that a keytab may be restricted to. Currently, there is +no automated mechanism to do this. + +=head1 CLASS METHODS + +=over 4 + +=item connect() + +Opens a new database connection and returns the database object. On any +failure, throws an exception. Unlike the DBI method, connect() takes no +arguments; all database connection information is derived from the wallet +configuration. + +=back + +=head1 SEE ALSO + +wallet-backend(8), Wallet::Config(3) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/lib/Wallet/Schema/Result/Acl.pm b/perl/lib/Wallet/Schema/Result/Acl.pm new file mode 100644 index 0000000..226738a --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/Acl.pm @@ -0,0 +1,110 @@ +# Wallet schema for an ACL. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Acl; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +ACL + +=head1 NAME + +Wallet::Schema::Result::Acl - Wallet schema for an ACL + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("acls"); + +=head1 ACCESSORS + +=head2 ac_id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + +=head2 ac_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "ac_id", + { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, + "ac_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("ac_id"); +__PACKAGE__->add_unique_constraint("ac_name", ["ac_name"]); + +__PACKAGE__->has_one( + 'acl_entries', + 'Wallet::Schema::Result::AclEntry', + { 'foreign.ae_id' => 'self.ac_id' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); +__PACKAGE__->has_many( + 'acl_history', + 'Wallet::Schema::Result::AclHistory', + { 'foreign.ah_id' => 'self.ac_id' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); + +# References for all of the various potential ACLs in owners. +__PACKAGE__->has_many( + 'acls_owner', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_owner' => 'self.ac_id' }, + ); +__PACKAGE__->has_many( + 'acls_get', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_acl_get' => 'self.ac_id' }, + ); +__PACKAGE__->has_many( + 'acls_store', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_acl_store' => 'self.ac_id' }, + ); +__PACKAGE__->has_many( + 'acls_show', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_acl_show' => 'self.ac_id' }, + ); +__PACKAGE__->has_many( + 'acls_destroy', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_acl_destroy' => 'self.ac_id' }, + ); +__PACKAGE__->has_many( + 'acls_flags', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_acl_flags' => 'self.ac_id' }, + ); + +# Override the insert method so that we can automatically create history +# items. +#sub insert { +# my ($self, @args) = @_; +# my $ret = $self->next::method (@args); +# print "ID: ".$self->ac_id."\n"; +# use Data::Dumper; print Dumper (@args); + +# return $self; +#} + +1; diff --git a/perl/lib/Wallet/Schema/Result/AclEntry.pm b/perl/lib/Wallet/Schema/Result/AclEntry.pm new file mode 100644 index 0000000..a33a98c --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/AclEntry.pm @@ -0,0 +1,74 @@ +# Wallet schema for an entry in an ACL. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::AclEntry; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +ACL + +=head1 NAME + +Wallet::Schema::Result::AclEntry - Wallet schema for an entry in an ACL + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("acl_entries"); + +=head1 ACCESSORS + +=head2 ae_id + + data_type: 'integer' + is_nullable: 0 + +=head2 ae_scheme + + data_type: 'varchar' + is_nullable: 0 + size: 32 + +=head2 ae_identifier + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "ae_id", + { data_type => "integer", is_nullable => 0 }, + "ae_scheme", + { data_type => "varchar", is_nullable => 0, size => 32 }, + "ae_identifier", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("ae_id", "ae_scheme", "ae_identifier"); + +__PACKAGE__->belongs_to( + 'acls', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ae_id' }, + { is_deferrable => 1, on_delete => 'CASCADE', + on_update => 'CASCADE' }, + ); + +__PACKAGE__->has_one( + 'acl_scheme', + 'Wallet::Schema::Result::AclScheme', + { 'foreign.as_name' => 'self.ae_scheme' }, + { cascade_delete => 0 }, + ); +1; diff --git a/perl/lib/Wallet/Schema/Result/AclHistory.pm b/perl/lib/Wallet/Schema/Result/AclHistory.pm new file mode 100644 index 0000000..11593b7 --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/AclHistory.pm @@ -0,0 +1,113 @@ +# Wallet schema for ACL history. +# +# Written by Jon Robertson +# Copyright 2012, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::AclHistory; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("InflateColumn::DateTime"); + +=for stopwords +ACL + +=head1 NAME + +Wallet::Schema::Result::AclHistory - Wallet schema for ACL history + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("acl_history"); + +=head1 ACCESSORS + +=head2 ah_id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + +=head2 ah_acl + + data_type: 'integer' + is_nullable: 0 + +=head2 ah_action + + data_type: 'varchar' + is_nullable: 0 + size: 16 + +=head2 ah_scheme + + data_type: 'varchar' + is_nullable: 1 + size: 32 + +=head2 ah_identifier + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 ah_by + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ah_from + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ah_on + + data_type: 'datetime' + datetime_undef_if_invalid: 1 + is_nullable: 0 + +=cut + +__PACKAGE__->add_columns( + "ah_id", + { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, + "ah_acl", + { data_type => "integer", is_nullable => 0 }, + "ah_action", + { data_type => "varchar", is_nullable => 0, size => 16 }, + "ah_scheme", + { data_type => "varchar", is_nullable => 1, size => 32 }, + "ah_identifier", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "ah_by", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ah_from", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ah_on", + { + data_type => "datetime", + datetime_undef_if_invalid => 1, + is_nullable => 0, + }, +); +__PACKAGE__->set_primary_key("ah_id"); + +# Add an index on the ACL. +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + my $name = 'acl_history_idx_ah_acl'; + $sqlt_table->add_index (name => $name, fields => [qw(ah_acl)]); +} + +1; diff --git a/perl/lib/Wallet/Schema/Result/AclScheme.pm b/perl/lib/Wallet/Schema/Result/AclScheme.pm new file mode 100644 index 0000000..91a58b2 --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/AclScheme.pm @@ -0,0 +1,84 @@ +# Wallet schema for ACL scheme. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::AclScheme; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; +__PACKAGE__->load_components (qw//); + +=for stopwords +ACL verifier APIs + +=head1 NAME + +Wallet::Schema::Result::AclScheme - Wallet schema for ACL scheme + +=head1 DESCRIPTION + +This is a normalization table used to constrain the values in other +tables. It contains the types of ACL schemes that Wallet will +recognize, and the modules that govern each of those schemes. + +By default it contains the following entries: + + insert into acl_schemes (as_name, as_class) + values ('krb5', 'Wallet::ACL::Krb5'); + insert into acl_schemes (as_name, as_class) + values ('krb5-regex', 'Wallet::ACL::Krb5::Regex'); + insert into acl_schemes (as_name, as_class) + values ('ldap-attr', 'Wallet::ACL::LDAP::Attribute'); + 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'); + +If you have extended the wallet to support additional ACL schemes, you +will want to add additional rows to this table mapping those schemes +to Perl classes that implement the ACL verifier APIs. + +=cut + +__PACKAGE__->table("acl_schemes"); + +=head1 ACCESSORS + +=head2 as_name + + data_type: 'varchar' + is_nullable: 0 + size: 32 + +=head2 as_class + + data_type: 'varchar' + is_nullable: 1 + size: 64 + +=cut + +__PACKAGE__->add_columns( + "as_name", + { data_type => "varchar", is_nullable => 0, size => 32 }, + "as_class", + { data_type => "varchar", is_nullable => 1, size => 64 }, +); +__PACKAGE__->set_primary_key("as_name"); + +#__PACKAGE__->resultset->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' ], +# ]); + +1; diff --git a/perl/lib/Wallet/Schema/Result/Duo.pm b/perl/lib/Wallet/Schema/Result/Duo.pm new file mode 100644 index 0000000..80a71dc --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/Duo.pm @@ -0,0 +1,53 @@ +# Wallet schema for Duo metadata. +# +# Written by Jon Robertson +# Copyright 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Duo; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +keytab enctype + +=head1 NAME + +Wallet::Schema::Result::Duo - Wallet schema for Duo metadata + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("duo"); + +=head1 ACCESSORS + +=head2 du_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 du_key + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "du_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "du_key", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("du_name"); + +1; diff --git a/perl/lib/Wallet/Schema/Result/Enctype.pm b/perl/lib/Wallet/Schema/Result/Enctype.pm new file mode 100644 index 0000000..5733669 --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/Enctype.pm @@ -0,0 +1,45 @@ +# Wallet schema for Kerberos encryption type. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Enctype; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +Kerberos + +=head1 NAME + +Wallet::Schema::Result::Enctype - Wallet schema for Kerberos encryption type + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("enctypes"); + +=head1 ACCESSORS + +=head2 en_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "en_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("en_name"); + +1; diff --git a/perl/lib/Wallet/Schema/Result/Flag.pm b/perl/lib/Wallet/Schema/Result/Flag.pm new file mode 100644 index 0000000..e223ff8 --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/Flag.pm @@ -0,0 +1,62 @@ +# Wallet schema for object flags. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Flag; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::Flag - Wallet schema for object flags + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("flags"); + +=head1 ACCESSORS + +=head2 fl_type + + data_type: 'varchar' + is_nullable: 0 + size: 16 + +=head2 fl_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 fl_flag + + data_type: 'varchar' + is_nullable: 0 + size: 32 + +=cut + +__PACKAGE__->add_columns( + "fl_type" => + { data_type => "varchar", is_nullable => 0, size => 16 }, + "fl_name" => + { data_type => "varchar", is_nullable => 0, size => 255 }, + "fl_flag" => { + data_type => 'enum', + is_enum => 1, + extra => { list => [qw/locked unchanging/] }, + }, +); +__PACKAGE__->set_primary_key("fl_type", "fl_name", "fl_flag"); + + +1; diff --git a/perl/lib/Wallet/Schema/Result/KeytabEnctype.pm b/perl/lib/Wallet/Schema/Result/KeytabEnctype.pm new file mode 100644 index 0000000..daea724 --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/KeytabEnctype.pm @@ -0,0 +1,53 @@ +# Wallet schema for keytab enctype. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::KeytabEnctype; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +keytab enctype + +=head1 NAME + +Wallet::Schema::Result::KeytabEnctype - Wallet schema for keytab enctype + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("keytab_enctypes"); + +=head1 ACCESSORS + +=head2 ke_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ke_enctype + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "ke_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ke_enctype", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("ke_name", "ke_enctype"); + +1; diff --git a/perl/lib/Wallet/Schema/Result/KeytabSync.pm b/perl/lib/Wallet/Schema/Result/KeytabSync.pm new file mode 100644 index 0000000..ca84277 --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/KeytabSync.pm @@ -0,0 +1,53 @@ +# Wallet schema for keytab synchronization. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::KeytabSync; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +keytab + +=head1 NAME + +Wallet::Schema::Result::KeytabSync - Wallet schema for keytab synchronization + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("keytab_sync"); + +=head1 ACCESSORS + +=head2 ks_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ks_target + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "ks_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ks_target", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("ks_name", "ks_target"); + +1; diff --git a/perl/lib/Wallet/Schema/Result/Object.pm b/perl/lib/Wallet/Schema/Result/Object.pm new file mode 100644 index 0000000..fd64e1b --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/Object.pm @@ -0,0 +1,266 @@ +# Wallet schema for an object. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Object; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("InflateColumn::DateTime"); + +=head1 NAME + +Wallet::Schema::Result::Object - Wallet schema for an object + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("objects"); + +=head1 ACCESSORS + +=head2 ob_type + + data_type: 'varchar' + is_nullable: 0 + size: 16 + +=head2 ob_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ob_owner + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_acl_get + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_acl_store + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_acl_show + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_acl_destroy + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_acl_flags + + data_type: 'integer' + is_nullable: 1 + +=head2 ob_expires + + data_type: 'datetime' + datetime_undef_if_invalid: 1 + is_nullable: 1 + +=head2 ob_created_by + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ob_created_from + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 ob_created_on + + data_type: 'datetime' + datetime_undef_if_invalid: 1 + is_nullable: 0 + +=head2 ob_stored_by + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 ob_stored_from + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 ob_stored_on + + data_type: 'datetime' + datetime_undef_if_invalid: 1 + is_nullable: 1 + +=head2 ob_downloaded_by + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 ob_downloaded_from + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 ob_downloaded_on + + data_type: 'datetime' + datetime_undef_if_invalid: 1 + is_nullable: 1 + +=head2 ob_comment + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "ob_type", + { data_type => "varchar", is_nullable => 0, size => 16 }, + "ob_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ob_owner", + { data_type => "integer", is_nullable => 1 }, + "ob_acl_get", + { data_type => "integer", is_nullable => 1 }, + "ob_acl_store", + { data_type => "integer", is_nullable => 1 }, + "ob_acl_show", + { data_type => "integer", is_nullable => 1 }, + "ob_acl_destroy", + { data_type => "integer", is_nullable => 1 }, + "ob_acl_flags", + { data_type => "integer", is_nullable => 1 }, + "ob_expires", + { + data_type => "datetime", + datetime_undef_if_invalid => 1, + is_nullable => 1, + }, + "ob_created_by", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ob_created_from", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "ob_created_on", + { + data_type => "datetime", + datetime_undef_if_invalid => 1, + is_nullable => 0, + }, + "ob_stored_by", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "ob_stored_from", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "ob_stored_on", + { + data_type => "datetime", + datetime_undef_if_invalid => 1, + is_nullable => 1, + }, + "ob_downloaded_by", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "ob_downloaded_from", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "ob_downloaded_on", + { + data_type => "datetime", + datetime_undef_if_invalid => 1, + is_nullable => 1, + }, + "ob_comment", + { data_type => "varchar", is_nullable => 1, size => 255 }, +); +__PACKAGE__->set_primary_key("ob_name", "ob_type"); + +__PACKAGE__->has_one( + 'types', + 'Wallet::Schema::Result::Type', + { 'foreign.ty_name' => 'self.ob_type' }, + ); + +__PACKAGE__->has_many( + 'flags', + 'Wallet::Schema::Result::Flag', + { 'foreign.fl_type' => 'self.ob_type', + 'foreign.fl_name' => 'self.ob_name' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); + +__PACKAGE__->has_many( + 'object_history', + 'Wallet::Schema::Result::ObjectHistory', + { 'foreign.oh_type' => 'self.ob_type', + 'foreign.oh_name' => 'self.ob_name' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); + +__PACKAGE__->has_many( + 'keytab_enctypes', + 'Wallet::Schema::Result::KeytabEnctype', + { 'foreign.ke_name' => 'self.ob_name' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); + +__PACKAGE__->has_many( + 'keytab_sync', + 'Wallet::Schema::Result::KeytabSync', + { 'foreign.ks_name' => 'self.ob_name' }, + { cascade_copy => 0, cascade_delete => 0 }, + ); + +# References for all of the various potential ACLs. +__PACKAGE__->belongs_to( + 'acls_owner', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_owner' }, + ); +__PACKAGE__->belongs_to( + 'acls_get', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_acl_get' }, + ); +__PACKAGE__->belongs_to( + 'acls_store', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_acl_store' }, + ); +__PACKAGE__->belongs_to( + 'acls_show', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_acl_show' }, + ); +__PACKAGE__->belongs_to( + 'acls_destroy', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_acl_destroy' }, + ); +__PACKAGE__->belongs_to( + 'acls_flags', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ob_acl_flags' }, + ); + +1; diff --git a/perl/lib/Wallet/Schema/Result/ObjectHistory.pm b/perl/lib/Wallet/Schema/Result/ObjectHistory.pm new file mode 100644 index 0000000..5e9c8bd --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/ObjectHistory.pm @@ -0,0 +1,135 @@ +# Wallet schema for object history. +# +# Written by Jon Robertson +# Copyright 2012, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::ObjectHistory; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("InflateColumn::DateTime"); + +=head1 NAME + +Wallet::Schema::Result::ObjectHistory - Wallet schema for object history + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("object_history"); + +=head1 ACCESSORS + +=head2 oh_id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + +=head2 oh_type + + data_type: 'varchar' + is_nullable: 0 + size: 16 + +=head2 oh_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 oh_action + + data_type: 'varchar' + is_nullable: 0 + size: 16 + +=head2 oh_field + + data_type: 'varchar' + is_nullable: 1 + size: 16 + +=head2 oh_type_field + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 oh_old + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 oh_new + + data_type: 'varchar' + is_nullable: 1 + size: 255 + +=head2 oh_by + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 oh_from + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=head2 oh_on + + data_type: 'datetime' + datetime_undef_if_invalid: 1 + is_nullable: 0 + +=cut + +__PACKAGE__->add_columns( + "oh_id", + { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, + "oh_type", + { data_type => "varchar", is_nullable => 0, size => 16 }, + "oh_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "oh_action", + { data_type => "varchar", is_nullable => 0, size => 16 }, + "oh_field", + { data_type => "varchar", is_nullable => 1, size => 16 }, + "oh_type_field", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "oh_old", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "oh_new", + { data_type => "varchar", is_nullable => 1, size => 255 }, + "oh_by", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "oh_from", + { data_type => "varchar", is_nullable => 0, size => 255 }, + "oh_on", + { + data_type => "datetime", + datetime_undef_if_invalid => 1, + is_nullable => 0, + }, +); +__PACKAGE__->set_primary_key("oh_id"); + +# Add an index on object type and object name. +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + my $name = 'object_history_idx_oh_type_oh_name'; + $sqlt_table->add_index (name => $name, fields => [qw(oh_type oh_name)]); +} + +1; diff --git a/perl/lib/Wallet/Schema/Result/SyncTarget.pm b/perl/lib/Wallet/Schema/Result/SyncTarget.pm new file mode 100644 index 0000000..4300a54 --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/SyncTarget.pm @@ -0,0 +1,48 @@ +# Wallet schema for synchronization targets. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::SyncTarget; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::SyncTarget - Wallet schema for synchronization targets + +=head1 DESCRIPTION + +=cut + +__PACKAGE__->table("sync_targets"); + +=head1 ACCESSORS + +=head2 st_name + + data_type: 'varchar' + is_nullable: 0 + size: 255 + +=cut + +__PACKAGE__->add_columns( + "st_name", + { data_type => "varchar", is_nullable => 0, size => 255 }, +); +__PACKAGE__->set_primary_key("st_name"); + +#__PACKAGE__->has_many( +# 'keytab_sync', +# 'Wallet::Schema::Result::KeytabSync', +# { 'foreign.ks_target' => 'self.st_name' }, +# { cascade_copy => 0, cascade_delete => 0 }, +# ); +1; diff --git a/perl/lib/Wallet/Schema/Result/Type.pm b/perl/lib/Wallet/Schema/Result/Type.pm new file mode 100644 index 0000000..748a8a8 --- /dev/null +++ b/perl/lib/Wallet/Schema/Result/Type.pm @@ -0,0 +1,75 @@ +# Wallet schema for object types. +# +# Written by Jon Robertson +# Copyright 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +package Wallet::Schema::Result::Type; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=for stopwords +APIs + +=head1 NAME + +Wallet::Schema::Result::Type - Wallet schema for object types + +=head1 DESCRIPTION + +This is a normalization table used to constrain the values in other +tables. It contains the types of wallet objects that are considered +valid, and the modules that govern each. + +By default it contains the following entries: + + insert into types (ty_name, ty_class) + values ('file', 'Wallet::Object::File'); + insert into types (ty_name, ty_class) + values ('keytab', 'Wallet::Object::Keytab'); + +If you have extended the wallet to support additional object types , +you will want to add additional rows to this table mapping those types +to Perl classes that implement the object APIs. + +=cut + +__PACKAGE__->table("types"); + +=head1 ACCESSORS + +=head2 ty_name + + data_type: 'varchar' + is_nullable: 0 + size: 16 + +=head2 ty_class + + data_type: 'varchar' + is_nullable: 1 + size: 64 + +=cut + +__PACKAGE__->add_columns( + "ty_name", + { data_type => "varchar", is_nullable => 0, size => 16 }, + "ty_class", + { data_type => "varchar", is_nullable => 1, size => 64 }, +); +__PACKAGE__->set_primary_key("ty_name"); + +#__PACKAGE__->has_many( +# 'objects', +# 'Wallet::Schema::Result::Object', +# { 'foreign.ob_type' => 'self.ty_name' }, +# { cascade_copy => 0, cascade_delete => 0 }, +# ); + +1; diff --git a/perl/lib/Wallet/Server.pm b/perl/lib/Wallet/Server.pm new file mode 100644 index 0000000..3266928 --- /dev/null +++ b/perl/lib/Wallet/Server.pm @@ -0,0 +1,1095 @@ +# Wallet::Server -- Wallet system server implementation. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2010, 2011, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Server; +require 5.006; + +use strict; +use vars qw(%MAPPING $VERSION); + +use Wallet::ACL; +use Wallet::Config; +use Wallet::Schema; + +# This version should be increased on any code change to this module. Always +# use two digits for the minor version with a leading zero if necessary so +# that it will sort properly. +$VERSION = '0.11'; + +############################################################################## +# Utility methods +############################################################################## + +# Create a new wallet server object. A new server should be created for each +# user who is making changes to the wallet. Takes the principal and host who +# are sending wallet requests. Opens a connection to the database that will +# be used for all of the wallet metadata based on the wallet configuration +# information. We also instantiate the administrative ACL, which we'll use +# for various things. Throw an exception if anything goes wrong. +sub new { + my ($class, $user, $host) = @_; + my $schema = Wallet::Schema->connect; + my $acl = Wallet::ACL->new ('ADMIN', $schema); + my $self = { + schema => $schema, + user => $user, + host => $host, + admin => $acl, + }; + bless ($self, $class); + return $self; +} + +# Returns the database handle (used mostly for testing). +sub dbh { + my ($self) = @_; + return $self->{schema}->storage->dbh; +} + +# Returns the DBIx::Class-based database schema object. +sub schema { + my ($self) = @_; + return $self->{schema}; +} + +# Set or return the error stashed in the object. +sub error { + my ($self, @error) = @_; + if (@error) { + my $error = join ('', @error); + chomp $error; + 1 while ($error =~ s/ at \S+ line \d+\.?\z//); + $self->{error} = $error; + } + return $self->{error}; +} + +# Disconnect the database handle on object destruction to avoid warnings. +sub DESTROY { + my ($self) = @_; + + if ($self->{schema}) { + $self->{schema}->storage->dbh->disconnect; + } +} + +############################################################################## +# Object methods +############################################################################## + +# Given an object type, return the mapping to a class by querying the +# database, or undef if no mapping exists. Also load the relevant module. +sub type_mapping { + my ($self, $type) = @_; + my $class; + eval { + my $guard = $self->{schema}->txn_scope_guard; + my %search = (ty_name => $type); + my $type_rec = $self->{schema}->resultset('Type')->find (\%search); + $class = $type_rec->ty_class; + $guard->commit; + }; + if ($@) { + $self->error ($@); + return; + } + if (defined $class) { + eval "require $class"; + if ($@) { + $self->error ($@); + return; + } + } + return $class; +} + +# Given an object which doesn't currently exist, check whether a default_owner +# function is defined and, if so, if it returns an ACL for that object. If +# so, create the ACL and check if the current user is authorized by that ACL. +# Returns true if so, false if not, setting the internal error as appropriate. +# +# This leaves those new ACLs in the database, which may not be the best +# behavior, but it's the simplest given the current Wallet::ACL API. This +# should probably be revisited later. +sub create_check { + my ($self, $type, $name) = @_; + my $user = $self->{user}; + my $host = $self->{host}; + my $schema = $self->{schema}; + unless (defined (&Wallet::Config::default_owner)) { + $self->error ("$user not authorized to create ${type}:${name}"); + return; + } + my ($aname, @acl) = Wallet::Config::default_owner ($type, $name); + unless (defined $aname) { + $self->error ("$user not authorized to create ${type}:${name}"); + return; + } + my $acl = eval { Wallet::ACL->new ($aname, $schema) }; + if ($@) { + $acl = eval { Wallet::ACL->create ($aname, $schema, $user, $host) }; + if ($@) { + $self->error ($@); + return; + } + for my $entry (@acl) { + unless ($acl->add ($entry->[0], $entry->[1], $user, $host)) { + $self->error ($acl->error); + return; + } + } + } else { + my @entries = $acl->list; + if (not @entries and $acl->error) { + $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; + my $okay = 1; + if (@entries != @acl) { + $okay = 0; + } else { + for my $i (0 .. $#entries) { + $okay = 0 unless ($entries[$i][0] eq $acl[$i][0]); + $okay = 0 unless ($entries[$i][1] eq $acl[$i][1]); + } + } + unless ($okay) { + $self->error ("ACL $aname exists and doesn't match default"); + return; + } + } + if ($acl->check ($user)) { + return $aname; + } else { + $self->error ("$user not authorized to create ${type}:${name}"); + return; + } +} + +# Create an object and returns it. This function is called by both create and +# autocreate and assumes that permissions and names have already been checked. +# On error, returns undef and sets the internal error. +sub create_object { + my ($self, $type, $name) = @_; + my $class = $self->type_mapping ($type); + unless ($class) { + $self->error ("unknown object type $type"); + return; + } + my $schema = $self->{schema}; + my $user = $self->{user}; + my $host = $self->{host}; + my $object = eval { $class->create ($type, $name, $schema, $user, $host) }; + if ($@) { + $self->error ($@); + return; + } + return $object; +} + +# Create a new object and returns that object. This method can only be called +# by wallet administrators. autocreate should be used by regular users who +# may benefit from default ACLs. On error, returns undef and sets the +# internal error. +sub create { + my ($self, $type, $name) = @_; + unless ($self->{admin}->check ($self->{user})) { + my $id = $type . ':' . $name; + $self->error ("$self->{user} not authorized to create $id"); + return; + } + if (defined (&Wallet::Config::verify_name)) { + my $error = Wallet::Config::verify_name ($type, $name, $self->{user}); + if ($error) { + $self->error ("${type}:${name} rejected: $error"); + return; + } + } + return unless $self->create_object ($type, $name); + return 1; +} + +# Attempt to auto-create an object based on default ACLs. This method is +# called by the wallet client when trying to get an object that doesn't +# already exist. On error, returns undef and sets the internal error. +sub autocreate { + my ($self, $type, $name) = @_; + if (defined (&Wallet::Config::verify_name)) { + my $error = Wallet::Config::verify_name ($type, $name, $self->{user}); + if ($error) { + $self->error ("${type}:${name} rejected: $error"); + return; + } + } + my $acl = $self->create_check ($type, $name); + return unless $acl; + my $object = $self->create_object ($type, $name); + return unless $object; + unless ($object->owner ($acl, $self->{user}, $self->{host})) { + $self->error ($object->error); + return; + } + return 1; +} + +# Given the name and type of an object, returns a Perl object representing it +# or returns undef and sets the internal error. +sub retrieve { + my ($self, $type, $name) = @_; + my $class = $self->type_mapping ($type); + unless ($class) { + $self->error ("unknown object type $type"); + return; + } + my $object = eval { $class->new ($type, $name, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } else { + return $object; + } +} + +# Sets the internal error variable to the correct message for permission +# denied on an object. +sub object_error { + my ($self, $object, $action) = @_; + my $user = $self->{user}; + my $id = $object->type . ':' . $object->name; + if ($action eq 'getattr') { + $action = "get attributes for"; + } elsif ($action eq 'setattr') { + $action = "set attributes for"; + } elsif ($action !~ /^(create|get|store|show|destroy)\z/) { + $action = "set $action for"; + } + $self->error ("$self->{user} not authorized to $action $id"); +} + +# Given an object and an action, checks if the current user has access to +# perform that object. If so, returns true. If not, returns undef and sets +# the internal error message. Note that we do not allow any special access to +# admins for get and store; if they want to do that with objects, they need to +# set the ACL accordingly. +sub acl_verify { + my ($self, $object, $action) = @_; + my %actions = map { $_ => 1 } + qw(get store show destroy flags setattr getattr comment); + unless ($actions{$action}) { + $self->error ("unknown action $action"); + return; + } + if ($action ne 'get' and $action ne 'store') { + return 1 if $self->{admin}->check ($self->{user}); + } + my $id; + if ($action eq 'getattr') { + $id = $object->acl ('show'); + } elsif ($action eq 'setattr') { + $id = $object->acl ('store'); + } elsif ($action ne 'comment') { + $id = $object->acl ($action); + } + if (! defined ($id) and $action ne 'flags') { + $id = $object->owner; + } + unless (defined $id) { + $self->object_error ($object, $action); + return; + } + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + my $status = $acl->check ($self->{user}); + if ($status == 1) { + return 1; + } elsif (not defined $status) { + $self->error ($acl->error); + return; + } else { + $self->object_error ($object, $action); + return; + } +} + +# Retrieves or sets an ACL on an object. +sub acl { + my ($self, $type, $name, $acl, $id) = @_; + undef $self->{error}; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + unless ($self->{admin}->check ($self->{user})) { + $self->object_error ($object, 'ACL'); + return; + } + my $result; + if (defined $id) { + $result = $object->acl ($acl, $id, $self->{user}, $self->{host}); + } else { + $result = $object->acl ($acl); + } + if (not defined ($result) and $object->error) { + $self->error ($object->error); + } + return $result; +} + +# Retrieves or sets an attribute on an object. +sub attr { + my ($self, $type, $name, $attr, @values) = @_; + undef $self->{error}; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + my $user = $self->{user}; + my $host = $self->{host}; + if (@values) { + return unless $self->acl_verify ($object, 'setattr'); + if (@values == 1 and $values[0] eq '') { + @values = (); + } + my $result = $object->attr ($attr, [ @values ], $user, $host); + $self->error ($object->error) unless $result; + return $result; + } else { + return unless $self->acl_verify ($object, 'getattr'); + my @result = $object->attr ($attr); + if (not @result and $object->error) { + $self->error ($object->error); + return; + } else { + return @result; + } + } +} + +# Retrieves or sets the comment of an object. +sub comment { + my ($self, $type, $name, $comment) = @_; + undef $self->{error}; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + my $result; + if (defined $comment) { + return unless $self->acl_verify ($object, 'comment'); + $result = $object->comment ($comment, $self->{user}, $self->{host}); + } else { + return unless $self->acl_verify ($object, 'show'); + $result = $object->comment; + } + if (not defined ($result) and $object->error) { + $self->error ($object->error); + } + return $result; +} + +# Retrieves or sets the expiration of an object. +sub expires { + my ($self, $type, $name, $expires) = @_; + undef $self->{error}; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + unless ($self->{admin}->check ($self->{user})) { + $self->object_error ($object, 'expires'); + return; + } + my $result; + if (defined $expires) { + $result = $object->expires ($expires, $self->{user}, $self->{host}); + } else { + $result = $object->expires; + } + if (not defined ($result) and $object->error) { + $self->error ($object->error); + } + return $result; +} + +# Retrieves or sets the owner of an object. +sub owner { + my ($self, $type, $name, $owner) = @_; + undef $self->{error}; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + unless ($self->{admin}->check ($self->{user})) { + $self->object_error ($object, 'owner'); + return; + } + my $result; + if (defined $owner) { + $result = $object->owner ($owner, $self->{user}, $self->{host}); + } else { + $result = $object->owner; + } + if (not defined ($result) and $object->error) { + $self->error ($object->error); + } + return $result; +} + +# Checks for the existence of an object. Returns 1 if it does, 0 if it +# doesn't, and undef if there was an error in checking the existence of the +# object. +sub check { + my ($self, $type, $name) = @_; + my $object = $self->retrieve ($type, $name); + if (not defined $object) { + if ($self->error =~ /^cannot find/) { + return 0; + } else { + return; + } + } + return 1; +} + +# Retrieve the information associated with an object, or 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 get { + my ($self, $type, $name) = @_; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + return unless $self->acl_verify ($object, 'get'); + my $result = $object->get ($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 +# object doesn't exist, attempts dynamic creation of the object using the +# default ACL mappings (if any). +sub store { + my ($self, $type, $name, $data) = @_; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + return unless $self->acl_verify ($object, 'store'); + if (not defined ($data)) { + $self->{error} = "no data supplied to store"; + return; + } + my $result = $object->store ($data, $self->{user}, $self->{host}); + $self->error ($object->error) unless defined $result; + return $result; +} + +# Return a human-readable description of the object's metadata, or returns +# undef and sets the internal error if the object can't be found or if the +# user isn't authorized. +sub show { + my ($self, $type, $name) = @_; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + return unless $self->acl_verify ($object, 'show'); + my $result = $object->show; + $self->error ($object->error) unless defined $result; + return $result; +} + +# Return a human-readable description of the object history, or returns undef +# and sets the internal error if the object can't be found or if the user +# isn't authorized. +sub history { + my ($self, $type, $name) = @_; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + return unless $self->acl_verify ($object, 'show'); + my $result = $object->history; + $self->error ($object->error) unless defined $result; + return $result; +} + +# Destroys the object, or returns undef and sets the internal error if the +# object can't be found or if the user isn't authorized. +sub destroy { + my ($self, $type, $name) = @_; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + return unless $self->acl_verify ($object, 'destroy'); + my $result = $object->destroy ($self->{user}, $self->{host}); + $self->error ($object->error) unless defined $result; + return $result; +} + +############################################################################## +# Object flag methods +############################################################################## + +# Clear a flag on an object. Takes the object and the flag. Returns true on +# success or undef and sets the internal error on failure. +sub flag_clear { + my ($self, $type, $name, $flag) = @_; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + return unless $self->acl_verify ($object, 'flags'); + my $result = $object->flag_clear ($flag, $self->{user}, $self->{host}); + $self->error ($object->error) unless defined $result; + return $result; +} + +# Set a flag on an object. Takes the object and the flag. Returns true on +# success or undef and sets the internal error on failure. +sub flag_set { + my ($self, $type, $name, $flag) = @_; + my $object = $self->retrieve ($type, $name); + return unless defined $object; + return unless $self->acl_verify ($object, 'flags'); + my $result = $object->flag_set ($flag, $self->{user}, $self->{host}); + $self->error ($object->error) unless defined $result; + return $result; +} + +############################################################################## +# ACL methods +############################################################################## + +# Checks for the existence of an ACL. Returns 1 if it does, 0 if it doesn't, +# and undef if there was an error in checking the existence of the object. +sub acl_check { + my ($self, $id) = @_; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + if ($@ =~ /^ACL .* not found/) { + return 0; + } else { + $self->error ($@); + return; + } + } + return 1; +} + +# Create a new empty ACL in the database. Returns true on success and undef +# on failure, setting the internal error. +sub acl_create { + my ($self, $name) = @_; + unless ($self->{admin}->check ($self->{user})) { + $self->error ("$self->{user} not authorized to create ACL"); + return; + } + my $user = $self->{user}; + my $host = $self->{host}; + if (defined (&Wallet::Config::verify_acl_name)) { + my $error = Wallet::Config::verify_acl_name ($name, $user); + if ($error) { + $self->error ("$name rejected: $error"); + return; + } + } + my $schema = $self->{schema}; + my $acl = eval { Wallet::ACL->create ($name, $schema, $user, $host) }; + if ($@) { + $self->error ($@); + return; + } else { + return 1; + } +} + +# Sets the internal error variable to the correct message for permission +# denied on an ACL. +sub acl_error { + my ($self, $acl, $action) = @_; + my $user = $self->{user}; + if ($action eq 'add') { + $action = 'add to'; + } elsif ($action eq 'remove') { + $action = 'remove from'; + } elsif ($action eq 'history') { + $action = 'see history of'; + } + $self->error ("$self->{user} not authorized to $action ACL $acl"); +} + +# Display the history of an ACL or return undef and set the internal error. +sub acl_history { + my ($self, $id) = @_; + unless ($self->{admin}->check ($self->{user})) { + $self->acl_error ($id, 'history'); + return; + } + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + my $result = $acl->history; + if (not defined $result) { + $self->error ($acl->error); + return; + } + return $result; +} + +# Display the membership of an ACL or return undef and set the internal error. +sub acl_show { + my ($self, $id) = @_; + unless ($self->{admin}->check ($self->{user})) { + $self->acl_error ($id, 'show'); + return; + } + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + my $result = $acl->show; + if (not defined $result) { + $self->error ($acl->error); + return; + } + return $result; +} + +# Change the human-readable name of an ACL or return undef and set the +# internal error. +sub acl_rename { + my ($self, $id, $name) = @_; + unless ($self->{admin}->check ($self->{user})) { + $self->acl_error ($id, 'rename'); + return; + } + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + if ($acl->name eq 'ADMIN') { + $self->error ('cannot rename the ADMIN ACL'); + return; + } + if (defined (&Wallet::Config::verify_acl_name)) { + my $error = Wallet::Config::verify_acl_name ($name, $self->{user}); + if ($error) { + $self->error ("$name rejected: $error"); + return; + } + } + unless ($acl->rename ($name)) { + $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 { + my ($self, $id) = @_; + unless ($self->{admin}->check ($self->{user})) { + $self->acl_error ($id, 'destroy'); + return; + } + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + if ($acl->name eq 'ADMIN') { + $self->error ('cannot destroy the ADMIN ACL'); + return; + } + unless ($acl->destroy ($self->{user}, $self->{host})) { + $self->error ($acl->error); + return; + } + return 1; +} + +# Add an ACL entry to an ACL. Returns true on success. On failure, returns +# undef, setting the internal error. +sub acl_add { + my ($self, $id, $scheme, $identifier) = @_; + unless ($self->{admin}->check ($self->{user})) { + $self->acl_error ($id, 'add'); + return; + } + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + unless ($acl->add ($scheme, $identifier, $self->{user}, $self->{host})) { + $self->error ($acl->error); + return; + } + return 1; +} + +# Remove an ACL entry to an ACL. Returns true on success. On failure, +# returns undef, setting the internal error. +sub acl_remove { + my ($self, $id, $scheme, $identifier) = @_; + unless ($self->{admin}->check ($self->{user})) { + $self->acl_error ($id, 'remove'); + return; + } + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; + if ($@) { + $self->error ($@); + return; + } + if ($acl->name eq 'ADMIN') { + my @e = $acl->list; + if (not @e and $acl->error) { + $self->error ($acl->error); + return; + } elsif (@e == 1 && $e[0][0] eq $scheme && $e[0][1] eq $identifier) { + $self->error ('cannot remove last ADMIN ACL entry'); + return; + } + } + my $user = $self->{user}; + my $host = $self->{host}; + unless ($acl->remove ($scheme, $identifier, $user, $host)) { + $self->error ($acl->error); + return; + } + return 1; +} + +1; +__END__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +Wallet::Server - Wallet system server implementation + +=for stopwords +keytabs metadata backend HOSTNAME ACL timestamp ACL's nul Allbery +backend-specific wallet-backend verifier + +=head1 SYNOPSIS + + use Wallet::Server; + my $server = Wallet::Server->new ($user, $host); + $server->create ('keytab', 'host/example.com@EXAMPLE.COM'); + +=head1 DESCRIPTION + +Wallet::Server is the top-level class that implements the wallet server. +The wallet is a system for storing, generating, and retrieving secure +information such as Kerberos keytabs. The server maintains metadata about +the objects, checks access against ACLs, and dispatches requests for +objects to backend implementations for that object type. + +Wallet::Server is normally instantiated and used by B, a +thin wrapper around this object that determines the authenticated remote +user and gets user input and then calls the appropriate method of this +object. + +To use this object, several configuration variables must be set (at least +the database configuration). For information on those variables and how +to set them, see L. + +=head1 CLASS METHODS + +=over 4 + +=item new(PRINCIPAL, HOSTNAME) + +Creates a new wallet server object for actions from the user PRINCIPAL +connecting from HOSTNAME. PRINCIPAL and HOSTNAME will be used for logging +history information for all subsequent operations. new() opens the +database, using the database configuration as set by Wallet::Config and +ensures that the C ACL exists. That ACL will be used to authorize +privileged operations. + +On any error, this method throws an exception. + +=back + +=head1 INSTANCE METHODS + +For all methods that can fail, the caller should call error() after a +failure to get the error message. + +=over 4 + +=item acl(TYPE, NAME, ACL [, ID]) + +Gets or sets the ACL type ACL to ID for the object identified by TYPE and +NAME. ACL should be one of C, C, C, C, or +C. If ID is not given, returns the current setting of that ACL as +a numeric ACL ID or undef if that ACL isn't set or on failure. To +distinguish between an ACL that isn't set and a failure to retrieve the +ACL, the caller should call error() after an undef return. If error() +also returns undef, that ACL wasn't set; otherwise, error() will return +the error message. + +If ID is given, sets the specified ACL to ID, which can be either the name +of an ACL or a numeric ACL ID. To clear the ACL, pass in an empty string +as the ID. To set or clear an ACL, the current user must be authorized by +the ADMIN ACL. Returns true for success and false for failure. + +ACL settings are checked before the owner and override the owner setting. + +=item acl_add(ID, SCHEME, IDENTIFIER) + +Adds an ACL entry with scheme SCHEME and identifier IDENTIFIER to the ACL +identified by ID. ID may be either the ACL name or the numeric ACL ID. +SCHEME must be a valid ACL scheme for which the wallet system has an ACL +verifier implementation. To add an entry to an ACL, the current user must +be authorized by the ADMIN ACL. Returns true for success and false for +failure. + +=item acl_create(NAME) + +Create a new ACL with the specified NAME, which must not be all-numeric. +The newly created ACL will be empty. To create an ACL, the current user +must be authorized by the ADMIN ACL. Returns true on success and false on +failure. + +=item acl_destroy(ID) + +Destroys the ACL identified by ID, which may be either the ACL name or its +numeric ID. This call will fail if the ACL is still referenced by any +object. The ADMIN ACL may not be destroyed. To destroy an ACL, the +current user must be authorized by the ADMIN ACL. Returns true on success +and false on failure. + +=item acl_history(ID) + +Returns the history of the ACL identified by ID, which may be either the +ACL name or its numeric ID. To see the history of an ACL, the current +user must be authorized by the ADMIN ACL. Each change that modifies the +ACL (not counting changes in the name of the ACL) will be represented by +two lines. The first line will have a timestamp of the change followed by +a description of the change, and the second line will give the user who +made the change and the host from which the change was made. Returns +undef on failure. + +=item acl_remove(ID, SCHEME, IDENTIFIER) + +Removes from the ACL identified by ID the entry matching SCHEME and +IDENTIFIER. ID may be either the name of the ACL or its numeric ID. The +last entry in the ADMIN ACL cannot be removed. To remove an entry from an +ACL, the current user must be authorized by the ADMIN ACL. Returns true +on success and false on failure. + +=item acl_rename(OLD, NEW) + +Renames the ACL identified by OLD to NEW. This changes the human-readable +name, not the underlying numeric ID, so the ACL's associations with +objects will be unchanged. The ADMIN ACL may not be renamed. OLD may be +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_show(ID) + +Returns a human-readable description, including membership, of the ACL +identified by ID, which may be either the ACL name or its numeric ID. To +show an ACL, the current user must be authorized by the ADMIN ACL +(although be aware that anyone with show access to an object can see the +membership of ACLs associated with that object through the show() method). +Returns the human-readable description on success and undef on failure. + +=item attr(TYPE, NAME, ATTRIBUTE [, VALUE ...]) + +Sets or retrieves a given object attribute. Attributes are used to store +backend-specific information for a particular object type and ATTRIBUTE +must be an attribute type known to the underlying object implementation. + +If VALUE is not given, returns the values of that attribute, if any, as a +list. On error, returns the empty list. To distinguish between an error +and an empty return, call error() afterward. It is guaranteed to return +undef unless there was an error. To retrieve an attribute setting, the +user must be authorized by the ADMIN ACL, the show ACL if set, or the +owner ACL if the show ACL is not set. + +If VALUE is given, sets the given ATTRIBUTE values to VALUE, which is one +or more attribute values. Pass the empty string as the only VALUE to +clear the attribute values. Returns true on success and false on failure. +To set an attribute value, the user must be authorized by the ADMIN ACL, +the store ACL if set, or the owner ACL if the store ACL is not set. + +=item autocreate(TYPE, NAME) + +Creates a new object of type TYPE and name NAME. TYPE must be a +recognized type for which the wallet system has a backend implementation. +Returns true on success and false on failure. + +To create an object using this method, the current user must be authorized +by the default owner as determined by the wallet configuration. For more +information on how to map new objects to default owners, see +Wallet::Config(3). Wallet administrators should use the create() method +to create objects. + +=item check(TYPE, NAME) + +Check whether an object of type TYPE and name NAME exists. Returns 1 if +it does, 0 if it doesn't, and undef if some error occurred while checking +for the existence of the object. + +=item comment(TYPE, NAME, [COMMENT]) + +Gets or sets the comment for the object identified by TYPE and NAME. If +COMMENT is not given, returns the current comment or undef if no comment +is set or on an error. To distinguish between an expiration that isn't +set and a failure to retrieve the expiration, the caller should call +error() after an undef return. If error() also returns undef, no comment +was set; otherwise, error() will return the error message. + +If COMMENT is given, sets the comment to COMMENT. Pass in the empty +string for COMMENT to clear the comment. To set a comment, the current +user must be the object owner or be on the ADMIN ACL. Returns true for +success and false for failure. + +=item create(TYPE, NAME) + +Creates a new object of type TYPE and name NAME. TYPE must be a +recognized type for which the wallet system has a backend implementation. +Returns true on success and false on failure. + +To create an object using this method, the current user must be authorized +by the ADMIN ACL. Use autocreate() to create objects based on the default +owner as determined by the wallet configuration. + +=item destroy(TYPE, NAME) + +Destroys the object identified by TYPE and NAME. This destroys any data +that the wallet had saved about the object, may remove the underlying +object from other external systems, and destroys the wallet database entry +for the object. To destroy an object, the current user must be a member +of the ADMIN ACL, authorized by the destroy ACL, or authorized by the +owner ACL; however, if the destroy ACL is set, the owner ACL will not be +checked. Returns true on success and false on failure. + +=item dbh() + +Returns the database handle of a Wallet::Server object. This is used +mostly for testing; normally, clients should perform all actions through +the Wallet::Server object to ensure that authorization and history logging +is done properly. + +=item 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. + +=item expires(TYPE, NAME [, EXPIRES]) + +Gets or sets the expiration for the object identified by TYPE and NAME. +If EXPIRES is not given, returns the current expiration or undef if no +expiration is set or on an error. To distinguish between an expiration +that isn't set and a failure to retrieve the expiration, the caller should +call error() after an undef return. If error() also returns undef, the +expiration wasn't set; otherwise, error() will return the error message. + +If EXPIRES is given, sets the expiration to EXPIRES. EXPIRES must be in +the format C, although the time portion may be +omitted. Pass in the empty string for EXPIRES to clear the expiration +date. To set an expiration, the current user must be authorized by the +ADMIN ACL. Returns true for success and false for failure. + +=item flag_clear(TYPE, NAME, FLAG) + +Clears the flag FLAG on the object identified by TYPE and NAME. To clear +a flag, the current user must be authorized by the ADMIN ACL or the flags +ACL on the object. + +=item flag_set(TYPE, NAME, FLAG) + +Sets the flag FLAG on the object identified by TYPE and NAME. To set a +flag, the current user must be authorized by the ADMIN ACL or the flags +ACL on the object. + +=item get(TYPE, NAME) + +Returns the data associated with the object identified by TYPE and NAME. +Depending on the object TYPE, this may generate new data and invalidate +any existing data or it may return data previously stored or generated. +Note that this data may be binary and may contain nul characters. To get +an object, the current user must either be authorized by the owner ACL or +authorized by the get ACL; however, if the get ACL is set, the owner ACL +will not be checked. Being a member of the ADMIN ACL does not provide any +special privileges to get objects. + +Returns undef on failure. The caller should be careful to distinguish +between undef and the empty string, which is valid object data. + +=item history(TYPE, NAME) + +Returns (as a string) the human-readable history of the object identified +by TYPE and NAME, or undef on error. To see the object history, the +current user must be a member of the ADMIN ACL, authorized by the show +ACL, or authorized by the owner ACL; however, if the show ACL is set, the +owner ACL will not be checked. + +=item owner(TYPE, NAME [, OWNER]) + +Gets or sets the owner for the object identified by TYPE and NAME. If +OWNER is not given, returns the current owner as a numeric ACL ID or undef +if no owner is set or on an error. To distinguish between an owner that +isn't set and a failure to retrieve the owner, the caller should call +error() after an undef return. If error() also returns undef, that ACL +wasn't set; otherwise, error() will return the error message. + +If OWNER is given, sets the owner to OWNER, which may be either the name +of an ACL or a numeric ACL ID. To set an owner, the current user must be +authorized by the ADMIN ACL. Returns true for success and false for +failure. + +The owner of an object is permitted to get, store, and show that object, +but cannot destroy or set flags on that object without being listed on +those ACLs as well. + +=item schema() + +Returns the DBIx::Class schema object. + +=item show(TYPE, NAME) + +Returns (as a string) a human-readable representation of the metadata +stored for the object identified by TYPE and NAME, or undef on error. +Included is the metadata and entries of any ACLs associated with the +object. To show an object, the current user must be a member of the ADMIN +ACL, authorized by the show ACL, or authorized by the owner ACL; however, +if the show ACL is set, the owner ACL will not be checked. + +=item store(TYPE, NAME, DATA) + +Stores DATA for the object identified with TYPE and NAME for later +retrieval with get. Not all object types support this. Note that DATA +may be binary and may contain nul characters. To store an object, the +current user must either be authorized by the owner ACL or authorized by +the store ACL; however, if the store ACL is set, the owner ACL is not +checked. Being a member of the ADMIN ACL does not provide any special +privileges to store objects. Returns true on success and false on +failure. + +=back + +=head1 SEE ALSO + +wallet-backend(8) + +This module is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/t/acl.t b/perl/t/acl.t deleted file mode 100755 index e633f46..0000000 --- a/perl/t/acl.t +++ /dev/null @@ -1,232 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the wallet ACL API. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use POSIX qw(strftime); -use Test::More tests => 101; - -use Wallet::ACL; -use Wallet::Admin; -use Wallet::Server; - -use lib 't/lib'; -use Util; - -# Some global defaults to use. -my $admin = 'admin@EXAMPLE.COM'; -my $user1 = 'alice@EXAMPLE.COM'; -my $user2 = 'bob@EXAMPLE.COM'; -my $host = 'localhost'; -my @trace = ($admin, $host, time); - -# Use Wallet::Admin to set up the database. -db_setup; -my $setup = eval { Wallet::Admin->new }; -is ($@, '', 'Database connection succeeded'); -is ($setup->reinitialize ($setup), 1, 'Database initialization succeeded'); -my $schema = $setup->schema; - -# Test create and new. -my $acl = eval { Wallet::ACL->create ('test', $schema, @trace) }; -ok (defined ($acl), 'ACL creation'); -is ($@, '', ' with no exceptions'); -ok ($acl->isa ('Wallet::ACL'), ' and the right class'); -is ($acl->name, 'test', ' and the right name'); -is ($acl->id, 2, ' and the right ID'); -$acl = eval { Wallet::ACL->create (3, $schema, @trace) }; -ok (!defined ($acl), 'Creating with a numeric name'); -is ($@, "ACL name may not be all numbers\n", ' with the right error message'); -$acl = eval { Wallet::ACL->create ('test', $schema, @trace) }; -ok (!defined ($acl), 'Creating a duplicate object'); -like ($@, qr/^cannot create ACL test: /, ' with the right error message'); -$acl = eval { Wallet::ACL->new ('test2', $schema) }; -ok (!defined ($acl), 'Searching for a non-existent ACL'); -is ($@, "ACL test2 not found\n", ' with the right error message'); -$acl = eval { Wallet::ACL->new ('test', $schema) }; -ok (defined ($acl), 'Searching for the test ACL by name'); -is ($@, '', ' with no exceptions'); -ok ($acl->isa ('Wallet::ACL'), ' and the right class'); -is ($acl->id, 2, ' and the right ID'); -$acl = eval { Wallet::ACL->new (2, $schema) }; -ok (defined ($acl), 'Searching for the test ACL by ID'); -is ($@, '', ' with no exceptions'); -ok ($acl->isa ('Wallet::ACL'), ' and the right class'); -is ($acl->name, 'test', ' and the right name'); - -# Test rename. -if ($acl->rename ('example')) { - ok (1, 'Renaming the ACL'); -} else { - is ($acl->error, '', 'Renaming the ACL'); -} -is ($acl->name, 'example', ' and the new name is right'); -is ($acl->id, 2, ' and the ID did not change'); -$acl = eval { Wallet::ACL->new ('test', $schema) }; -ok (!defined ($acl), ' and it cannot be found under the old name'); -is ($@, "ACL test not found\n", ' with the right error message'); -$acl = eval { Wallet::ACL->new ('example', $schema) }; -ok (defined ($acl), ' and it can be found with the new name'); -is ($@, '', ' with no exceptions'); -is ($acl->name, 'example', ' and the right name'); -is ($acl->id, 2, ' and the right ID'); -$acl = eval { Wallet::ACL->new (2, $schema) }; -ok (defined ($acl), ' and it can still found by ID'); -is ($@, '', ' with no exceptions'); -is ($acl->name, 'example', ' and the right name'); -is ($acl->id, 2, ' and the right ID'); -ok (! $acl->rename ('ADMIN'), ' but renaming to an existing name fails'); -like ($acl->error, qr/^cannot rename ACL 2 to ADMIN: /, - ' with the right error'); - -# Test add, check, remove, list, and show. -my @entries = $acl->list; -is (scalar (@entries), 0, 'ACL starts empty'); -is ($acl->check ($user1), 0, ' so check fails'); -is (scalar ($acl->check_errors), '', ' with no errors'); -ok (! $acl->add ('example', 'foo', @trace), ' and cannot add bad scheme'); -is ($acl->error, 'unknown ACL scheme example', ' with the right error'); -if ($acl->add ('krb5', $user1, @trace)) { - ok (1, ' and can add a good scheme'); -} else { - is ($acl->error, '', ' and can add a good scheme'); -} -@entries = $acl->list; -is (scalar (@entries), 1, ' and now there is one element'); -is ($entries[0][0], 'krb5', ' with the right scheme'); -is ($entries[0][1], $user1, ' and identifier'); -is ($acl->check ($user1), 1, ' so check succeeds'); -is (scalar ($acl->check_errors), '', ' with no errors'); -is ($acl->check ($user2), 0, ' but the second user still fails'); -is (scalar ($acl->check_errors), '', ' with no errors'); -if ($acl->add ('krb5', $user2, @trace)) { - ok (1, ' and can add a second entry'); -} else { - is ($acl->error, '', ' and can add a second entry'); -} -is ($acl->check ($user2), 1, ' and now the second user checks'); -is (scalar ($acl->check_errors), '', ' with no errors'); -is ($acl->check ($user1), 1, ' and the first one still checks'); -is (scalar ($acl->check_errors), '', ' with no errors'); -@entries = sort { $a->[1] cmp $b->[1] } $acl->list; -is (scalar (@entries), 2, ' and now there are two entries'); -is ($entries[0][0], 'krb5', ' with the right scheme for 1'); -is ($entries[0][1], $user1, ' and the right identifier for 1'); -is ($entries[1][0], 'krb5', ' and the right scheme for 2'); -is ($entries[1][1], $user2, ' and the right identifier for 2'); -my $expected = <<"EOE"; -Members of ACL example (id: 2) are: - krb5 $user1 - krb5 $user2 -EOE -is ($acl->show, $expected, ' and show returns correctly'); -ok (! $acl->remove ('krb5', $admin, @trace), - 'Removing a nonexistent entry fails'); -is ($acl->error, "cannot remove krb5:$admin from 2: entry not found in ACL", - ' with the right error'); -if ($acl->remove ('krb5', $user1, @trace)) { - ok (1, ' but removing the first user works'); -} else { - is ($acl->error, '', ' but removing the first user works'); -} -is ($acl->check ($user1), 0, ' and now they do not check'); -is (scalar ($acl->check_errors), '', ' with no errors'); -@entries = $acl->list; -is (scalar (@entries), 1, ' and now there is one entry'); -is ($entries[0][0], 'krb5', ' with the right scheme'); -is ($entries[0][1], $user2, ' and the right identifier'); -ok (! $acl->add ('krb5', $user2), 'Adding the same entry again fails'); -like ($acl->error, qr/^cannot add \Qkrb5:$user2\E to 2: /, - ' with the right error'); -if ($acl->add ('krb5', '', @trace)) { - ok (1, 'Adding a bad entry works'); -} else { - is ($acl->error, '', 'Adding a bad entry works'); -} -@entries = sort { $a->[1] cmp $b->[1] } $acl->list; -is (scalar (@entries), 2, ' and now there are two entries'); -is ($entries[0][0], 'krb5', ' with the right scheme for 1'); -is ($entries[0][1], '', ' and the right identifier for 1'); -is ($entries[1][0], 'krb5', ' and the right scheme for 2'); -is ($entries[1][1], $user2, ' and the right identifier for 2'); -$expected = <<"EOE"; -Members of ACL example (id: 2) are: - krb5 - krb5 $user2 -EOE -is ($acl->show, $expected, ' and show returns correctly'); -is ($acl->check ($user2), 1, ' and checking the good entry still works'); -is (scalar ($acl->check_errors), "malformed krb5 ACL\n", - ' but now with the right error'); -my @errors = $acl->check_errors; -is (scalar (@errors), 1, ' and the error return is right in list context'); -is ($errors[0], 'malformed krb5 ACL', ' with the same text'); -is ($acl->check (''), undef, 'Checking with an empty principal fails'); -is ($acl->error, 'no principal specified', ' with the right error'); -if ($acl->remove ('krb5', $user2, @trace)) { - ok (1, 'Removing the second user works'); -} else { - is ($acl->error, '', 'Removing the second user works'); -} -is ($acl->check ($user2), 0, ' and now the second user check fails'); -is (scalar ($acl->check_errors), "malformed krb5 ACL\n", - ' with the right error'); -if ($acl->remove ('krb5', '', @trace)) { - ok (1, 'Removing the bad entry works'); -} else { - is ($acl->error, '', 'Removing the bad entry works'); -} -@entries = $acl->list; -is (scalar (@entries), 0, ' and now there are no entries'); -is ($acl->show, "Members of ACL example (id: 2) are:\n", ' and show concurs'); -is ($acl->check ($user2), 0, ' and the second user check fails'); -is (scalar ($acl->check_errors), '', ' with no error message'); - -# Test history. -my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); -my $history = <<"EOO"; -$date create - by $admin from $host -$date add krb5 $user1 - by $admin from $host -$date add krb5 $user2 - by $admin from $host -$date remove krb5 $user1 - by $admin from $host -$date add krb5 - by $admin from $host -$date remove krb5 $user2 - by $admin from $host -$date remove krb5 - by $admin from $host -EOO -is ($acl->history, $history, 'History is correct'); - -# Test destroy. -if ($acl->destroy (@trace)) { - ok (1, 'Destroying the ACL works'); -} else { - is ($acl->error, '', 'Destroying the ACL works'); -} -$acl = eval { Wallet::ACL->new ('example', $schema) }; -ok (!defined ($acl), ' and now cannot be found'); -is ($@, "ACL example not found\n", ' with the right error message'); -$acl = eval { Wallet::ACL->new (2, $schema) }; -ok (!defined ($acl), ' or by ID'); -is ($@, "ACL 2 not found\n", ' with the right error message'); -$acl = eval { Wallet::ACL->create ('example', $schema, @trace) }; -ok (defined ($acl), ' and creating another with the same name works'); -is ($@, '', ' with no exceptions'); -is ($acl->name, 'example', ' and the right name'); -like ($acl->id, qr{\A[23]\z}, ' and an ID of 2 or 3'); - -# Clean up. -$setup->destroy; -END { - unlink 'wallet-db'; -} diff --git a/perl/t/admin.t b/perl/t/admin.t deleted file mode 100755 index 41bc33a..0000000 --- a/perl/t/admin.t +++ /dev/null @@ -1,106 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for wallet administrative interface. -# -# Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2011, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 26; - -use Wallet::Admin; -use Wallet::Report; -use Wallet::Schema; -use Wallet::Server; -use DBI; - -use lib 't/lib'; -use Util; - -# We test database setup in init.t, so just do the basic setup here. -db_setup; -my $admin = eval { Wallet::Admin->new }; -is ($@, '', 'Wallet::Admin creation did not die'); -ok ($admin->isa ('Wallet::Admin'), ' and returned the right class'); -is ($admin->initialize ('admin@EXAMPLE.COM'), 1, - ' and initialization succeeds'); -is ($admin->upgrade, 1, ' and upgrade succeeds (should do nothing)'); -is ($admin->error, undef, ' and there is no error'); - -# We have an empty database, so we should see no objects and one ACL. -my $report = Wallet::Report->new; -my @objects = $report->objects; -is (scalar (@objects), 0, 'No objects in the database'); -is ($report->error, undef, ' and no error'); -my @acls = $report->acls; -is (scalar (@acls), 1, 'One ACL in the database'); -is ($acls[0][0], 1, ' and that is ACL ID 1'); -is ($acls[0][1], 'ADMIN', ' with the right name'); - -# Register a base object so that we can create a simple object. -is ($admin->register_object ('base', 'Wallet::Object::Base'), 1, - 'Registering Wallet::Object::Base works'); -is ($admin->register_object ('base', 'Wallet::Object::Base'), undef, - ' and cannot be registered twice'); -$server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; -is ($@, '', 'Creating a server instance did not die'); -is ($server->create ('base', 'service/admin'), 1, - ' and creating base:service/admin succeeds'); - -# Test registering a new ACL type. -is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), 1, - 'Registering Wallet::ACL::Base works'); -is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), undef, - ' and cannot be registered twice'); -is ($server->acl_add ('ADMIN', 'base', 'foo'), 1, - ' and adding a base ACL now works'); - -# Test re-initialization of the database. -$Wallet::Schema::VERSION = '0.07'; -is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, - ' and re-initialization succeeds'); - -# Test an upgrade. Reinitialize to an older version, then test upgrade to the -# current version. -SKIP: { - my @path = (split (':', $ENV{PATH})); - my ($sqlite) = grep { -x $_ } map { "$_/sqlite3" } @path; - skip 'sqlite3 not found', 5 unless $sqlite; - - # Delete all tables and then redump them straight from the SQL file to - # avoid getting the version table. - unlink 'wallet-db'; - my $status = system ('sqlite3', 'wallet-db', - '.read sql/Wallet-Schema-0.07-SQLite.sql'); - is ($status, 0, 'Reinstalling database from non-versioned SQL succeds'); - - # Upgrade to 0.08. - $Wallet::Schema::VERSION = '0.08'; - $admin = eval { Wallet::Admin->new }; - my $retval = $admin->upgrade; - is ($retval, 1, ' and performing an upgrade to 0.08 succeeds'); - my $sql = "select version from dbix_class_schema_versions order by" - . " version DESC"; - $version = $admin->dbh->selectall_arrayref ($sql); - is (@$version, 2, ' and versions table has correct number of rows'); - is (@{ $version->[0] }, 1, ' and correct number of columns'); - is ($version->[0][0], '0.08', ' and the schema version is correct'); - - # Upgrade to 0.09. - $Wallet::Schema::VERSION = '0.09'; - $admin = eval { Wallet::Admin->new }; - $retval = $admin->upgrade; - is ($retval, 1, ' and performing an upgrade to 0.09 succeeds'); - $sql = "select version from dbix_class_schema_versions order by" - . " version DESC"; - $version = $admin->dbh->selectall_arrayref ($sql); - is ($version->[0][0], '0.09', ' and the schema version is correct'); -} - -# Clean up. -is ($admin->destroy, 1, 'Destruction succeeds'); -END { - unlink 'wallet-db'; -} diff --git a/perl/t/config.t b/perl/t/config.t deleted file mode 100755 index 881f2bd..0000000 --- a/perl/t/config.t +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the wallet server configuration. -# -# Written by Russ Allbery -# Copyright 2008, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 6; - -# Silence warnings since we're not using use. -package Wallet::Config; -our $DB_DRIVER; -our $KEYTAB_AFS_KASETKEY; -our $KEYTAB_FLAGS; -our $KEYTAB_KADMIN; -package main; - -# Load with a nonexistent file. -$ENV{WALLET_CONFIG} = '/path/to/nonexistent/file'; -eval { require Wallet::Config }; -is ($@, '', 'Loading Wallet::Config with nonexistent config file works'); -is ($Wallet::Config::KEYTAB_FLAGS, '-clearpolicy', - ' and KEYTAB_FLAGS is correct'); -is ($Wallet::Config::KEYTAB_KADMIN, 'kadmin', - ' and KEYTAB_KADMIN is correct'); -is ($Wallet::Config::DB_DRIVER, undef, ' and DB_DRIVER is unset'); - -# Create a configuration file with a single setting. -open (CONFIG, '>', 'test-wallet.conf') - or die "$0: cannot create test-wallet.conf: $!\n"; -print CONFIG '$DB_DRIVER = "mysql";', "\n"; -print CONFIG "1;\n"; -close CONFIG; -$ENV{WALLET_CONFIG} = './test-wallet.conf'; - -# Reload the module and be sure it picks up that configuration file. -delete $INC{'Wallet/Config.pm'}; -eval { require Wallet::Config }; -is ($@, '', 'Loading Wallet::Config with new config file works'); -is ($Wallet::Config::DB_DRIVER, 'mysql', ' and now DB_DRIVER is set'); -unlink 'test-wallet.conf'; diff --git a/perl/t/docs/pod-spelling.t b/perl/t/docs/pod-spelling.t new file mode 100755 index 0000000..577a99e --- /dev/null +++ b/perl/t/docs/pod-spelling.t @@ -0,0 +1,74 @@ +#!/usr/bin/perl -w +# +# Check for spelling errors in POD documentation +# +# Checks all POD files in the tree for spelling problems using Pod::Spell and +# either aspell or ispell. aspell is preferred. This test is disabled unless +# RRA_MAINTAINER_TESTS is set, since spelling dictionaries vary too much +# between environments. +# +# Copyright 2008, 2009 Russ Allbery +# +# See LICENSE for licensing terms. + +use strict; +use Test::More; + +# Skip all spelling tests unless the maintainer environment variable is set. +plan skip_all => 'Spelling tests only run for maintainer' + unless $ENV{RRA_MAINTAINER_TESTS}; + +# Load required Perl modules. +eval 'use Test::Pod 1.00'; +plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; +eval 'use Pod::Spell'; +plan skip_all => 'Pod::Spell required to test POD spelling' if $@; + +# Locate a spell-checker. hunspell is not currently supported due to its lack +# of support for contractions (at least in the version in Debian). +my @spell; +my %options = (aspell => [ qw(-d en_US --home-dir=./ list) ], + ispell => [ qw(-d american -l -p /dev/null) ]); +SEARCH: for my $program (qw/aspell ispell/) { + for my $dir (split ':', $ENV{PATH}) { + if (-x "$dir/$program") { + @spell = ("$dir/$program", @{ $options{$program} }); + } + last SEARCH if @spell; + } +} +plan skip_all => 'aspell or ispell required to test POD spelling' + unless @spell; + +# Prerequisites are satisfied, so we're going to do some testing. Figure out +# what POD files we have and from that develop our plan. +$| = 1; +my @pod = all_pod_files (); +plan tests => scalar @pod; + +# Finally, do the checks. +for my $pod (@pod) { + my $child = open (CHILD, '-|'); + if (not defined $child) { + die "Cannot fork: $!\n"; + } elsif ($child == 0) { + my $pid = open (SPELL, '|-', @spell) or die "Cannot run @spell: $!\n"; + open (POD, '<', $pod) or die "Cannot open $pod: $!\n"; + my $parser = Pod::Spell->new; + $parser->parse_from_filehandle (\*POD, \*SPELL); + close POD; + close SPELL; + exit ($? >> 8); + } else { + my @words = ; + close CHILD; + SKIP: { + skip "@spell failed for $pod", 1 unless $? == 0; + for (@words) { + s/^\s+//; + s/\s+$//; + } + is ("@words", '', $pod); + } + } +} diff --git a/perl/t/docs/pod.t b/perl/t/docs/pod.t new file mode 100755 index 0000000..dfcf88e --- /dev/null +++ b/perl/t/docs/pod.t @@ -0,0 +1,15 @@ +#!/usr/bin/perl -w +# +# Test POD formatting for the wallet Perl modules. +# +# Written by Russ Allbery +# Copyright 2007, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use strict; +use Test::More; +eval 'use Test::Pod 1.00'; +plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; +all_pod_files_ok (); diff --git a/perl/t/duo.t b/perl/t/duo.t deleted file mode 100755 index 4229afe..0000000 --- a/perl/t/duo.t +++ /dev/null @@ -1,157 +0,0 @@ -#!/usr/bin/perl -# -# Tests for the Duo integration object implementation. -# -# Written by Russ Allbery -# Copyright 2014 -# 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; - -BEGIN { - eval 'use Net::Duo'; - plan skip_all => 'Net::Duo required for testing duo' - if $@; - eval 'use Net::Duo::Mock::Agent'; - plan skip_all => 'Net::Duo::Mock::Agent required for testing duo' - if $@; -} - -BEGIN { - use_ok('Wallet::Admin'); - use_ok('Wallet::Config'); - use_ok('Wallet::Object::Duo'); -} - -use lib 't/lib'; -use Util; - -# Some global defaults to use. -my $user = 'admin@EXAMPLE.COM'; -my $host = 'localhost'; -my @trace = ($user, $host, time); -my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); - -# Flush all output immediately. -$| = 1; - -# Use Wallet::Admin to set up the database. -db_setup; -my $admin = eval { Wallet::Admin->new }; -is ($@, '', 'Database connection succeeded'); -is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $schema = $admin->schema; - -# Create a mock object to use for Duo calls. -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->new ('duo', 'test', $schema); -}; -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->create ('duo', 'test', $schema, @trace); -}; -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. -$Wallet::Config::DUO_AGENT = $mock; -$Wallet::Config::DUO_KEY_FILE = 't/data/duo/keys.json'; - -# Test creating an integration. -note ('Test creating an integration'); -my $expected = { - name => 'test', - notes => 'Managed by wallet', - type => 'unix', -}; -$mock->expect ( - { - method => 'POST', - uri => '/admin/v1/integrations', - content => $expected, - response_file => 't/data/duo/integration.json', - } -); -$object = Wallet::Object::Duo->create ('duo', 'test', $schema, @trace); -isa_ok ($object, 'Wallet::Object::Duo'); - -# Check the metadata about the new wallet object. -$expected = <<"EOO"; - Type: duo - Name: test - Duo key: DIRWIH0ZZPV4G88B37VQ - Created by: $user - Created from: $host - Created on: $date -EOO -is ($object->show, $expected, 'Show output is correct'); - -# Test retrieving the integration information. -note ('Test retrieving an integration'); -$mock->expect ( - { - method => 'GET', - uri => '/admin/v1/integrations/DIRWIH0ZZPV4G88B37VQ', - response_file => 't/data/duo/integration.json', - } -); -my $data = $object->get (@trace); -ok (defined ($data), 'Retrieval succeeds'); -$expected = <<'EOO'; -[duo] -ikey = DIRWIH0ZZPV4G88B37VQ -skey = QO4ZLqQVRIOZYkHfdPDORfcNf8LeXIbCWwHazY7o -host = example-admin.duosecurity.com -EOO -is ($data, $expected, '...and integration data is correct'); - -# Ensure that we can't retrieve the object when locked. -is ($object->flag_set ('locked', @trace), 1, - 'Setting object to locked succeeds'); -is ($object->get, undef, '...and now get fails'); -is ($object->error, 'cannot get duo:test: object is locked', - '...with correct error'); -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->new ('duo', '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 -# calls and delete makes two calls. -note ('Test deleting an integration'); -$mock->expect ( - { - method => 'GET', - uri => '/admin/v1/integrations/DIRWIH0ZZPV4G88B37VQ', - response_file => 't/data/duo/integration.json', - } -); -TODO: { - local $TODO = 'Net::Duo::Mock::Agent not yet capable'; - - is ($object->destroy (@trace), 1, 'Duo object deletion succeeded'); - $object = eval { Wallet::Object::Duo->new ('duo', 'test', $schema) }; - is ($object, undef, '...and now object cannot be retrieved'); - is ($@, "cannot find duo:test\n", '...with correct error'); -} - -# Clean up. -$admin->destroy; -END { - unlink ('wallet-db'); -} - -# Done testing. -done_testing (); diff --git a/perl/t/file.t b/perl/t/file.t deleted file mode 100755 index 0aecd9d..0000000 --- a/perl/t/file.t +++ /dev/null @@ -1,150 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the file object implementation. -# -# Written by Russ Allbery -# Copyright 2008, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use POSIX qw(strftime); -use Test::More tests => 56; - -use Wallet::Admin; -use Wallet::Config; -use Wallet::Object::File; - -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]); - -# Test error handling in the absence of configuration. -$object = eval { - Wallet::Object::File->create ('file', 'test', $schema, @trace) - }; -ok (defined ($object), 'Creating a basic file object succeeds'); -ok ($object->isa ('Wallet::Object::File'), ' and is the right class'); -is ($object->get (@trace), undef, ' and get fails'); -is ($object->error, 'file support not configured', ' with the right error'); -is ($object->store (@trace), undef, ' and store fails'); -is ($object->error, 'file 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::FILE_BUCKET = 'test-files'; - -# Okay, now we can test. First, the basic object without store. -$object = eval { - Wallet::Object::File->create ('file', 'test', $schema, @trace) - }; -ok (defined ($object), 'Creating a basic file object succeeds'); -ok ($object->isa ('Wallet::Object::File'), ' and is the right class'); -is ($object->get (@trace), undef, ' and get fails'); -is ($object->error, 'cannot get file:test: object has not been stored', - ' with the right error'); -is ($object->destroy (@trace), 1, ' but destroying the object succeeds'); - -# Now store something and be sure that we get something reasonable. -$object = eval { - Wallet::Object::File->create ('file', 'test', $schema, @trace) - }; -ok (defined ($object), 'Recreating the object succeeds'); -is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); -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'), '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 fails if we delete it'); -is ($object->error, 'cannot get file: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'); - -# Try exceeding the store size. -$Wallet::Config::FILE_MAX_SIZE = 1024; -is ($object->store ('x' x 1024, @trace), 1, - ' and storing exactly 1024 characters works'); -is ($object->get (@trace), 'x' x 1024, ' and get returns the right thing'); -is ($object->store ('x' x 1025, @trace), undef, - ' but storing 1025 characters fails'); -is ($object->error, 'data exceeds maximum of 1024 bytes', - ' with the right error'); - -# Try storing the empty data object. -is ($object->store ('', @trace), 1, 'Storing the empty object works'); -is ($object->get (@trace), '', ' and get returns the right thing'); - -# Test destruction. -is ($object->destroy (@trace), 1, 'Destroying the object works'); -ok (! -f 'test-files/09/test', ' and the file is gone'); - -# Now try some aggressive names. -$object = eval { - Wallet::Object::File->create ('file', '../foo', $schema, @trace) - }; -ok (defined ($object), 'Creating ../foo succeeds'); -is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); -ok (-d 'test-files/39', ' and the hash bucket was created'); -ok (-f 'test-files/39/%2E%2E%2Ffoo', ' and the file exists'); -is (contents ('test-files/39/%2E%2E%2Ffoo'), 'foo', - ' with the right contents'); -is ($object->get (@trace), "foo\n", ' and get returns correctly'); -is ($object->destroy (@trace), 1, 'Destroying the object works'); -ok (! -f 'test-files/39/%2E%2E%2Ffoo', ' and the file is gone'); -$object = eval { - Wallet::Object::File->create ('file', "\0", $schema, @trace) - }; -ok (defined ($object), 'Creating nul succeeds'); -is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); -ok (-d 'test-files/93', ' and the hash bucket was created'); -ok (-f 'test-files/93/%00', ' and the file exists'); -is (contents ('test-files/93/%00'), 'foo', - ' with the right contents'); -is ($object->get (@trace), "foo\n", ' and get returns correctly'); -is ($object->destroy (@trace), 1, 'Destroying the object works'); -ok (! -f 'test-files/93/%00', ' and the file is gone'); - -# Test error handling in the file store. -system ('rm -r test-files') == 0 or die "cannot remove test-files\n"; -$object = eval { - Wallet::Object::File->create ('file', 'test', $schema, @trace) - }; -ok (defined ($object), 'Recreating the object succeeds'); -is ($object->store ("foo\n", @trace), undef, - ' and storing data in it fails'); -like ($object->error, qr/^cannot create file bucket 09: /, - ' with the right error'); -is ($object->get (@trace), undef, ' and get fails'); -like ($object->error, qr/^cannot create file bucket 09: /, - ' with the right error'); -is ($object->destroy (@trace), 1, ' but destroying the object succeeds'); - -# Clean up. -$admin->destroy; -END { - unlink ('wallet-db'); -} diff --git a/perl/t/general/acl.t b/perl/t/general/acl.t new file mode 100755 index 0000000..e633f46 --- /dev/null +++ b/perl/t/general/acl.t @@ -0,0 +1,232 @@ +#!/usr/bin/perl -w +# +# Tests for the wallet ACL API. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 101; + +use Wallet::ACL; +use Wallet::Admin; +use Wallet::Server; + +use lib 't/lib'; +use Util; + +# Some global defaults to use. +my $admin = 'admin@EXAMPLE.COM'; +my $user1 = 'alice@EXAMPLE.COM'; +my $user2 = 'bob@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($admin, $host, time); + +# Use Wallet::Admin to set up the database. +db_setup; +my $setup = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($setup->reinitialize ($setup), 1, 'Database initialization succeeded'); +my $schema = $setup->schema; + +# Test create and new. +my $acl = eval { Wallet::ACL->create ('test', $schema, @trace) }; +ok (defined ($acl), 'ACL creation'); +is ($@, '', ' with no exceptions'); +ok ($acl->isa ('Wallet::ACL'), ' and the right class'); +is ($acl->name, 'test', ' and the right name'); +is ($acl->id, 2, ' and the right ID'); +$acl = eval { Wallet::ACL->create (3, $schema, @trace) }; +ok (!defined ($acl), 'Creating with a numeric name'); +is ($@, "ACL name may not be all numbers\n", ' with the right error message'); +$acl = eval { Wallet::ACL->create ('test', $schema, @trace) }; +ok (!defined ($acl), 'Creating a duplicate object'); +like ($@, qr/^cannot create ACL test: /, ' with the right error message'); +$acl = eval { Wallet::ACL->new ('test2', $schema) }; +ok (!defined ($acl), 'Searching for a non-existent ACL'); +is ($@, "ACL test2 not found\n", ' with the right error message'); +$acl = eval { Wallet::ACL->new ('test', $schema) }; +ok (defined ($acl), 'Searching for the test ACL by name'); +is ($@, '', ' with no exceptions'); +ok ($acl->isa ('Wallet::ACL'), ' and the right class'); +is ($acl->id, 2, ' and the right ID'); +$acl = eval { Wallet::ACL->new (2, $schema) }; +ok (defined ($acl), 'Searching for the test ACL by ID'); +is ($@, '', ' with no exceptions'); +ok ($acl->isa ('Wallet::ACL'), ' and the right class'); +is ($acl->name, 'test', ' and the right name'); + +# Test rename. +if ($acl->rename ('example')) { + ok (1, 'Renaming the ACL'); +} else { + is ($acl->error, '', 'Renaming the ACL'); +} +is ($acl->name, 'example', ' and the new name is right'); +is ($acl->id, 2, ' and the ID did not change'); +$acl = eval { Wallet::ACL->new ('test', $schema) }; +ok (!defined ($acl), ' and it cannot be found under the old name'); +is ($@, "ACL test not found\n", ' with the right error message'); +$acl = eval { Wallet::ACL->new ('example', $schema) }; +ok (defined ($acl), ' and it can be found with the new name'); +is ($@, '', ' with no exceptions'); +is ($acl->name, 'example', ' and the right name'); +is ($acl->id, 2, ' and the right ID'); +$acl = eval { Wallet::ACL->new (2, $schema) }; +ok (defined ($acl), ' and it can still found by ID'); +is ($@, '', ' with no exceptions'); +is ($acl->name, 'example', ' and the right name'); +is ($acl->id, 2, ' and the right ID'); +ok (! $acl->rename ('ADMIN'), ' but renaming to an existing name fails'); +like ($acl->error, qr/^cannot rename ACL 2 to ADMIN: /, + ' with the right error'); + +# Test add, check, remove, list, and show. +my @entries = $acl->list; +is (scalar (@entries), 0, 'ACL starts empty'); +is ($acl->check ($user1), 0, ' so check fails'); +is (scalar ($acl->check_errors), '', ' with no errors'); +ok (! $acl->add ('example', 'foo', @trace), ' and cannot add bad scheme'); +is ($acl->error, 'unknown ACL scheme example', ' with the right error'); +if ($acl->add ('krb5', $user1, @trace)) { + ok (1, ' and can add a good scheme'); +} else { + is ($acl->error, '', ' and can add a good scheme'); +} +@entries = $acl->list; +is (scalar (@entries), 1, ' and now there is one element'); +is ($entries[0][0], 'krb5', ' with the right scheme'); +is ($entries[0][1], $user1, ' and identifier'); +is ($acl->check ($user1), 1, ' so check succeeds'); +is (scalar ($acl->check_errors), '', ' with no errors'); +is ($acl->check ($user2), 0, ' but the second user still fails'); +is (scalar ($acl->check_errors), '', ' with no errors'); +if ($acl->add ('krb5', $user2, @trace)) { + ok (1, ' and can add a second entry'); +} else { + is ($acl->error, '', ' and can add a second entry'); +} +is ($acl->check ($user2), 1, ' and now the second user checks'); +is (scalar ($acl->check_errors), '', ' with no errors'); +is ($acl->check ($user1), 1, ' and the first one still checks'); +is (scalar ($acl->check_errors), '', ' with no errors'); +@entries = sort { $a->[1] cmp $b->[1] } $acl->list; +is (scalar (@entries), 2, ' and now there are two entries'); +is ($entries[0][0], 'krb5', ' with the right scheme for 1'); +is ($entries[0][1], $user1, ' and the right identifier for 1'); +is ($entries[1][0], 'krb5', ' and the right scheme for 2'); +is ($entries[1][1], $user2, ' and the right identifier for 2'); +my $expected = <<"EOE"; +Members of ACL example (id: 2) are: + krb5 $user1 + krb5 $user2 +EOE +is ($acl->show, $expected, ' and show returns correctly'); +ok (! $acl->remove ('krb5', $admin, @trace), + 'Removing a nonexistent entry fails'); +is ($acl->error, "cannot remove krb5:$admin from 2: entry not found in ACL", + ' with the right error'); +if ($acl->remove ('krb5', $user1, @trace)) { + ok (1, ' but removing the first user works'); +} else { + is ($acl->error, '', ' but removing the first user works'); +} +is ($acl->check ($user1), 0, ' and now they do not check'); +is (scalar ($acl->check_errors), '', ' with no errors'); +@entries = $acl->list; +is (scalar (@entries), 1, ' and now there is one entry'); +is ($entries[0][0], 'krb5', ' with the right scheme'); +is ($entries[0][1], $user2, ' and the right identifier'); +ok (! $acl->add ('krb5', $user2), 'Adding the same entry again fails'); +like ($acl->error, qr/^cannot add \Qkrb5:$user2\E to 2: /, + ' with the right error'); +if ($acl->add ('krb5', '', @trace)) { + ok (1, 'Adding a bad entry works'); +} else { + is ($acl->error, '', 'Adding a bad entry works'); +} +@entries = sort { $a->[1] cmp $b->[1] } $acl->list; +is (scalar (@entries), 2, ' and now there are two entries'); +is ($entries[0][0], 'krb5', ' with the right scheme for 1'); +is ($entries[0][1], '', ' and the right identifier for 1'); +is ($entries[1][0], 'krb5', ' and the right scheme for 2'); +is ($entries[1][1], $user2, ' and the right identifier for 2'); +$expected = <<"EOE"; +Members of ACL example (id: 2) are: + krb5 + krb5 $user2 +EOE +is ($acl->show, $expected, ' and show returns correctly'); +is ($acl->check ($user2), 1, ' and checking the good entry still works'); +is (scalar ($acl->check_errors), "malformed krb5 ACL\n", + ' but now with the right error'); +my @errors = $acl->check_errors; +is (scalar (@errors), 1, ' and the error return is right in list context'); +is ($errors[0], 'malformed krb5 ACL', ' with the same text'); +is ($acl->check (''), undef, 'Checking with an empty principal fails'); +is ($acl->error, 'no principal specified', ' with the right error'); +if ($acl->remove ('krb5', $user2, @trace)) { + ok (1, 'Removing the second user works'); +} else { + is ($acl->error, '', 'Removing the second user works'); +} +is ($acl->check ($user2), 0, ' and now the second user check fails'); +is (scalar ($acl->check_errors), "malformed krb5 ACL\n", + ' with the right error'); +if ($acl->remove ('krb5', '', @trace)) { + ok (1, 'Removing the bad entry works'); +} else { + is ($acl->error, '', 'Removing the bad entry works'); +} +@entries = $acl->list; +is (scalar (@entries), 0, ' and now there are no entries'); +is ($acl->show, "Members of ACL example (id: 2) are:\n", ' and show concurs'); +is ($acl->check ($user2), 0, ' and the second user check fails'); +is (scalar ($acl->check_errors), '', ' with no error message'); + +# Test history. +my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); +my $history = <<"EOO"; +$date create + by $admin from $host +$date add krb5 $user1 + by $admin from $host +$date add krb5 $user2 + by $admin from $host +$date remove krb5 $user1 + by $admin from $host +$date add krb5 + by $admin from $host +$date remove krb5 $user2 + by $admin from $host +$date remove krb5 + by $admin from $host +EOO +is ($acl->history, $history, 'History is correct'); + +# Test destroy. +if ($acl->destroy (@trace)) { + ok (1, 'Destroying the ACL works'); +} else { + is ($acl->error, '', 'Destroying the ACL works'); +} +$acl = eval { Wallet::ACL->new ('example', $schema) }; +ok (!defined ($acl), ' and now cannot be found'); +is ($@, "ACL example not found\n", ' with the right error message'); +$acl = eval { Wallet::ACL->new (2, $schema) }; +ok (!defined ($acl), ' or by ID'); +is ($@, "ACL 2 not found\n", ' with the right error message'); +$acl = eval { Wallet::ACL->create ('example', $schema, @trace) }; +ok (defined ($acl), ' and creating another with the same name works'); +is ($@, '', ' with no exceptions'); +is ($acl->name, 'example', ' and the right name'); +like ($acl->id, qr{\A[23]\z}, ' and an ID of 2 or 3'); + +# Clean up. +$setup->destroy; +END { + unlink 'wallet-db'; +} diff --git a/perl/t/general/admin.t b/perl/t/general/admin.t new file mode 100755 index 0000000..41bc33a --- /dev/null +++ b/perl/t/general/admin.t @@ -0,0 +1,106 @@ +#!/usr/bin/perl -w +# +# Tests for wallet administrative interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010, 2011, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 26; + +use Wallet::Admin; +use Wallet::Report; +use Wallet::Schema; +use Wallet::Server; +use DBI; + +use lib 't/lib'; +use Util; + +# We test database setup in init.t, so just do the basic setup here. +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Wallet::Admin creation did not die'); +ok ($admin->isa ('Wallet::Admin'), ' and returned the right class'); +is ($admin->initialize ('admin@EXAMPLE.COM'), 1, + ' and initialization succeeds'); +is ($admin->upgrade, 1, ' and upgrade succeeds (should do nothing)'); +is ($admin->error, undef, ' and there is no error'); + +# We have an empty database, so we should see no objects and one ACL. +my $report = Wallet::Report->new; +my @objects = $report->objects; +is (scalar (@objects), 0, 'No objects in the database'); +is ($report->error, undef, ' and no error'); +my @acls = $report->acls; +is (scalar (@acls), 1, 'One ACL in the database'); +is ($acls[0][0], 1, ' and that is ACL ID 1'); +is ($acls[0][1], 'ADMIN', ' with the right name'); + +# Register a base object so that we can create a simple object. +is ($admin->register_object ('base', 'Wallet::Object::Base'), 1, + 'Registering Wallet::Object::Base works'); +is ($admin->register_object ('base', 'Wallet::Object::Base'), undef, + ' and cannot be registered twice'); +$server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; +is ($@, '', 'Creating a server instance did not die'); +is ($server->create ('base', 'service/admin'), 1, + ' and creating base:service/admin succeeds'); + +# Test registering a new ACL type. +is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), 1, + 'Registering Wallet::ACL::Base works'); +is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), undef, + ' and cannot be registered twice'); +is ($server->acl_add ('ADMIN', 'base', 'foo'), 1, + ' and adding a base ACL now works'); + +# Test re-initialization of the database. +$Wallet::Schema::VERSION = '0.07'; +is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, + ' and re-initialization succeeds'); + +# Test an upgrade. Reinitialize to an older version, then test upgrade to the +# current version. +SKIP: { + my @path = (split (':', $ENV{PATH})); + my ($sqlite) = grep { -x $_ } map { "$_/sqlite3" } @path; + skip 'sqlite3 not found', 5 unless $sqlite; + + # Delete all tables and then redump them straight from the SQL file to + # avoid getting the version table. + unlink 'wallet-db'; + my $status = system ('sqlite3', 'wallet-db', + '.read sql/Wallet-Schema-0.07-SQLite.sql'); + is ($status, 0, 'Reinstalling database from non-versioned SQL succeds'); + + # Upgrade to 0.08. + $Wallet::Schema::VERSION = '0.08'; + $admin = eval { Wallet::Admin->new }; + my $retval = $admin->upgrade; + is ($retval, 1, ' and performing an upgrade to 0.08 succeeds'); + my $sql = "select version from dbix_class_schema_versions order by" + . " version DESC"; + $version = $admin->dbh->selectall_arrayref ($sql); + is (@$version, 2, ' and versions table has correct number of rows'); + is (@{ $version->[0] }, 1, ' and correct number of columns'); + is ($version->[0][0], '0.08', ' and the schema version is correct'); + + # Upgrade to 0.09. + $Wallet::Schema::VERSION = '0.09'; + $admin = eval { Wallet::Admin->new }; + $retval = $admin->upgrade; + is ($retval, 1, ' and performing an upgrade to 0.09 succeeds'); + $sql = "select version from dbix_class_schema_versions order by" + . " version DESC"; + $version = $admin->dbh->selectall_arrayref ($sql); + is ($version->[0][0], '0.09', ' and the schema version is correct'); +} + +# Clean up. +is ($admin->destroy, 1, 'Destruction succeeds'); +END { + unlink 'wallet-db'; +} diff --git a/perl/t/general/config.t b/perl/t/general/config.t new file mode 100755 index 0000000..881f2bd --- /dev/null +++ b/perl/t/general/config.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl -w +# +# Tests for the wallet server configuration. +# +# Written by Russ Allbery +# Copyright 2008, 2010 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 6; + +# Silence warnings since we're not using use. +package Wallet::Config; +our $DB_DRIVER; +our $KEYTAB_AFS_KASETKEY; +our $KEYTAB_FLAGS; +our $KEYTAB_KADMIN; +package main; + +# Load with a nonexistent file. +$ENV{WALLET_CONFIG} = '/path/to/nonexistent/file'; +eval { require Wallet::Config }; +is ($@, '', 'Loading Wallet::Config with nonexistent config file works'); +is ($Wallet::Config::KEYTAB_FLAGS, '-clearpolicy', + ' and KEYTAB_FLAGS is correct'); +is ($Wallet::Config::KEYTAB_KADMIN, 'kadmin', + ' and KEYTAB_KADMIN is correct'); +is ($Wallet::Config::DB_DRIVER, undef, ' and DB_DRIVER is unset'); + +# Create a configuration file with a single setting. +open (CONFIG, '>', 'test-wallet.conf') + or die "$0: cannot create test-wallet.conf: $!\n"; +print CONFIG '$DB_DRIVER = "mysql";', "\n"; +print CONFIG "1;\n"; +close CONFIG; +$ENV{WALLET_CONFIG} = './test-wallet.conf'; + +# Reload the module and be sure it picks up that configuration file. +delete $INC{'Wallet/Config.pm'}; +eval { require Wallet::Config }; +is ($@, '', 'Loading Wallet::Config with new config file works'); +is ($Wallet::Config::DB_DRIVER, 'mysql', ' and now DB_DRIVER is set'); +unlink 'test-wallet.conf'; diff --git a/perl/t/general/init.t b/perl/t/general/init.t new file mode 100755 index 0000000..b8ec3c9 --- /dev/null +++ b/perl/t/general/init.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl -w +# +# Tests for database initialization. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 18; + +use Wallet::ACL; +use Wallet::Admin; + +use lib 't/lib'; +use Util; + +# Use Wallet::Admin to set up the database. +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Wallet::Admin creation did not die'); +ok ($admin->isa ('Wallet::Admin'), ' and returned the right class'); +is ($admin->initialize ('admin@EXAMPLE.COM'), 1, + ' and initialization succeeds'); + +# Check whether the database entries that should be created were. +my $acl = eval { Wallet::ACL->new ('ADMIN', $admin->schema) }; +is ($@, '', 'Retrieving ADMIN ACL successful'); +ok ($acl->isa ('Wallet::ACL'), ' and is the right class'); +my @entries = $acl->list; +is (scalar (@entries), 1, ' and has only one entry'); +isnt ($entries[0], undef, ' which is a valid entry'); +is ($entries[0][0], 'krb5', ' of krb5 scheme'); +is ($entries[0][1], 'admin@EXAMPLE.COM', ' with the right user'); + +# Test reinitialization. +is ($admin->reinitialize ('admin@EXAMPLE.ORG'), 1, + 'Reinitialization succeeded'); + +# Now repeat the database content checks. +$acl = eval { Wallet::ACL->new ('ADMIN', $admin->schema) }; +is ($@, '', 'Retrieving ADMIN ACL successful'); +ok ($acl->isa ('Wallet::ACL'), ' and is the right class'); +@entries = $acl->list; +is (scalar (@entries), 1, ' and has only one entry'); +isnt ($entries[0], undef, ' which is a valid entry'); +is ($entries[0][0], 'krb5', ' of krb5 scheme'); +is ($entries[0][1], 'admin@EXAMPLE.ORG', ' with the right user'); + +# Test cleanup. +is ($admin->destroy, 1, 'Destroying the database works'); +$acl = eval { Wallet::ACL->new ('ADMIN', $admin->schema) }; +like ($@, qr/^cannot search for ACL ADMIN: /, + ' and now the database is gone'); +END { + unlink 'wallet-db'; +} diff --git a/perl/t/general/report.t b/perl/t/general/report.t new file mode 100755 index 0000000..9563362 --- /dev/null +++ b/perl/t/general/report.t @@ -0,0 +1,330 @@ +#!/usr/bin/perl -w +# +# Tests for the wallet reporting interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 197; + +use Wallet::Admin; +use Wallet::Report; +use Wallet::Server; + +use lib 't/lib'; +use Util; + +# Use Wallet::Admin to set up the database. +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Wallet::Admin creation did not die'); +is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, + 'Database initialization succeeded'); +$admin->register_object ('base', 'Wallet::Object::Base'); +$admin->register_verifier ('base', 'Wallet::ACL::Base'); + +# We have an empty database, so we should see no objects and one ACL. +my $report = eval { Wallet::Report->new }; +is ($@, '', 'Wallet::Report creation did not die'); +ok ($report->isa ('Wallet::Report'), ' and returned the right class'); +my @objects = $report->objects; +is (scalar (@objects), 0, 'No objects in the database'); +is ($report->error, undef, ' and no error'); +my @acls = $report->acls; +is (scalar (@acls), 1, 'One ACL in the database'); +is ($acls[0][0], 1, ' and that is ACL ID 1'); +is ($acls[0][1], 'ADMIN', ' with the right name'); + +# Create an object. +$server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; +is ($@, '', 'Creating a server instance did not die'); +is ($server->create ('base', 'service/admin'), 1, + ' and creating base:service/admin succeeds'); + +# Now, we should see one object. +@objects = $report->objects; +is (scalar (@objects), 1, ' and now there is one object'); +is ($objects[0][0], 'base', ' with the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); + +# That object should be unused. +@objects = $report->objects ('unused'); +is (scalar (@objects), 1, ' and that object is unused'); +is ($objects[0][0], 'base', ' with the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); + +# Create another ACL. +is ($server->acl_create ('first'), 1, 'ACL creation succeeds'); +@acls = $report->acls; +is (scalar (@acls), 2, ' and now there are two ACLs'); +is ($acls[0][0], 1, ' and the first ID is correct'); +is ($acls[0][1], 'ADMIN', ' and the first name is correct'); +is ($acls[1][0], 2, ' and the second ID is correct'); +is ($acls[1][1], 'first', ' and the second name is correct'); + +# Delete that ACL and create another. +is ($server->acl_create ('second'), 1, 'Second ACL creation succeeds'); +is ($server->acl_destroy ('first'), 1, ' and deletion of the first succeeds'); +@acls = $report->acls; +is (scalar (@acls), 2, ' and there are still two ACLs'); +is ($acls[0][0], 1, ' and the first ID is still the same'); +is ($acls[0][1], 'ADMIN', ' and the first name is still the same'); +is ($acls[1][0], 3, ' but the second ID has changed'); +is ($acls[1][1], 'second', ' and the second name is correct'); + +# Currently, we have no owners, so we should get an empty owner report. +my @lines = $report->owners ('%', '%'); +is (scalar (@lines), 0, 'Owner report is currently empty'); +is ($report->error, undef, ' and there is no error'); + +# Set an owner and make sure we now see something in the report. +is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, + 'Setting an owner works'); +@lines = $report->owners ('%', '%'); +is (scalar (@lines), 1, ' and now there is one owner in the report'); +is ($lines[0][0], 'krb5', ' with the right scheme'); +is ($lines[0][1], 'admin@EXAMPLE.COM', ' and the right identifier'); +@lines = $report->owners ('keytab', '%'); +is (scalar (@lines), 0, 'Owners of keytabs is empty'); +is ($report->error, undef, ' with no error'); +@lines = $report->owners ('base', 'foo/%'); +is (scalar (@lines), 0, 'Owners of base foo/* objects is empty'); +is ($report->error, undef, ' with no error'); + +# Create a second object with the same owner. +is ($server->create ('base', 'service/foo'), 1, + 'Creating base:service/foo succeeds'); +is ($server->owner ('base', 'service/foo', 'ADMIN'), 1, + ' and setting the owner to the same value works'); +@lines = $report->owners ('base', 'service/%'); +is (scalar (@lines), 1, ' and there is still owner in the report'); +is ($lines[0][0], 'krb5', ' with the right scheme'); +is ($lines[0][1], 'admin@EXAMPLE.COM', ' and the right identifier'); + +# Both objects should now show as unused. +@objects = $report->objects ('unused'); +is (scalar (@objects), 2, 'There are now two unused objects'); +is ($objects[0][0], 'base', ' and the first has the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); +is ($objects[1][0], 'base', ' and the second has the right type'); +is ($objects[1][1], 'service/foo', ' and the right name'); + +# Change the owner of the second object to an empty ACL. +is ($server->owner ('base', 'service/foo', 'second'), 1, + ' and changing the owner to an empty ACL works'); +@lines = $report->owners ('base', '%'); +is (scalar (@lines), 1, ' and there is still owner in the report'); +is ($lines[0][0], 'krb5', ' with the right scheme'); +is ($lines[0][1], 'admin@EXAMPLE.COM', ' and the right identifier'); + +# Add a few things to the second ACL to see what happens. +is ($server->acl_add ('second', 'base', 'foo'), 1, + 'Adding an ACL line to the new ACL works'); +is ($server->acl_add ('second', 'base', 'bar'), 1, + ' and adding another ACL line to the new ACL works'); +@lines = $report->owners ('base', '%'); +is (scalar (@lines), 3, ' and now there are three owners in the report'); +is ($lines[0][0], 'base', ' first has the right scheme'); +is ($lines[0][1], 'bar', ' and the right identifier'); +is ($lines[1][0], 'base', ' second has the right scheme'); +is ($lines[1][1], 'foo', ' and the right identifier'); +is ($lines[2][0], 'krb5', ' third has the right scheme'); +is ($lines[2][1], 'admin@EXAMPLE.COM', ' and the right identifier'); + +# Test ownership and other ACL values. Change one keytab to be not owned by +# ADMIN, but have group permission on it. We'll need a third object neither +# owned by ADMIN or with any permissions from it. +is ($server->create ('base', 'service/null'), 1, + 'Creating base:service/null succeeds'); +is ($server->acl ('base', 'service/foo', 'get', 'ADMIN'), 1, + 'Changing the get ACL for the search also does'); +@lines = $report->objects ('owner', 'ADMIN'); +is (scalar (@lines), 1, 'Searching for objects owned by ADMIN finds one'); +is ($lines[0][0], 'base', ' and it has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +@lines = $report->objects ('owner', 'null'); +is (scalar (@lines), 1, 'Searching for objects with no set owner finds one'); +is ($lines[0][0], 'base', ' and it has the right type'); +is ($lines[0][1], 'service/null', ' and the right name'); +@lines = $report->objects ('acl', 'ADMIN'); +is (scalar (@lines), 2, 'ADMIN has any rights at all on two objects'); +is ($lines[0][0], 'base', ' and the first has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +is ($lines[1][0], 'base', ' and the second has the right type'); +is ($lines[1][1], 'service/foo', ' and the right name'); + +# Listing objects of a specific type. +@lines = $report->objects ('type', 'base'); +is (scalar (@lines), 3, 'Searching for all objects of type base finds three'); +is ($lines[0][0], 'base', ' and the first has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +is ($lines[1][0], 'base', ' and the second has the right type'); +is ($lines[1][1], 'service/foo', ' and the right name'); +is ($lines[2][0], 'base', ' and the third has the right type'); +is ($lines[2][1], 'service/null', ' and the right name'); +@lines = $report->objects ('type', 'keytab'); +is (scalar (@lines), 0, 'Searching for all objects of type keytab finds none'); + +# Test setting a flag, searching for objects with it, and then clearing it. +is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, + 'Setting a flag works'); +@lines = $report->objects ('flag', 'unchanging'); +is (scalar (@lines), 1, 'Searching for all objects with that flag finds one'); +is ($lines[0][0], 'base', ' and it has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); +is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, + 'Clearing the flag works'); +@lines = $report->objects ('flag', 'unchanging'); +is (scalar (@lines), 0, ' and now there are no objects in the report'); +is ($report->error, undef, ' with no error'); + +# All of our ACLs should be in use. +@lines = $report->acls ('unused'); +is (scalar (@lines), 0, 'Searching for unused ACLs returns nothing'); +is ($report->error, undef, ' with no error'); + +# Create some unused ACLs that should show up in the report. +is ($server->acl_create ('third'), 1, 'Creating an empty ACL succeeds'); +is ($server->acl_create ('fourth'), 1, ' and creating another succeeds'); +@lines = $report->acls ('unused'); +is (scalar (@lines), 2, ' and now we see two unused ACLs'); +is ($server->error, undef, ' with no error'); +is ($lines[0][0], 4, ' and the first has the right ID'); +is ($lines[0][1], 'third', ' and the right name'); +is ($lines[1][0], 5, ' and the second has the right ID'); +is ($lines[1][1], 'fourth', ' and the right name'); + +# Use one of those ACLs and ensure it drops out of the report. Test that we +# try all of the possible ACL types. +for my $type (qw/get store show destroy flags/) { + is ($server->acl ('base', 'service/admin', $type, 'fourth'), 1, + "Setting ACL $type to fourth succeeds"); + @lines = $report->acls ('unused'); + is (scalar (@lines), 1, ' and now we see only one unused ACL'); + is ($lines[0][0], 4, ' with the right ID'); + is ($lines[0][1], 'third', ' and the right name'); + is ($server->acl ('base', 'service/admin', $type, ''), 1, + ' and clearing the ACL succeeds'); + @lines = $report->acls ('unused'); + is (scalar (@lines), 2, ' and now we see two unused ACLs'); + is ($lines[0][0], 4, ' and the first has the right ID'); + is ($lines[0][1], 'third', ' and the right name'); + is ($lines[1][0], 5, ' and the second has the right ID'); + is ($lines[1][1], 'fourth', ' and the right name'); +} + +# The naming audit returns nothing if there's no naming policy. +@lines = $report->audit ('objects', 'name'); +is (scalar (@lines), 0, 'Searching for naming violations finds none'); +is ($report->error, undef, ' with no error'); + +# Set a naming policy and then look for objects that fail that policy. We +# have to deactivate this policy until now so that it doesn't prevent the +# creation of that name originally, which is the reason for the variable +# reference. +our $naming_active = 1; +package Wallet::Config; +sub verify_name { + my ($type, $name) = @_; + return unless $naming_active; + return 'admin not allowed' if $name eq 'service/admin'; + return; +} +package main; +@lines = $report->audit ('objects', 'name'); +is (scalar (@lines), 1, 'Searching for naming violations finds one'); +is ($lines[0][0], 'base', ' and the first has the right type'); +is ($lines[0][1], 'service/admin', ' and the right name'); + +# Set an ACL naming policy and then look for objects that fail that policy. +# Use the same deactivation trick as above. +package Wallet::Config; +sub verify_acl_name { + my ($name) = @_; + return unless $naming_active; + return 'second not allowed' if $name eq 'second'; + return; +} +package main; +@lines = $report->audit ('acls', 'name'); +is (scalar (@lines), 1, 'Searching for ACL naming violations finds one'); +is ($lines[0][0], 3, ' and the first has the right ID'); +is ($lines[0][1], 'second', ' and the right name'); + +# Set up a file bucket so that we can create an object we can retrieve. +system ('rm -rf test-files') == 0 or die "cannot remove test-files\n"; +mkdir 'test-files' or die "cannot create test-files: $!\n"; +$Wallet::Config::FILE_BUCKET = 'test-files'; + +# Create a file object and ensure that it shows up in the unused list. +is ($server->create ('file', 'test'), 1, 'Creating file:test succeeds'); +is ($server->owner ('file', 'test', 'ADMIN'), 1, + ' and setting its owner works'); +@objects = $report->objects ('unused'); +is (scalar (@objects), 4, 'There are now four unused objects'); +is ($objects[0][0], 'base', ' and the first has the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); +is ($objects[1][0], 'base', ' and the second has the right type'); +is ($objects[1][1], 'service/foo', ' and the right name'); +is ($objects[2][0], 'base', ' and the third has the right type'); +is ($objects[2][1], 'service/null', ' and the right name'); +is ($objects[3][0], 'file', ' and the fourth has the right type'); +is ($objects[3][1], 'test', ' and the right name'); + +# Store something and retrieve it, and then check that the file object fell +# off of the list. +is ($server->store ('file', 'test', 'Some data'), 1, + 'Storing data in file:test succeeds'); +is ($server->get ('file', 'test'), 'Some data', ' and retrieving it works'); +@objects = $report->objects ('unused'); +is (scalar (@objects), 3, ' and now there are three unused objects'); +is ($objects[0][0], 'base', ' and the first has the right type'); +is ($objects[0][1], 'service/admin', ' and the right name'); +is ($objects[1][0], 'base', ' and the second has the right type'); +is ($objects[1][1], 'service/foo', ' and the right name'); +is ($objects[2][0], 'base', ' and the third has the right type'); +is ($objects[2][1], 'service/null', ' and the right name'); + +# The third and fourth ACLs are both empty and should show up as duplicate. +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); +is (scalar (@{ $acls[0] }), 2, ' with two members'); +is ($acls[0][0], 'fourth', ' and the first member is correct'); +is ($acls[0][1], 'third', ' and the second member is correct'); + +# Add the same line to both ACLs. They should still show up as duplicate. +is ($server->acl_add ('fourth', 'base', 'bar'), 1, + 'Adding a line to the fourth ACL works'); +is ($server->acl_add ('third', 'base', 'bar'), 1, + ' and adding a line to the third ACL works'); +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); +is (scalar (@{ $acls[0] }), 2, ' with two members'); +is ($acls[0][0], 'fourth', ' and the first member is correct'); +is ($acls[0][1], 'third', ' and the second member is correct'); + +# Add another line to the third ACL. Now we match second. +is ($server->acl_add ('third', 'base', 'foo'), 1, + 'Adding another line to the third ACL works'); +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); +is (scalar (@{ $acls[0] }), 2, ' with two members'); +is ($acls[0][0], 'second', ' and the first member is correct'); +is ($acls[0][1], 'third', ' and the second member is correct'); + +# Add yet another line to the third ACL. Now all ACLs are distinct. +is ($server->acl_add ('third', 'base', 'baz'), 1, + 'Adding another line to the third ACL works'); +@acls = $report->acls ('duplicate'); +is (scalar (@acls), 0, 'There are no duplicate ACLs'); +is ($report->error, undef, ' and no error'); + +# Clean up. +$admin->destroy; +system ('rm -r test-files') == 0 or die "cannot remove test-files\n"; +END { + unlink 'wallet-db'; +} diff --git a/perl/t/general/server.t b/perl/t/general/server.t new file mode 100755 index 0000000..9026439 --- /dev/null +++ b/perl/t/general/server.t @@ -0,0 +1,1040 @@ +#!/usr/bin/perl -w +# +# Tests for the wallet server API. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2010, 2011, 2012, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 382; + +use POSIX qw(strftime); +use Wallet::Admin; +use Wallet::Config; +use Wallet::Schema; +use Wallet::Server; + +use lib 't/lib'; +use Util; + +# Some global defaults to use. +my $admin = 'admin@EXAMPLE.COM'; +my $user1 = 'alice@EXAMPLE.COM'; +my $user2 = 'bob@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($admin, $host); + +# Use Wallet::Admin to set up the database. +db_setup; +my $setup = eval { Wallet::Admin->new }; +is ($@, '', 'Database initialization did not die'); +is ($setup->reinitialize ($admin), 1, 'Database initialization succeeded'); + +# Now test the new method. +$server = eval { Wallet::Server->new (@trace) }; +is ($@, '', 'Reopening with new did not die'); +ok ($server->isa ('Wallet::Server'), ' and returned the right class'); +my $schema = $server->schema; +ok (defined ($schema), ' and returns a defined schema object'); + +# Allow creation of base objects for testing purposes. +$setup->register_object ('base', 'Wallet::Object::Base'); + +# We're currently running as the administrator, so everything should succeed. +# Set up a bunch of data for us to test with, starting with some ACLs. Test +# the error handling while we're at it. +is ($server->acl_show ('ADMIN'), + "Members of ACL ADMIN (id: 1) are:\n krb5 $admin\n", + 'Showing the ADMIN ACL works'); +is ($server->acl_show (1), + "Members of ACL ADMIN (id: 1) are:\n krb5 $admin\n", + ' including by number'); +my $history = <<"EOO"; +DATE create + by $admin from $host +DATE add krb5 $admin + by $admin from $host +EOO +my $result = $server->acl_history ('ADMIN'); +$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($result, $history, ' and displaying history works'); +$result = $server->acl_history (1); +$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($result, $history, ' including by number'); +is ($server->acl_create (3), undef, 'Cannot create ACL with a numeric name'); +is ($server->error, 'ACL name may not be all numbers', + ' and returns the right error'); +is ($server->acl_check ('user1'), 0, 'user1 ACL does not exist'); +is ($server->acl_create ('user1'), 1, 'Can create regular ACL'); +is ($server->acl_check ('user1'), 1, 'user1 now exists'); +is ($server->acl_show ('user1'), "Members of ACL user1 (id: 2) are:\n", + ' and show works'); +is ($server->acl_create ('user1'), undef, ' but not twice'); +like ($server->error, qr/^cannot create ACL user1: /, + ' and returns a good error'); +is ($server->acl_create ('ADMIN'), undef, ' and cannot create ADMIN'); +like ($server->error, qr/^cannot create ACL ADMIN: /, + ' and returns a good error'); +is ($server->acl_create ('user2'), 1, 'Create another ACL'); +is ($server->acl_create ('both'), 1, ' and one for both users'); +is ($server->acl_create ('test2'), 1, ' and an empty one'); +is ($server->acl_create ('test'), 1, ' and another test one'); +is ($server->acl_rename ('empty', 'test'), undef, + 'Cannot rename nonexistent ACL'); +is ($server->error, 'ACL empty not found', ' and returns the right error'); +is ($server->acl_rename ('test', 'test2'), undef, + ' and cannot rename to an existing name'); +like ($server->error, qr/^cannot rename ACL 6 to test2: /, + ' and returns the right error'); +is ($server->acl_rename ('test', 'empty'), 1, 'Renaming does work'); +is ($server->acl_rename ('test', 'empty'), undef, ' but not twice'); +is ($server->error, 'ACL test not found', ' and returns the right error'); +is ($server->acl_show ('test'), undef, ' and show fails'); +is ($server->error, 'ACL test not found', ' and returns the right error'); +is ($server->acl_history ('test'), undef, ' and history fails'); +is ($server->error, 'ACL test not found', ' and returns the right error'); +is ($server->acl_destroy ('test'), undef, 'Destroying the old name fails'); +is ($server->error, 'ACL test not found', ' and returns the right error'); +is ($server->acl_check ('test2'), 1, ' but the other ACL exists'); +is ($server->acl_destroy ('test2'), 1, ' and destroying it works'); +is ($server->acl_destroy ('test2'), undef, ' but not twice'); +is ($server->acl_check ('test2'), 0, ' and now it does not exist'); +is ($server->error, 'ACL test2 not found', ' and returns the right error'); +is ($server->acl_add ('user1', 'krb4', $user1), undef, + 'Adding with a bad scheme fails'); +is ($server->error, 'unknown ACL scheme krb4', ' with the right error'); +is ($server->acl_add ('user1', 'krb5', $user1), 1, + ' but works with the right scheme'); +is ($server->acl_add ('user2', 'krb5', $user2), 1, 'Add another entry'); +is ($server->acl_add ('both', 'krb5', $user1), 1, ' and another'); +is ($server->acl_add ('both', 'krb5', $user2), 1, + ' and another to the same ACL'); +is ($server->acl_show ('both'), + "Members of ACL both (id: 4) are:\n krb5 $user1\n krb5 $user2\n", + ' and show returns the correct result'); +$history = <<"EOO"; +DATE create + by $admin from $host +DATE add krb5 $user1 + by $admin from $host +DATE add krb5 $user2 + by $admin from $host +EOO +$result = $server->acl_history ('both'); +$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($result, $history, ' as does history'); +is ($server->acl_add ('empty', 'krb5', $user1), 1, ' and another to empty'); +is ($server->acl_add ('test', 'krb5', $user1), undef, + ' but adding to an unknown ACL fails'); +is ($server->error, 'ACL test not found', ' and returns the right error'); +is ($server->acl_remove ('test', 'krb5', $user1), undef, + 'Removing from a nonexistent ACL fails'); +is ($server->error, 'ACL test not found', ' and returns the right error'); +is ($server->acl_remove ('empty', 'krb5', $user2), undef, + ' and removing an entry not there fails'); +is ($server->error, + "cannot remove krb5:$user2 from 6: entry not found in ACL", + ' and returns the right error'); +is ($server->acl_show ('empty'), + "Members of ACL empty (id: 6) are:\n krb5 $user1\n", + ' and show returns the correct status'); +is ($server->acl_remove ('empty', 'krb5', $user1), 1, + ' but removing a good one works'); +is ($server->acl_remove ('empty', 'krb5', $user1), undef, + ' but does not work twice'); +is ($server->error, + "cannot remove krb5:$user1 from 6: entry not found in ACL", + ' and returns the right error'); +is ($server->acl_show ('empty'), "Members of ACL empty (id: 6) are:\n", + ' and show returns the correct status'); + +# Make sure we can't cripple the ADMIN ACL. +is ($server->acl_destroy ('ADMIN'), undef, 'Cannot destroy the ADMIN ACL'); +is ($server->error, 'cannot destroy the ADMIN ACL', ' with the right error'); +is ($server->acl_rename ('ADMIN', 'foo'), undef, ' or rename it'); +is ($server->error, 'cannot rename the ADMIN ACL', ' with the right error'); +is ($server->acl_remove ('ADMIN', 'krb5', $admin), undef, + ' or remove its last entry'); +is ($server->error, 'cannot remove last ADMIN ACL entry', + ' with the right error'); +is ($server->acl_add ('ADMIN', 'krb5', $user1), 1, + ' but we can add another entry'); +is ($server->acl_remove ('ADMIN', 'krb5', $user1), 1, ' and then remove it'); +is ($server->acl_remove ('ADMIN', 'krb5', $user1), undef, + ' and remove a user not on it'); +is ($server->error, + "cannot remove krb5:$user1 from 1: entry not found in ACL", + ' and get the right error'); + +# Now, create a few objects to use for testing and test the object API while +# we're at it. +is ($server->create ('base', 'service/admin'), 1, + 'Creating an object works'); +is ($server->create ('base', 'service/admin'), undef, ' but not twice'); +like ($server->error, qr{^cannot create object base:service/admin: }, + ' and returns the right error'); +is ($server->check ('base', 'service/admin'), 1, ' and check works'); +is ($server->create ('srvtab', 'service.admin'), undef, + 'Creating an unknown object fails'); +is ($server->error, 'unknown object type srvtab', ' with the right error'); +is ($server->check ('srvtab', 'service.admin'), undef, ' and check fails'); +is ($server->error, 'unknown object type srvtab', ' with the right error'); +is ($server->create ('', 'service.admin'), undef, + ' and likewise with an empty type'); +is ($server->error, 'unknown object type ', ' with the right error'); +is ($server->create ('base', 'service/user1'), 1, + ' but we can create a base object'); +is ($server->create ('base', 'service/user2'), 1, ' and another'); +is ($server->create ('base', 'service/both'), 1, ' and another'); +is ($server->create ('base', 'service/test'), 1, ' and another'); +is ($server->create ('base', ''), undef, ' but not with an empty name'); +is ($server->error, 'invalid object name', ' with the right error'); +is ($server->destroy ('base', 'service/none'), undef, + 'Destroying an unknown object fails'); +is ($server->error, 'cannot find base:service/none', ' with the right error'); +is ($server->destroy ('srvtab', 'service/test'), undef, + ' and destroying an unknown type fails'); +is ($server->error, 'unknown object type srvtab', ' with a different error'); +is ($server->destroy ('base', 'service/test'), 1, + ' but destroying a good object works'); +is ($server->check ('base', 'service/test'), 0, + ' and now check says it is not there'); +is ($server->destroy ('base', 'service/test'), undef, ' but not twice'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); + +# Test manipulating comments. +is ($server->comment ('base', 'service/test'), undef, + 'Retrieving comment on an unknown object fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->comment ('base', 'service/test', 'this is a comment'), undef, + ' and setting it also fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->comment ('base', 'service/admin'), undef, + 'Retrieving comment for the right object returns undef'); +is ($server->error, undef, ' but there is no error'); +is ($server->comment ('base', 'service/admin', 'this is a comment'), 1, + ' and we can set it'); +is ($server->comment ('base', 'service/admin'), 'this is a comment', + ' and get the value back'); +is ($server->comment ('base', 'service/admin', ''), 1, ' and clear it'); +is ($server->comment ('base', 'service/admin'), undef, ' and now it is gone'); +is ($server->error, undef, ' and still no error'); + +# Test manipulating expires. +my $now = strftime ('%Y-%m-%d %T', localtime time); +is ($server->expires ('base', 'service/test'), undef, + 'Retrieving expires on an unknown object fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->expires ('base', 'service/test', $now), undef, + ' and setting it also fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->expires ('base', 'service/admin'), undef, + 'Retrieving expires for the right object returns undef'); +is ($server->error, undef, ' but there is no error'); +is ($server->expires ('base', 'service/admin', $now), 1, + ' and we can set it'); +is ($server->expires ('base', 'service/admin'), $now, + ' and get the value back'); +is ($server->expires ('base', 'service/admin', ''), 1, ' and clear it'); +is ($server->expires ('base', 'service/admin'), undef, ' and now it is gone'); +is ($server->error, undef, ' and still no error'); + +# Test attributes. +is ($server->attr ('base', 'service/admin', 'foo'), undef, + 'Getting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but called the method'); +is ($server->attr ('base', 'service/admin', 'foo', 'foo'), undef, + ' and setting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' and called the method'); + +# Because we're admin, we should be able to show one of these objects, but we +# still shouldn't be able to get or store since there are no ACLs. +is ($server->show ('base', 'service/test'), undef, + 'Cannot show nonexistent object'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +my $show = $server->show ('base', 'service/admin'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/; +my $expected = <<"EOO"; + Type: base + Name: service/admin + Created by: $admin + Created from: $host + Created on: 0 +EOO +is ($show, $expected, ' but showing an existing object works'); +is ($server->get ('base', 'service/admin'), undef, 'Getting an object fails'); +is ($server->error, "$admin not authorized to get base:service/admin", + ' with the right error'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and storing the object also fails'); +is ($server->error, "$admin not authorized to store base:service/admin", + ' with the right error'); + +# Grant only the get ACL, which should give us partial permissions. +is ($server->acl ('base', 'service/test', 'get', 'ADMIN'), undef, + 'Setting ACL on unknown object fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->acl ('base', 'service/admin', 'foo', 'ADMIN'), undef, + ' as does setting an unknown ACL'); +is ($server->error, 'invalid ACL type foo', ' with the right error'); +is ($server->acl ('base', 'service/admin', 'get', 'test2'), undef, + ' as does setting it to an unknown ACL'); +is ($server->error, 'ACL test2 not found', ' with the right error'); +is ($server->acl ('base', 'service/admin', 'get', 'ADMIN'), 1, + ' but setting the right ACL works'); +$result = eval { $server->get ('base', 'service/admin') }; +is ($result, undef, 'Get still fails'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' but the method is called'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and storing the object still fails'); +is ($server->error, "$admin not authorized to store base:service/admin", + ' with the right error'); +is ($server->acl ('base', 'service/admin', 'get', ''), 1, + 'Clearing the ACL works'); +is ($server->get ('base', 'service/admin'), undef, ' and now get fails'); +is ($server->error, "$admin not authorized to get base:service/admin", + ' with the right error'); +is ($server->acl ('base', 'service/admin', 'store', 'ADMIN'), 1, + 'Setting the store ACL works'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and now store fails'); +is ($server->error, + "cannot store base:service/admin: object type is immutable", + ' with a different error message'); +is ($server->get ('base', 'service/admin'), undef, ' and get still fails'); +is ($server->error, "$admin not authorized to get base:service/admin", + ' with the right error'); +is ($server->acl ('base', 'service/admin', 'store', ''), 1, + 'Clearing the ACL works'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and storing the object now fails'); +is ($server->error, "$admin not authorized to store base:service/admin", + ' with the right error'); + +# Test manipulating the owner. +is ($server->owner ('base', 'service/test'), undef, + 'Owner of nonexistent object fails'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->owner ('base', 'service/test', 'ADMIN'), undef, + ' as does setting it'); +is ($server->error, 'cannot find base:service/test', ' with the right error'); +is ($server->owner ('base', 'service/admin'), undef, + 'Owner of existing object is also undef'); +is ($server->error, undef, ' but there is no error'); +is ($server->owner ('base', 'service/admin', 'test2'), undef, + 'Setting it to an unknown ACL fails'); +is ($server->error, 'ACL test2 not found', ' with the right error'); +is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, + 'Setting it to ADMIN works'); +$result = eval { $server->get ('base', 'service/admin') }; +is ($result, undef, ' and get still fails'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' but the method is called'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and now store fails'); +is ($server->error, + "cannot store base:service/admin: object type is immutable", + ' with a different error message'); +is ($server->acl ('base', 'service/admin', 'get', 'empty'), 1, + 'Setting the get ACL succeeds'); +is ($server->get ('base', 'service/admin'), undef, ' and get now fails'); +is ($server->error, "$admin not authorized to get base:service/admin", + ' with the right error'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' but store fails'); +is ($server->error, + "cannot store base:service/admin: object type is immutable", + ' with the same error message'); +is ($server->acl ('base', 'service/admin', 'store', 'empty'), 1, + ' until we do the same thing with store'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and now store fails'); +is ($server->error, "$admin not authorized to store base:service/admin", + ' due to permissions'); +is ($server->acl ('base', 'service/admin', 'store', ''), 1, + 'Clearing the store ACL works'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and fixes that'); +is ($server->error, + "cannot store base:service/admin: object type is immutable", + ' since we are back to immutable'); +is ($server->owner ('base', 'service/admin', ''), 1, + ' but clearing the owner works'); +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' and now store fails'); +is ($server->error, "$admin not authorized to store base:service/admin", + ' due to permissions again'); +is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, + ' and setting the owner again works'); + +# Test manipulating flags. +is ($server->flag_clear ('base', 'service/admin', 'locked'), undef, + 'Clearing an unset flag fails'); +is ($server->error, + "cannot clear flag locked on base:service/admin: flag not set", + ' with the right error'); +if ($server->flag_set ('base', 'service/admin', 'locked')) { + ok (1, ' but setting it works'); +} else { + is ($server->error, '', ' but setting it works'); +} +is ($server->store ('base', 'service/admin', 'stuff'), undef, + ' now store fails'); +is ($server->error, 'cannot store base:service/admin: object is locked', + ' because the object is locked'); +is ($server->expires ('base', 'service/admin', ''), undef, + ' and expires fails'); +is ($server->error, 'cannot modify base:service/admin: object is locked', + ' because the object is locked'); +is ($server->owner ('base', 'service/admin', ''), undef, ' and owner fails'); +is ($server->error, 'cannot modify base:service/admin: object is locked', + ' because the object is locked'); +for my $acl (qw/get store show destroy flags/) { + is ($server->acl ('base', 'service/admin', $acl, ''), undef, + " and setting $acl ACL fails"); + is ($server->error, 'cannot modify base:service/admin: object is locked', + ' for the same reason'); +} +is ($server->flag_clear ('base', 'service/admin', 'locked'), 1, + ' and then clearing it works'); +is ($server->owner ('base', 'service/admin', ''), 1, + ' and then clearing owner works'); +is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, + ' and setting unchanging works'); +is ($server->flag_clear ('base', 'service/admin', 'locked'), undef, + ' and clearing locked still does not'); +is ($server->error, + "cannot clear flag locked on base:service/admin: flag not set", + ' with the right error'); +is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, + ' and clearing unchanging works'); + +# Test history. +$history = <<"EOO"; +DATE create + by $admin from $host +DATE set comment to this is a comment + by $admin from $host +DATE unset comment (was this is a comment) + by $admin from $host +DATE set expires to $now + by $admin from $host +DATE unset expires (was $now) + by $admin from $host +DATE set acl_get to ADMIN (1) + by $admin from $host +DATE unset acl_get (was ADMIN (1)) + by $admin from $host +DATE set acl_store to ADMIN (1) + by $admin from $host +DATE unset acl_store (was ADMIN (1)) + by $admin from $host +DATE set owner to ADMIN (1) + by $admin from $host +DATE set acl_get to empty (6) + by $admin from $host +DATE set acl_store to empty (6) + by $admin from $host +DATE unset acl_store (was empty (6)) + by $admin from $host +DATE unset owner (was ADMIN (1)) + by $admin from $host +DATE set owner to ADMIN (1) + by $admin from $host +DATE set flag locked + by $admin from $host +DATE clear flag locked + by $admin from $host +DATE unset owner (was ADMIN (1)) + by $admin from $host +DATE set flag unchanging + by $admin from $host +DATE clear flag unchanging + by $admin from $host +EOO +my $seen = $server->history ('base', 'service/admin'); +$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($seen, $history, 'History for service/admin is correct'); + +# Now let's set up some additional ACLs for future tests. +is ($server->owner ('base', 'service/user1', 'user1'), 1, 'Set user1 owner'); +is ($server->owner ('base', 'service/user2', 'user2'), 1, 'Set user2 owner'); +is ($server->owner ('base', 'service/both', 'both'), 1, 'Set both owner'); +is ($server->acl ('base', 'service/both', 'show', 'user1'), 1, ' and show'); +is ($server->acl ('base', 'service/both', 'destroy', 'user2'), 1, + ' and destroy'); +is ($server->acl ('base', 'service/both', 'flags', 'user1'), 1, ' and flags'); +is ($server->acl ('base', 'service/admin', 'store', 'user1'), 1, + 'Set admin store'); + +# Okay, now we can switch users and be sure we don't have admin rights. +$server = eval { Wallet::Server->new ($user1, $host) }; +is ($@, '', 'Switching users works'); +is ($server->acl_create ('new'), undef, ' and now we cannot create ACLs'); +is ($server->error, "$user1 not authorized to create ACL", ' with error'); +is ($server->acl_rename ('user1', 'alice'), undef, ' or rename ACLs'); +is ($server->error, "$user1 not authorized to rename ACL user1", + ' with error'); +is ($server->acl_show ('user1'), undef, ' or show ACLs'); +is ($server->error, "$user1 not authorized to show ACL user1", ' with error'); +is ($server->acl_history ('user1'), undef, ' or see history for ACLs'); +is ($server->error, "$user1 not authorized to see history of ACL user1", + ' with error'); +is ($server->acl_destroy ('user2'), undef, ' or destroy ACLs'); +is ($server->error, "$user1 not authorized to destroy ACL user2", + ' with error'); +is ($server->acl_add ('user1', 'krb5', $user2), undef, ' or add to ACLs'); +is ($server->error, "$user1 not authorized to add to ACL user1", + ' with error'); +is ($server->acl_remove ('user1', 'krb5', $user1), undef, + ' or remove from ACLs'); +is ($server->error, "$user1 not authorized to remove from ACL user1", + ' with error'); +is ($server->create ('base', 'service/test'), undef, + ' nor can we create objects'); +is ($server->error, "$user1 not authorized to create base:service/test", + ' with error'); +is ($server->owner ('base', 'service/user1', 'user2'), undef, + ' or set the owner'); +is ($server->error, + "$user1 not authorized to set owner for base:service/user1", + ' with error'); +is ($server->expires ('base', 'service/user1', $now), undef, + ' or set expires'); +is ($server->error, + "$user1 not authorized to set expires for base:service/user1", + ' with error'); +is ($server->acl ('base', 'service/user1', 'get', 'user1'), undef, + ' or set an ACL'); +is ($server->error, + "$user1 not authorized to set ACL for base:service/user1", + ' with error'); +is ($server->flag_set ('base', 'service/user1', 'unchanging'), undef, + ' or set flags'); +is ($server->error, + "$user1 not authorized to set flags for base:service/user1", + ' with error'); +is ($server->flag_clear ('base', 'service/user1', 'unchanging'), undef, + ' or clear flags'); +is ($server->error, + "$user1 not authorized to set flags for base:service/user1", + ' with error'); + +# However, we can perform object actions on things we own. +$result = eval { $server->get ('base', 'service/user1') }; +is ($result, undef, 'We can get an object we own'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' and the method is called'); +is ($server->store ('base', 'service/user1', 'stuff'), undef, + ' or store an object we own'); +is ($server->error, + "cannot store base:service/user1: object type is immutable", + ' and the method is called'); +is ($server->comment ('base', 'service/user1', 'this is a comment'), 1, + ' and set a comment'); +$show = $server->show ('base', 'service/user1'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; +$expected = <<"EOO"; + Type: base + Name: service/user1 + Owner: user1 + Comment: this is a comment + Created by: $admin + Created from: $host + Created on: 0 + +Members of ACL user1 (id: 2) are: + krb5 $user1 +EOO +is ($show, $expected, ' and show an object we own'); +$history = <<"EOO"; +DATE create + by $admin from $host +DATE set owner to user1 (2) + by $admin from $host +DATE set comment to this is a comment + by $user1 from $host +EOO +$seen = $server->history ('base', 'service/user1'); +$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($seen, $history, ' and see history for an object we own'); +is ($server->attr ('base', 'service/user1', 'foo'), undef, + ' and getting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but calls the method'); +is ($server->attr ('base', 'service/user1', 'foo', 'foo'), undef, + ' and setting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but calls the method'); + +# But not on things we don't own. +is ($server->get ('base', 'service/user2'), undef, + 'But we cannot get an object we do not own'); +is ($server->error, "$user1 not authorized to get base:service/user2", + ' with the right error'); +is ($server->store ('base', 'service/user2', 'stuff'), undef, + ' or store it'); +is ($server->error, "$user1 not authorized to store base:service/user2", + ' with the right error'); +is ($server->show ('base', 'service/user2'), undef, ' or show it'); +is ($server->error, "$user1 not authorized to show base:service/user2", + ' with the right error'); +is ($server->history ('base', 'service/user2'), undef, + ' or see history for it'); +is ($server->error, "$user1 not authorized to show base:service/user2", + ' with the right error'); +is ($server->attr ('base', 'service/user2', 'foo'), undef, + ' or get attributes'); +is ($server->error, + "$user1 not authorized to get attributes for base:service/user2", + ' with the right error'); +is ($server->attr ('base', 'service/user2', 'foo', ''), undef, + ' and set attributes'); +is ($server->error, + "$user1 not authorized to set attributes for base:service/user2", + ' with the right error'); +is ($server->comment ('base', 'service/user2', 'this is a comment'), undef, + ' and set comment'); +is ($server->error, + "$user1 not authorized to set comment for base:service/user2", + ' with the right error'); + +# And only some things on an object we own with some ACLs. +$result = eval { $server->get ('base', 'service/both') }; +is ($result, undef, 'We can get an object we jointly own'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' and the method is called'); +is ($server->store ('base', 'service/both', 'stuff'), undef, + ' or store an object we jointly own'); +is ($server->error, + "cannot store base:service/both: object type is immutable", + ' and the method is called'); +is ($server->flag_set ('base', 'service/both', 'unchanging'), 1, + ' and set flags on an object we have an ACL'); +is ($server->flag_set ('base', 'service/both', 'locked'), 1, ' both flags'); +$show = $server->show ('base', 'service/both'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; +$expected = <<"EOO"; + Type: base + Name: service/both + Owner: both + Show ACL: user1 + Destroy ACL: user2 + Flags ACL: user1 + Flags: locked unchanging + Created by: $admin + Created from: $host + Created on: 0 + +Members of ACL both (id: 4) are: + krb5 $user1 + krb5 $user2 + +Members of ACL user1 (id: 2) are: + krb5 $user1 + +Members of ACL user2 (id: 3) are: + krb5 $user2 +EOO +is ($show, $expected, ' and show an object we jointly own'); +$history = <<"EOO"; +DATE create + by $admin from $host +DATE set owner to both (4) + by $admin from $host +DATE set acl_show to user1 (2) + by $admin from $host +DATE set acl_destroy to user2 (3) + by $admin from $host +DATE set acl_flags to user1 (2) + by $admin from $host +DATE set flag unchanging + by $user1 from $host +DATE set flag locked + by $user1 from $host +EOO +$seen = $server->history ('base', 'service/both'); +$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($seen, $history, ' and see history for an object we jointly own'); +is ($server->store ('base', 'service/both', 'stuff'), undef, + ' but not store data'); +is ($server->error, 'cannot store base:service/both: object is locked', + ' when the object is locked'); +is ($server->flag_clear ('base', 'service/both', 'locked'), 1, + ' and clear flags'); +is ($server->destroy ('base', 'service/both'), undef, + ' but not destroy it'); +is ($server->error, "$user1 not authorized to destroy base:service/both", + ' due to permissions'); +is ($server->attr ('base', 'service/both', 'foo'), undef, + 'Getting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but calls the method'); +is ($server->attr ('base', 'service/both', 'foo', ''), undef, + ' and setting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but calls the method'); +is ($server->attr ('base', 'service/admin', 'foo', ''), undef, + ' but setting an attribute on service/admin fails'); +is ($server->error, 'unknown attribute foo', ' and calls the method'); +is ($server->attr ('base', 'service/admin', 'foo'), undef, + ' while getting an attribute on service/admin fails'); +is ($server->error, + "$user1 not authorized to get attributes for base:service/admin", + ' with a permission error'); + +# Now switch to the other user and make sure we can do things on objects we +# own. +$server = eval { Wallet::Server->new ($user2, $host) }; +is ($@, '', 'Switching users works'); +$result = eval { $server->get ('base', 'service/user2') }; +is ($result, undef, 'We can get an object we own'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' and the method is called'); +is ($server->store ('base', 'service/user2', 'stuff'), undef, + ' or store an object we own'); +is ($server->error, + "cannot store base:service/user2: object type is immutable", + ' and the method is called'); +$show = $server->show ('base', 'service/user2'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; +$expected = <<"EOO"; + Type: base + Name: service/user2 + Owner: user2 + Created by: $admin + Created from: $host + Created on: 0 + +Members of ACL user2 (id: 3) are: + krb5 $user2 +EOO +is ($show, $expected, ' and show an object we own'); +$history = <<"EOO"; +DATE create + by $admin from $host +DATE set owner to user2 (3) + by $admin from $host +EOO +$seen = $server->history ('base', 'service/user2'); +$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; +is ($seen, $history, ' and see history for an object we own'); + +# But not on things we don't own. +is ($server->get ('base', 'service/user1'), undef, + 'But we cannot get an object we do not own'); +is ($server->error, "$user2 not authorized to get base:service/user1", + ' with the right error'); +is ($server->store ('base', 'service/user1', 'stuff'), undef, + ' or store it'); +is ($server->error, "$user2 not authorized to store base:service/user1", + ' with the right error'); +is ($server->show ('base', 'service/user1'), undef, ' or show it'); +is ($server->error, "$user2 not authorized to show base:service/user1", + ' with the right error'); +is ($server->history ('base', 'service/user1'), undef, + ' or see history for it'); +is ($server->error, "$user2 not authorized to show base:service/user1", + ' with the right error'); +is ($server->comment ('base', 'service/user1', 'this is a comment'), undef, + ' or set a comment for it'); +is ($server->error, + "$user2 not authorized to set comment for base:service/user1", + ' with the right error'); + +# Test that setting a comment is controlled by the owner but retrieving it is +# controlled by the show ACL. +$result = eval { $server->get ('base', 'service/both') }; +is ($result, undef, 'We can get an object we jointly own'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' and the method is called'); +is ($server->comment ('base', 'service/both', 'this is a comment'), 1, + ' and can set a comment on it'); +is ($server->error, undef, ' with no error'); +is ($server->comment ('base', 'service/both'), undef, + ' but cannot see the comment on it'); +is ($server->error, "$user2 not authorized to show base:service/both", + ' with the right error'); + +# And can only do some things on an object we own with some ACLs. +$result = eval { $server->get ('base', 'service/both') }; +is ($result, undef, 'We can get an object we jointly own'); +is ($@, "Do not instantiate Wallet::Object::Base directly\n", + ' and the method is called'); +is ($server->store ('base', 'service/both', 'stuff'), undef, + ' or store an object we jointly own'); +is ($server->error, + "cannot store base:service/both: object type is immutable", + ' and the method is called'); +is ($server->show ('base', 'service/both'), undef, ' but we cannot show it'); +is ($server->error, "$user2 not authorized to show base:service/both", + ' with the right error'); +is ($server->history ('base', 'service/both'), undef, + ' or see history for it'); +is ($server->error, "$user2 not authorized to show base:service/both", + ' with the right error'); +is ($server->flag_set ('base', 'service/both', 'locked'), undef, + ' or set flags on it'); +is ($server->error, + "$user2 not authorized to set flags for base:service/both", + ' with the right error'); +is ($server->flag_clear ('base', 'service/both', 'unchanging'), undef, + ' or clear flags on it'); +is ($server->error, + "$user2 not authorized to set flags for base:service/both", + ' with the right error'); +is ($server->attr ('base', 'service/both', 'foo'), undef, + ' or getting an attribute'); +is ($server->error, + "$user2 not authorized to get attributes for base:service/both", + ' with the right error'); +is ($server->attr ('base', 'service/both', 'foo', 'foo'), undef, + ' but setting an attribute fails'); +is ($server->error, 'unknown attribute foo', ' but calls the method'); +is ($server->destroy ('base', 'service/both'), 1, ' and we can destroy it'); +is ($server->get ('base', 'service/both'), undef, ' and now cannot get it'); +is ($server->error, 'cannot find base:service/both', ' because it is gone'); +is ($server->store ('base', 'service/both', 'stuff'), undef, + ' or store it'); +is ($server->error, 'cannot find base:service/both', ' because it is gone'); + +# Switch back to user1 and test destroy. +$server = eval { Wallet::Server->new ($user1, $host) }; +is ($@, '', 'Switching users works'); +is ($server->destroy ('base', 'service/user1'), 1, + 'Destroy of an object we own with no destroy ACLs works'); + +# Test default ACLs on object creation. +# +# Create a default_acl sub that permits $user2 to create service/default with +# a default owner of default (the same as the both ACL), $user1 to create +# service/default-both with a default owner of both (but a different +# definition than the existing ACL), and $user2 to create service/default-2 +# with a default owner of user2 (with the same definition as the existing +# ACL). +# +# Also add service/default-get and service/default-store to test auto-creation +# on get and store, and service/default-admin to test auto-creation when one +# is an admin. +package Wallet::Config; +sub default_owner { + my ($type, $name) = @_; + if ($type eq 'base' and $name eq 'service/default') { + return ('default', [ 'krb5', $user1 ], [ 'krb5', $user2 ]); + } elsif ($type eq 'base' and $name eq 'service/default-both') { + return ('both', [ 'krb5', $user1 ]); + } elsif ($type eq 'base' and $name eq 'service/default-2') { + return ('user2', [ 'krb5', $user2 ]); + } elsif ($type eq 'base' and $name eq 'service/default-get') { + return ('user2', [ 'krb5', $user2 ]); + } elsif ($type eq 'base' and $name eq 'service/default-store') { + return ('user2', [ 'krb5', $user2 ]); + } elsif ($type eq 'base' and $name eq 'service/default-admin') { + return ('auto-admin', [ 'krb5', $admin ]); + } elsif ($type eq 'base' and $name eq 'host/default') { + return ('auto-host', [ 'krb5', $admin ]); + } else { + return; + } +} +package main; + +# Switch back to user2, so we should now be able to create service/default. +# Make sure we can and that the ACLs all look good. +$server = eval { Wallet::Server->new ($user2, $host) }; +is ($@, '', 'Switching users works'); +is ($server->create ('base', 'service/default'), undef, + 'Creating an object with the default ACL fails'); +is ($server->error, "$user2 not authorized to create base:service/default", + ' due to lack of authorization'); +is ($server->autocreate ('base', 'service/default'), 1, + ' but autocreation succeeds'); +is ($server->autocreate ('base', 'service/foo'), undef, + ' but not any object'); +is ($server->error, "$user2 not authorized to create base:service/foo", + ' with the right error'); +$show = $server->show ('base', 'service/default'); +if (defined $show) { + $show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; + $expected = <<"EOO"; + Type: base + Name: service/default + Owner: default + Created by: $user2 + Created from: $host + Created on: 0 + +Members of ACL default (id: 7) are: + krb5 $user1 + krb5 $user2 +EOO + is ($show, $expected, ' and the created object and ACL are correct'); +} else { + is ($server->error, undef, ' and the created object and ACL are correct'); +} + +# Try the other basic cases in default_owner. +is ($server->autocreate ('base', 'service/default-both'), undef, + 'Creating an object with an ACL mismatch fails'); +is ($server->error, "ACL both exists and doesn't match default", + ' with the right error'); +is ($server->autocreate ('base', 'service/default-2'), 1, + 'Creating an object with an existing ACL works'); +$show = $server->show ('base', 'service/default-2'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; +$expected = <<"EOO"; + Type: base + Name: service/default-2 + Owner: user2 + Created by: $user2 + Created from: $host + Created on: 0 + +Members of ACL user2 (id: 3) are: + krb5 $user2 +EOO +is ($show, $expected, ' and the created object and ACL are correct'); + +# Auto-creation does not work on get or store; this is done by the client. +$result = eval { $server->get ('base', 'service/default-get') }; +is ($result, undef, 'Auto-creation on get fails'); +is ($@, '', ' does not die'); +is ($server->error, 'cannot find base:service/default-get', + ' and fails with the right error'); +is ($server->store ('base', 'service/default-store', 'stuff'), undef, + 'Auto-creation on store fails'); +is ($server->error, 'cannot find base:service/default-store', + ' with the right error'); + +# Switch back to admin to test auto-creation. +$server = eval { Wallet::Server->new ($admin, $host) }; +is ($@, '', 'Switching users back to admin works'); +is ($server->autocreate ('base', 'service/default-admin'), 1, + 'Autocreation works for admin'); +$show = $server->show ('base', 'service/default-admin'); +$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; +$expected = <<"EOO"; + Type: base + Name: service/default-admin + Owner: auto-admin + Created by: $admin + Created from: $host + Created on: 0 + +Members of ACL auto-admin (id: 8) are: + krb5 $admin +EOO +is ($show, $expected, ' and the created object and ACL are correct'); +is ($server->destroy ('base', 'service/default-admin'), 1, + ' and we can destroy it'); + +# Test naming enforcement. Permit any base service/* name, but only permit +# base host/* if the host is fully qualified and ends in .example.edu. +package Wallet::Config; +sub verify_name { + my ($type, $name) = @_; + if ($type eq 'base' and $name =~ m,^service/,) { + return; + } elsif ($type eq 'base' and $name =~ m,^host/(.*),) { + my $host = $1; + return "host $host must be fully qualified (add .example.edu)" + unless $host =~ /\./; + return "host $host not in .example.edu domain" + unless $host =~ /\.example\.edu$/; + return; + } else { + return; + } +} +package main; + +# Recreate service/default-admin, which should succeed, and then try the +# various host/* principals. +is ($server->create ('base', 'service/default-admin'), 1, + 'Creating default/admin succeeds'); +if ($server->create ('base', 'host/default.example.edu')) { + ok (1, ' as does creating host/default.example.edu'); +} else { + is ($server->error, '', ' as does creating host/default.example.edu'); +} +is ($server->destroy ('base', 'service/default-admin'), 1, + ' and destroying default-admin works'); +is ($server->destroy ('base', 'host/default.example.edu'), 1, + ' and destroying host/default.example.edu works'); +is ($server->create ('base', 'host/default'), undef, + ' but an unqualified host fails'); +is ($server->error, 'base:host/default rejected: host default must be fully' + . ' qualified (add .example.edu)', ' with the right error'); +is ($server->create ('base', 'host/default.stanford.edu'), undef, + ' and a host in the wrong domain fails'); +is ($server->error, 'base:host/default.stanford.edu rejected: host' + . ' default.stanford.edu not in .example.edu domain', + ' with the right error'); +is ($server->autocreate ('base', 'service/default-admin'), 1, + 'Creating default/admin succeeds'); +is ($server->autocreate ('base', 'host/default'), undef, + ' but an unqualified host fails'); +is ($server->error, 'base:host/default rejected: host default must be fully' + . ' qualified (add .example.edu)', ' with the right error'); +is ($server->acl_show ('auto-host'), undef, ' and the ACL is not present'); +is ($server->error, 'ACL auto-host not found', ' with the right error'); +is ($server->autocreate ('base', 'host/default.stanford.edu'), undef, + ' and a host in the wrong domain fails'); +is ($server->error, 'base:host/default.stanford.edu rejected: host' + . ' default.stanford.edu not in .example.edu domain', + ' with the right error'); + +# Ensure that we can't destroy an ACL that's in use. +is ($server->acl_create ('test-destroy'), 1, 'Creating an ACL works'); +is ($server->create ('base', 'service/acl-user'), 1, 'Creating object works'); +is ($server->owner ('base', 'service/acl-user', 'test-destroy'), 1, + ' and setting owner'); +is ($server->acl_destroy ('test-destroy'), undef, + ' and now we cannot destroy that ACL'); +is ($server->error, + 'cannot destroy ACL 9: ACL in use by base:service/acl-user', + ' with the right error'); +is ($server->owner ('base', 'service/acl-user', ''), 1, + ' but after we clear the owner'); +is ($server->acl_destroy ('test-destroy'), 1, ' now we can destroy the ACL'); +is ($server->destroy ('base', 'service/acl-user'), 1, ' and the object'); + +# Test ACL naming enforcement. Require that ACL names not contain a slash. +package Wallet::Config; +sub verify_acl_name { + my ($name, $user) = @_; + return 'ACL names may not contain slash' if $name =~ m,/,; + return; +} +package main; +is ($server->acl_create ('test/naming'), undef, + 'Creating an ACL with a disallowed name fails'); +is ($server->error, 'test/naming rejected: ACL names may not contain slash', + ' with the right error message'); +is ($server->acl_create ('test-naming'), 1, + 'Creating test-naming succeeds'); +is ($server->acl_rename ('test-naming', 'test/naming'), undef, + ' but renaming it fails'); +is ($server->error, 'test/naming rejected: ACL names may not contain slash', + ' with the right error message'); +is ($server->acl_destroy ('test-naming'), 1, 'Destroying it succeeds'); + +# Clean up. +$setup->destroy; +END { + unlink 'wallet-db'; +} + +# Now test handling of some configuration errors. +undef $Wallet::Config::DB_DRIVER; +$server = eval { Wallet::Server->new ($user2, $host) }; +is ($@, "database connection information not configured\n", + 'Fail if DB_DRIVER is not set'); +$Wallet::Config::DB_DRIVER = 'SQLite'; +undef $Wallet::Config::DB_INFO; +$server = eval { Wallet::Server->new ($user2, $host) }; +is ($@, "database connection information not configured\n", + ' or if DB_INFO is not set'); +$Wallet::Config::DB_INFO = 't'; +$server = eval { Wallet::Server->new ($user2, $host) }; +like ($@, qr/unable to open database file/, + ' or if the database connection fails'); diff --git a/perl/t/init.t b/perl/t/init.t deleted file mode 100755 index b8ec3c9..0000000 --- a/perl/t/init.t +++ /dev/null @@ -1,58 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for database initialization. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 18; - -use Wallet::ACL; -use Wallet::Admin; - -use lib 't/lib'; -use Util; - -# Use Wallet::Admin to set up the database. -db_setup; -my $admin = eval { Wallet::Admin->new }; -is ($@, '', 'Wallet::Admin creation did not die'); -ok ($admin->isa ('Wallet::Admin'), ' and returned the right class'); -is ($admin->initialize ('admin@EXAMPLE.COM'), 1, - ' and initialization succeeds'); - -# Check whether the database entries that should be created were. -my $acl = eval { Wallet::ACL->new ('ADMIN', $admin->schema) }; -is ($@, '', 'Retrieving ADMIN ACL successful'); -ok ($acl->isa ('Wallet::ACL'), ' and is the right class'); -my @entries = $acl->list; -is (scalar (@entries), 1, ' and has only one entry'); -isnt ($entries[0], undef, ' which is a valid entry'); -is ($entries[0][0], 'krb5', ' of krb5 scheme'); -is ($entries[0][1], 'admin@EXAMPLE.COM', ' with the right user'); - -# Test reinitialization. -is ($admin->reinitialize ('admin@EXAMPLE.ORG'), 1, - 'Reinitialization succeeded'); - -# Now repeat the database content checks. -$acl = eval { Wallet::ACL->new ('ADMIN', $admin->schema) }; -is ($@, '', 'Retrieving ADMIN ACL successful'); -ok ($acl->isa ('Wallet::ACL'), ' and is the right class'); -@entries = $acl->list; -is (scalar (@entries), 1, ' and has only one entry'); -isnt ($entries[0], undef, ' which is a valid entry'); -is ($entries[0][0], 'krb5', ' of krb5 scheme'); -is ($entries[0][1], 'admin@EXAMPLE.ORG', ' with the right user'); - -# Test cleanup. -is ($admin->destroy, 1, 'Destroying the database works'); -$acl = eval { Wallet::ACL->new ('ADMIN', $admin->schema) }; -like ($@, qr/^cannot search for ACL ADMIN: /, - ' and now the database is gone'); -END { - unlink 'wallet-db'; -} diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t deleted file mode 100755 index 8eabc6b..0000000 --- a/perl/t/kadmin.t +++ /dev/null @@ -1,117 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the kadmin object implementation. -# -# Written by Jon Robertson -# Copyright 2009, 2010, 2012, 2013 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use POSIX qw(strftime); -use Test::More tests => 34; - -BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } - -use Wallet::Admin; -use Wallet::Config; -use Wallet::Kadmin; -use Wallet::Kadmin::MIT; - -# Only load Wallet::Kadmin::Heimdal if a required module is found. -my $heimdal_kadm5 = 0; -eval 'use Heimdal::Kadm5'; -if (!$@) { - $heimdal_kadm5 = 1; - require Wallet::Kadmin::Heimdal; -} - -use lib 't/lib'; -use Util; - -# Test creating an MIT object and seeing if the callback works. -$Wallet::Config::KEYTAB_KRBTYPE = 'MIT'; -my $kadmin = Wallet::Kadmin->new; -ok (defined ($kadmin), 'MIT kadmin object created'); -my $callback = sub { return 1 }; -$kadmin->fork_callback ($callback); -is ($kadmin->{fork_callback} (), 1, ' and callback works'); -$callback = sub { return 2 }; -$kadmin->fork_callback ($callback); -is ($kadmin->{fork_callback} (), 2, ' and changing it works'); - -# Check principal validation in the Wallet::Kadmin::MIT module. This is -# specific to that module, since Heimdal doesn't require passing the principal -# through the kadmin client. -for my $bad (qw{service\* = host/foo+bar host/foo/bar /bar bar/ rcmd.foo}) { - ok (! Wallet::Kadmin::MIT->valid_principal ($bad), - "Invalid principal name $bad"); -} -for my $good (qw{service service/foo bar foo/bar host/example.org - aservice/foo}) { - ok (Wallet::Kadmin::MIT->valid_principal ($good), - "Valid principal name $good"); -} - -# Test creating a Heimdal object. We deliberately connect without -# configuration to get the error. That tests that we can find the Heimdal -# module and it dies how it should. -SKIP: { - skip 'Heimdal::Kadm5 not installed', 2 unless $heimdal_kadm5; - undef $Wallet::Config::KEYTAB_PRINCIPAL; - undef $Wallet::Config::KEYTAB_FILE; - undef $Wallet::Config::KEYTAB_REALM; - undef $kadmin; - $Wallet::Config::KEYTAB_KRBTYPE = 'Heimdal'; - $kadmin = eval { Wallet::Kadmin->new }; - is ($kadmin, undef, 'Heimdal fails properly'); - is ($@, "keytab object implementation not configured\n", - ' with the right error'); -} - -# Now, check the generic API. We can run this test no matter which -# implementation is configured. This retests some things that are also tested -# by the keytab test, but specifically through the Wallet::Kadmin API. -SKIP: { - skip 'no keytab configuration', 16 unless -f 't/data/test.keytab'; - - # Set up our configuration. - $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; - $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); - $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); - $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); - $Wallet::Config::KEYTAB_TMP = '.'; - - # Don't destroy the user's Kerberos ticket cache. - $ENV{KRB5CCNAME} = 'krb5cc_test'; - - # Create the object and clean up the principal we're going to use. - $kadmin = eval { Wallet::Kadmin->new }; - ok (defined $kadmin, 'Creating Wallet::Kadmin object succeeds'); - is ($@, '', ' and there is no error'); - is ($kadmin->destroy ('wallet/one'), 1, 'Deleting wallet/one works'); - is ($kadmin->exists ('wallet/one'), 0, ' and it does not exist'); - is ($kadmin->error, undef, ' with no error message'); - - # Create the principal and check that keytab returns something. We'll - # check the details of the return in the keytab check. - is ($kadmin->create ('wallet/one'), 1, 'Creating wallet/one works'); - is ($kadmin->error, undef, ' with no error message'); - is ($kadmin->exists ('wallet/one'), 1, ' and it now exists'); - my $data = $kadmin->keytab_rekey ('wallet/one'); - ok (defined ($data), ' and retrieving a keytab works'); - is (keytab_valid ($data, 'wallet/one'), 1, - ' and works for authentication'); - - # Delete the principal and confirm behavior. - is ($kadmin->destroy ('wallet/one'), 1, 'Deleting principal works'); - is ($kadmin->exists ('wallet/one'), 0, ' and now it does not exist'); - is ($kadmin->keytab_rekey ('wallet/one', './tmp.keytab'), undef, - ' and retrieving the keytab does not work'); - ok (! -f './tmp.keytab', ' and no file was created'); - like ($kadmin->error, qr%^error creating keytab for wallet/one%, - ' and the right error message is set'); - is ($kadmin->destroy ('wallet/one'), 1, ' and deleting it again works'); - - unlink 'krb5cc_test'; -} diff --git a/perl/t/keytab.t b/perl/t/keytab.t deleted file mode 100755 index 127762a..0000000 --- a/perl/t/keytab.t +++ /dev/null @@ -1,771 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the keytab object implementation. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2009, 2010, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use POSIX qw(strftime); -use Test::More tests => 141; - -BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } - -use DBI; -use Wallet::Admin; -use Wallet::Config; -use Wallet::Kadmin; -use Wallet::Object::Keytab; - -use lib 't/lib'; -use Util; - -# Mapping of klist -ke encryption type names to the strings that Kerberos uses -# internally. It's very annoying to have to maintain this, and it probably -# breaks with Heimdal. -my %enctype = - ('triple des cbc mode with hmac/sha1' => 'des3-cbc-sha1', - 'des cbc mode with crc-32' => 'des-cbc-crc', - 'des cbc mode with rsa-md5' => 'des-cbc-md5', - 'aes-256 cts mode with 96-bit sha-1 hmac' => 'aes256-cts-hmac-sha1-96', - 'arcfour with hmac/md5' => 'rc4-hmac'); - -# Some global defaults to use. -my $user = 'admin@EXAMPLE.COM'; -my $host = 'localhost'; -my @trace = ($user, $host, time); - -# Flush all output immediately. -$| = 1; - -# Run a command and throw away the output, returning the exit status. -sub system_quiet { - my ($command, @args) = @_; - my $pid = fork; - if (not defined $pid) { - die "cannot fork: $!\n"; - } elsif ($pid == 0) { - open (STDIN, '<', '/dev/null') or die "cannot reopen stdin: $!\n"; - open (STDOUT, '>', '/dev/null') or die "cannot reopen stdout: $!\n"; - open (STDERR, '>', '/dev/null') or die "cannot reopen stderr: $!\n"; - exec ($command, @args) or die "cannot exec $command: $!\n"; - } else { - waitpid ($pid, 0); - return $?; - } -} - -# Create a principal out of Kerberos. Only usable once the configuration has -# been set up. -sub create { - my ($principal) = @_; - my $kadmin = Wallet::Kadmin->new; - return $kadmin->create ($principal); -} - -# Destroy a principal out of Kerberos. Only usable once the configuration has -# been set up. -sub destroy { - my ($principal) = @_; - my $kadmin = Wallet::Kadmin->new; - return $kadmin->destroy ($principal); -} - -# Check whether a principal exists. MIT uses kvno and Heimdal uses kgetcred. -# Note that the Kerberos type may be different than our local userspace, so -# don't use the Kerberos type to decide here. Instead, check for which -# program is available on the path. -sub created { - my ($principal) = @_; - $principal .= '@' . $Wallet::Config::KEYTAB_REALM; - local $ENV{KRB5CCNAME} = 'krb5cc_temp'; - getcreds ('t/data/test.keytab', $Wallet::Config::KEYTAB_PRINCIPAL); - if (grep { -x "$_/kvno" } split (':', $ENV{PATH})) { - return (system_quiet ('kvno', $principal) == 0); - } elsif (grep { -x "$_/kgetcred" } split (':', $ENV{PATH})) { - return (system_quiet ('kgetcred', $principal) == 0); - } else { - warn "# No kvno or kgetcred found\n"; - return; - } -} - -# Given keytab data, write it to a file and try to determine the enctypes of -# the keys present in that file. Returns the enctypes as a list, with UNKNOWN -# for encryption types that weren't recognized. This is an ugly way of doing -# this for MIT. Heimdal is much more straightforward, but MIT ktutil doesn't -# have the needed abilities. -sub enctypes { - my ($keytab) = @_; - open (KEYTAB, '>', 'keytab') or die "cannot create keytab: $!\n"; - print KEYTAB $keytab; - close KEYTAB; - - my @enctypes; - my $pid = open (KLIST, '-|'); - if (not defined $pid) { - die "cannot fork: $!\n"; - } elsif ($pid == 0) { - open (STDERR, '>', '/dev/null') or die "cannot reopen stderr: $!\n"; - exec ('klist', '-ke', 'keytab') - or die "cannot run klist: $!\n"; - } - local $_; - while () { - next unless /^ *\d+ /; - my ($string) = /\((.*)\)\s*$/; - next unless $string; - $enctype = $enctype{lc $string} || 'UNKNOWN'; - push (@enctypes, $enctype); - } - close KLIST; - - # If that failed, we may have a Heimdal user space instead, so try ktutil. - # If we try this directly, it will just hang with MIT ktutil. - if ($? != 0 || !@enctypes) { - @enctypes = (); - open (KTUTIL, '-|', 'ktutil', '-k', 'keytab', 'list') - or die "cannot run ktutil: $!\n"; - local $_; - while () { - next unless /^ *\d+ /; - my ($string) = /^\s*\d+\s+(\S+)/; - next unless $string; - push (@enctypes, $string); - } - close KTUTIL; - } - unlink 'keytab'; - return sort @enctypes; -} - -# Use Wallet::Admin to set up the database. -unlink ('krb5cc_temp', 'krb5cc_test', 'test-acl', 'test-pid'); -db_setup; -my $admin = eval { Wallet::Admin->new }; -is ($@, '', 'Database connection succeeded'); -is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $schema = $admin->schema; -my $dbh = $admin->dbh; - -# 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]); - -# Basic keytab creation and manipulation tests. -SKIP: { - skip 'no keytab configuration', 52 unless -f 't/data/test.keytab'; - - # Set up our configuration. - $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; - $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); - $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); - $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); - my $realm = $Wallet::Config::KEYTAB_REALM; - - # Clean up the principals we're going to use. - destroy ('wallet/one'); - destroy ('wallet/two'); - - # Don't destroy the user's Kerberos ticket cache. - $ENV{KRB5CCNAME} = 'krb5cc_test'; - - # Test that object creation without KEYTAB_TMP fails. - undef $Wallet::Config::KEYTAB_TMP; - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - is ($object, undef, 'Creating keytab without KEYTAB_TMP fails'); - is ($@, "KEYTAB_TMP configuration variable not set\n", - ' with the right error'); - $Wallet::Config::KEYTAB_TMP = '.'; - - # Okay, now we can test. First, create. - $object = eval { - Wallet::Object::Keytab->create ('keytab', "wallet\nf", $schema, - @trace) - }; - is ($object, undef, 'Creating malformed principal fails'); - if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - is ($@, "invalid principal name wallet\nf\n", ' with the right error'); - } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - like ($@, qr/^error adding principal wallet\nf/, - ' with the right error'); - } - $object = eval { - Wallet::Object::Keytab->create ('keytab', '', $schema, @trace) - }; - is ($object, undef, 'Creating empty principal fails'); - if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - is ($@, "invalid principal name \n", ' with the right error'); - } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - like ($@, qr/^error adding principal \@/, ' with the right error'); - } - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - if (defined ($object)) { - ok (defined ($object), 'Creating good principal succeeds'); - } else { - is ($@, '', 'Creating good principal succeeds'); - } - ok ($object->isa ('Wallet::Object::Keytab'), ' and is the right class'); - ok (created ('wallet/one'), ' and the principal was created'); - create ('wallet/two'); - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/two', $schema, - @trace) - }; - if (defined ($object)) { - ok (defined ($object), 'Creating an existing principal succeeds'); - } else { - is ($@, '', 'Creating an existing principal succeeds'); - } - ok ($object->isa ('Wallet::Object::Keytab'), ' and is the right class'); - is ($object->destroy (@trace), 1, ' and destroying it succeeds'); - is ($object->error, undef, ' with no error message'); - ok (! created ('wallet/two'), ' and now it does not exist'); - my @name = qw(keytab wallet-test/one); - $object = eval { Wallet::Object::Keytab->create (@name, $schema, @trace) }; - is ($object, undef, 'Creation without permissions fails'); - like ($@, qr{^error adding principal wallet-test/one\@\Q$realm: }, - ' with the right error'); - - # Now, try retrieving the keytab. - $object = Wallet::Object::Keytab->new ('keytab', 'wallet/one', $schema); - ok (defined ($object), 'Retrieving the object works'); - ok ($object->isa ('Wallet::Object::Keytab'), ' and is the right type'); - is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); - is ($object->get (@trace), undef, ' and get fails'); - is ($object->error, "cannot get keytab:wallet/one: object is locked", - ' because it is locked'); - is ($object->flag_clear ('locked', @trace), 1, - ' and clearing locked works'); - my $data = $object->get (@trace); - if (defined ($data)) { - ok (defined ($data), ' and getting the keytab works'); - } else { - is ($object->error, '', ' and getting the keytab works'); - } - ok (! -f "./keytab.$$", ' and the temporary file was cleaned up'); - ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); - - # For right now, this is the only backend type that we have for which we - # can do a get, so test display of the last download information. - my $expected = <<"EOO"; - Type: keytab - Name: wallet/one - Created by: $user - Created from: $host - Created on: $date - Downloaded by: $user -Downloaded from: $host - Downloaded on: $date -EOO - is ($object->show, $expected, 'Show output is correct'); - - # Test error handling on keytab retrieval. - SKIP: { - skip 'no kadmin program test for Heimdal', 2 - if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; - $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; - $data = $object->get (@trace); - is ($data, undef, 'Cope with a failure to run kadmin'); - like ($object->error, qr{^cannot run /some/nonexistent/file: }, - ' with the right error'); - $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; - } - destroy ('wallet/one'); - $data = $object->get (@trace); - is ($data, undef, 'Getting a keytab for a nonexistent principal fails'); - like ($object->error, - qr{^error creating keytab for wallet/one\@\Q$realm\E: }, - ' with the right error'); - is ($object->destroy (@trace), 1, ' but we can still destroy it'); - - # Test principal deletion on object destruction. - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - ok (defined ($object), 'Creating good principal succeeds'); - ok (created ('wallet/one'), ' and the principal was created'); - SKIP: { - skip 'no kadmin program test for Heimdal', 2 - if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; - $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; - is ($object->destroy (@trace), undef, - ' and destroying it with bad kadmin fails'); - like ($object->error, qr{^cannot run /some/nonexistent/file: }, - ' with the right error'); - $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; - } - is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); - is ($object->destroy (@trace), undef, ' and destroying it fails'); - is ($object->error, "cannot destroy keytab:wallet/one: object is locked", - ' because it is locked'); - is ($object->flag_clear ('locked', @trace), 1, - ' and clearing locked works'); - is ($object->destroy (@trace), 1, ' and destroying it succeeds'); - ok (! created ('wallet/one'), ' and now it does not exist'); - - # Test history (which should still work after the object is deleted). - $history .= <<"EOO"; -$date create - by $user from $host -$date set flag locked - by $user from $host -$date clear flag locked - by $user from $host -$date get - by $user from $host -$date destroy - by $user from $host -$date create - by $user from $host -$date set flag locked - by $user from $host -$date clear flag locked - by $user from $host -$date destroy - by $user from $host -EOO - is ($object->history, $history, 'History is correct to this point'); - - # Test configuration errors. - undef $Wallet::Config::KEYTAB_FILE; - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - is ($object, undef, 'Creating with bad configuration fails'); - is ($@, "keytab object implementation not configured\n", - ' with the right error'); - $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; - undef $Wallet::Config::KEYTAB_PRINCIPAL; - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - is ($object, undef, ' likewise with another missing variable'); - is ($@, "keytab object implementation not configured\n", - ' with the right error'); - $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); - undef $Wallet::Config::KEYTAB_REALM; - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - is ($object, undef, ' and another'); - is ($@, "keytab object implementation not configured\n", - ' with the right error'); - $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); - undef $Wallet::Config::KEYTAB_KRBTYPE; - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - is ($object, undef, ' and another'); - is ($@, "keytab object implementation not configured\n", - ' with the right error'); - $Wallet::Config::KEYTAB_KRBTYPE = 'Active Directory'; - $object = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - is ($object, undef, ' and one set to an invalid value'); - is ($@, "unknown KEYTAB_KRBTYPE setting: Active Directory\n", - ' with the right error'); - $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); -} - -# Tests for unchanging support. Skip these if we don't have a keytab or if we -# can't find remctld. -SKIP: { - skip 'no keytab configuration', 31 unless -f 't/data/test.keytab'; - - # Set up our configuration. - $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; - $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); - $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); - $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); - $Wallet::Config::KEYTAB_TMP = '.'; - my $realm = $Wallet::Config::KEYTAB_REALM; - my $principal = $Wallet::Config::KEYTAB_PRINCIPAL; - - # Create the objects for testing and set the unchanging flag. - my $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - ok (defined ($one), 'Creating wallet/one succeeds'); - is ($one->flag_set ('unchanging', @trace), 1, ' and setting unchanging'); - my $two = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/two', $schema, - @trace); - }; - ok (defined ($two), 'Creating wallet/two succeeds'); - is ($two->flag_set ('unchanging', @trace), 1, ' and setting unchanging'); - - # Finally we can test. First the MIT Kerberos tests. - SKIP: { - skip 'skipping MIT unchanging tests for Heimdal', 16 - if (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'heimdal'); - - # We need remctld and Net::Remctl. - my @path = (split (':', $ENV{PATH}), '/usr/local/sbin', '/usr/sbin'); - my ($remctld) = grep { -x $_ } map { "$_/remctld" } @path; - skip 'remctld not found', 16 unless $remctld; - eval { require Net::Remctl }; - skip 'Net::Remctl not available', 16 if $@; - - # Now spawn our remctld server and get a ticket cache. - remctld_spawn ($remctld, $principal, 't/data/test.keytab', - 't/data/keytab.conf'); - $ENV{KRB5CCNAME} = 'krb5cc_test'; - getcreds ('t/data/test.keytab', $principal); - $ENV{KRB5CCNAME} = 'krb5cc_good'; - - # Do the unchanging tests for MIT Kerberos. - is ($one->get (@trace), undef, 'Get without configuration fails'); - is ($one->error, 'keytab unchanging support not configured', - ' with the right error'); - $Wallet::Config::KEYTAB_REMCTL_CACHE = 'krb5cc_test'; - is ($one->get (@trace), undef, ' and still fails without host'); - is ($one->error, 'keytab unchanging support not configured', - ' with the right error'); - $Wallet::Config::KEYTAB_REMCTL_HOST = 'localhost'; - $Wallet::Config::KEYTAB_REMCTL_PRINCIPAL = $principal; - $Wallet::Config::KEYTAB_REMCTL_PORT = 14373; - is ($one->get (@trace), undef, ' and still fails without ACL'); - is ($one->error, - "cannot retrieve keytab for wallet/one\@$realm: Access denied", - ' with the right error'); - open (ACL, '>', 'test-acl') or die "cannot create test-acl: $!\n"; - print ACL "$principal\n"; - close ACL; - is ($one->get (@trace), 'Keytab for wallet/one', 'Now get works'); - is ($ENV{KRB5CCNAME}, 'krb5cc_good', - ' and we did not nuke the cache name'); - is ($one->get (@trace), 'Keytab for wallet/one', - ' and we get the same thing the second time'); - is ($one->flag_clear ('unchanging', @trace), 1, - 'Clearing the unchanging flag works'); - my $data = $one->get (@trace); - ok (defined ($data), ' and getting the keytab works'); - ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); - is ($two->get (@trace), undef, 'Get for wallet/two does not work'); - is ($two->error, - "cannot retrieve keytab for wallet/two\@$realm: bite me", - ' with the right error'); - is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); - is ($two->destroy (@trace), 1, ' as does destroying wallet/two'); - remctld_stop; - unlink 'krb5cc_good'; - } - - # Now Heimdal. Since the keytab contains timestamps, before testing for - # equality we have to substitute out the timestamps. - SKIP: { - skip 'skipping Heimdal unchanging tests for MIT', 11 - if (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'mit'); - my $data = $one->get (@trace); - ok (defined $data, 'Get of unchanging keytab works'); - ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); - my $second = $one->get (@trace); - ok (defined $second, ' and second retrieval also works'); - $data =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; - $second =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; - ok (keytab_valid ($second, 'wallet/one'), ' and the keytab is valid'); - ok (keytab_valid ($data, 'wallet/one'), ' as is the first keytab'); - is ($one->flag_clear ('unchanging', @trace), 1, - 'Clearing the unchanging flag works'); - $data = $one->get (@trace); - ok (defined ($data), ' and getting the keytab works'); - ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); - $data =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; - ok ($data ne $second, ' and the new keytab is different'); - is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); - is ($two->destroy (@trace), 1, ' as does destroying wallet/two'); - } - - # Check that history has been updated correctly. - $history .= <<"EOO"; -$date create - by $user from $host -$date set flag unchanging - by $user from $host -$date get - by $user from $host -$date get - by $user from $host -$date clear flag unchanging - by $user from $host -$date get - by $user from $host -$date destroy - by $user from $host -EOO - is ($one->history, $history, 'History is correct to this point'); -} - -# Tests for synchronization support. This code is deactivated at present -# since no synchronization targets are supported, but we want to still test -# the basic stub code. -SKIP: { - skip 'no keytab configuration', 18 unless -f 't/data/test.keytab'; - - # Test setting synchronization attributes, which can also be done without - # configuration. - my $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - ok (defined ($one), 'Creating wallet/one succeeds'); - my $expected = <<"EOO"; - Type: keytab - Name: wallet/one - Created by: $user - Created from: $host - Created on: $date -EOO - is ($one->show, $expected, 'Show output displays no attributes'); - is ($one->attr ('foo', [ 'bar' ], @trace), undef, - 'Setting unknown attribute fails'); - is ($one->error, 'unknown attribute foo', ' with the right error'); - my @targets = $one->attr ('foo'); - is (scalar (@targets), 0, ' and getting an unknown attribute fails'); - is ($one->error, 'unknown attribute foo', ' with the right error'); - is ($one->attr ('sync', [ 'kaserver' ], @trace), undef, - ' and setting an unknown sync target fails'); - is ($one->error, 'unsupported synchronization target kaserver', - ' with the right error'); - is ($one->attr ('sync', [ 'kaserver', 'bar' ], @trace), undef, - ' and setting two targets fails'); - is ($one->error, 'only one synchronization target supported', - ' with the right error'); - - # Create a synchronization manually so that we can test the display and - # removal code. - my $sql = "insert into keytab_sync (ks_name, ks_target) values - ('wallet/one', 'kaserver')"; - $dbh->do ($sql); - @targets = $one->attr ('sync'); - is (scalar (@targets), 1, ' and now one target is set'); - is ($targets[0], 'kaserver', ' and it is correct'); - is ($one->error, undef, ' and there is no error'); - $expected = <<"EOO"; - Type: keytab - Name: wallet/one - Synced with: kaserver - Created by: $user - Created from: $host - Created on: $date -EOO - is ($one->show, $expected, ' and show now displays the attribute'); - $history .= <<"EOO"; -$date create - by $user from $host -EOO - is ($one->history, $history, ' and history is correct for attributes'); - is ($one->attr ('sync', [], @trace), 1, - 'Removing the kaserver sync attribute works'); - is ($one->destroy (@trace),1, ' and then destroying wallet/one works'); - $history .= <<"EOO"; -$date remove kaserver from attribute sync - by $user from $host -$date destroy - by $user from $host -EOO - is ($one->history, $history, ' and history is correct for removal'); -} - -# Tests for enctype restriction. -SKIP: { - skip 'no keytab configuration', 36 unless -f 't/data/test.keytab'; - - # Set up our configuration. - $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; - $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); - $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); - $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); - $Wallet::Config::KEYTAB_TMP = '.'; - my $realm = $Wallet::Config::KEYTAB_REALM; - my $principal = $Wallet::Config::KEYTAB_PRINCIPAL; - - # Create an object for testing and determine the enctypes we have to work - # with. - my $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - if (defined ($one)) { - ok (1, 'Creating wallet/one succeeds'); - } else { - is ($@, '', 'Creating wallet/one succeeds'); - } - my $keytab = $one->get (@trace); - ok (defined ($keytab), ' and retrieving the keytab works'); - my @enctypes = grep { $_ ne 'UNKNOWN' } enctypes ($keytab); - $history .= <<"EOO"; -$date create - by $user from $host -$date get - by $user from $host -EOO - is ($one->history, $history, ' and history is still correct'); - - # No enctypes we recognize? - skip 'no recognized enctypes', 34 unless @enctypes; - - # Set those encryption types and make sure we get back a limited keytab. - is ($one->attr ('enctypes', [ @enctypes ], @trace), 1, - 'Setting enctypes works'); - is ($one->error, undef, ' with no error'); - for my $enctype (@enctypes) { - $history .= "$date add $enctype to attribute enctypes\n"; - $history .= " by $user from $host\n"; - } - my @values = $one->attr ('enctypes'); - is ("@values", "@enctypes", ' and we get back the right enctype list'); - my $eshow = join ("\n" . (' ' x 17), @enctypes); - $eshow =~ s/\s+\z/\n/; - $expected = <<"EOO"; - Type: keytab - Name: wallet/one - Enctypes: $eshow - Created by: $user - Created from: $host - Created on: $date - Downloaded by: $user -Downloaded from: $host - Downloaded on: $date -EOO - is ($one->show, $expected, ' and show now displays the enctype list'); - $keytab = $one->get (@trace); - ok (defined ($keytab), ' and retrieving the keytab still works'); - @values = enctypes ($keytab); - is ("@values", "@enctypes", ' and the keytab has the right keys'); - is ($one->attr ('enctypes', [ 'foo-bar' ], @trace), undef, - 'Setting an unrecognized enctype fails'); - is ($one->error, 'unknown encryption type foo-bar', - ' with the right error message'); - is ($one->show, $expected, ' and we did rollback properly'); - $history .= <<"EOO"; -$date get - by $user from $host -EOO - is ($one->history, $history, 'History is correct to this point'); - - # Now, try testing limiting the enctypes to just one. - SKIP: { - skip 'insufficient recognized enctypes', 14 unless @enctypes > 1; - - is ($one->attr ('enctypes', [ $enctypes[0] ], @trace), 1, - 'Setting a single enctype works'); - for my $enctype (@enctypes) { - next if $enctype eq $enctypes[0]; - $history .= "$date remove $enctype from attribute enctypes\n"; - $history .= " by $user from $host\n"; - } - @values = $one->attr ('enctypes'); - is ("@values", $enctypes[0], ' and we get back the right value'); - $keytab = $one->get (@trace); - ok (defined ($keytab), ' and retrieving the keytab still works'); - if (defined ($keytab)) { - @values = enctypes ($keytab); - is ("@values", $enctypes[0], ' and it has the right enctype'); - } else { - ok (0, ' and it has the right keytab'); - } - is ($one->attr ('enctypes', [ $enctypes[1] ], @trace), 1, - 'Setting a different single enctype works'); - @values = $one->attr ('enctypes'); - is ("@values", $enctypes[1], ' and we get back the right value'); - $keytab = $one->get (@trace); - ok (defined ($keytab), ' and retrieving the keytab still works'); - @values = enctypes ($keytab); - is ("@values", $enctypes[1], ' and it has the right enctype'); - is ($one->attr ('enctypes', [ @enctypes[0..1] ], @trace), 1, - 'Setting two enctypes works'); - @values = $one->attr ('enctypes'); - is ("@values", "@enctypes[0..1]", ' and we get back the right values'); - $keytab = $one->get (@trace); - ok (defined ($keytab), ' and retrieving the keytab still works'); - @values = enctypes ($keytab); - is ("@values", "@enctypes[0..1]", ' and it has the right enctypes'); - - # Check the history trace. Put back all the enctypes for consistent - # status whether or not we skipped this section. - $history .= <<"EOO"; -$date get - by $user from $host -$date remove $enctypes[0] from attribute enctypes - by $user from $host -$date add $enctypes[1] to attribute enctypes - by $user from $host -$date get - by $user from $host -$date add $enctypes[0] to attribute enctypes - by $user from $host -$date get - by $user from $host -EOO - is ($one->attr ('enctypes', [ @enctypes ], @trace), 1, - 'Restoring all enctypes works'); - for my $enctype (@enctypes) { - next if $enctype eq $enctypes[0]; - next if $enctype eq $enctypes[1]; - $history .= "$date add $enctype to attribute enctypes\n"; - $history .= " by $user from $host\n"; - } - is ($one->history, $history, 'History is correct to this point'); - } - - # Test clearing enctypes. - is ($one->attr ('enctypes', [], @trace), 1, 'Clearing enctypes works'); - for my $enctype (@enctypes) { - $history .= "$date remove $enctype from attribute enctypes\n"; - $history .= " by $user from $host\n"; - } - @values = $one->attr ('enctypes'); - ok (@values == 0, ' and now there are no enctypes'); - is ($one->error, undef, ' and no error'); - - # Test deleting enctypes on object destruction. - is ($one->attr ('enctypes', [ $enctypes[0] ], @trace), 1, - 'Setting a single enctype works'); - is ($one->destroy (@trace), 1, ' and destroying the object works'); - $one = eval { - Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, - @trace) - }; - ok (defined ($one), ' as does recreating it'); - @values = $one->attr ('enctypes'); - ok (@values == 0, ' and now there are no enctypes'); - is ($one->error, undef, ' and no error'); - - # All done. Clean up and check history. - is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); - $history .= <<"EOO"; -$date add $enctypes[0] to attribute enctypes - by $user from $host -$date destroy - by $user from $host -$date create - by $user from $host -$date destroy - by $user from $host -EOO - is ($one->history, $history, 'History is correct to this point'); -} - -# Clean up. -$admin->destroy; -END { - unlink ('wallet-db', 'krb5cc_temp', 'krb5cc_test', 'test-acl', 'test-pid'); -} diff --git a/perl/t/object.t b/perl/t/object.t deleted file mode 100755 index 0432a23..0000000 --- a/perl/t/object.t +++ /dev/null @@ -1,353 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the basic object implementation. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2011, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use POSIX qw(strftime); -use Test::More tests => 137; - -use Wallet::ACL; -use Wallet::Admin; -use Wallet::Config; -use Wallet::Object::Base; - -use lib 't/lib'; -use Util; - -# Some global defaults to use. -my $user = 'admin@EXAMPLE.COM'; -my $host = 'localhost'; -my @trace = ($user, $host, time); -my $princ = 'service/test@EXAMPLE.COM'; - -# Use Wallet::Admin to set up the database. -db_setup; -my $admin = eval { Wallet::Admin->new }; -is ($@, '', 'Database connection succeeded'); -is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $schema = $admin->schema; - -# Okay, now we have a database. Test create and new. We make believe this is -# a keytab object; it won't matter for what we're doing. -my $object = eval { - Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) - }; -is ($@, '', 'Object creation did not die'); -ok ($object->isa ('Wallet::Object::Base'), ' and returned the right class'); -my $other = eval { - Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) - }; -like ($@, qr/^cannot create object \Qkeytab:$princ: /, 'Repeating fails'); -$other = eval { Wallet::Object::Base->create ('', $princ, $schema, @trace) }; -is ($@, "invalid object type\n", 'Using an empty type fails'); -$other = eval { Wallet::Object::Base->create ('keytab', '', $schema, @trace) }; -is ($@, "invalid object name\n", ' as does an empty name'); -$object = eval { Wallet::Object::Base->new ('keytab', "a$princ", $schema) }; -is ($@, "cannot find keytab:a$princ\n", 'Searching for unknown object fails'); -$object = eval { Wallet::Object::Base->new ('keytab', $princ, $schema) }; -is ($@, '', 'Object new did not die'); -ok ($object->isa ('Wallet::Object::Base'), ' and returned the right class'); - -# Simple accessor tests. -is ($object->type, 'keytab', 'Type accessor works'); -is ($object->name, $princ, 'Name accessor works'); - -# We'll use this for later tests. -my $acl = Wallet::ACL->new ('ADMIN', $schema); - -# Owner. -is ($object->owner, undef, 'Owner is not set to start'); -if ($object->owner ('ADMIN', @trace)) { - ok (1, ' and setting it to ADMIN works'); -} else { - is ($object->error, '', ' and setting it to ADMIN works'); -} -is ($object->owner, $acl->id, ' at which point it is ADMIN'); -ok (! $object->owner ('unknown', @trace), - ' but setting it to something bogus fails'); -is ($object->error, 'ACL unknown not found', ' with the right error'); -if ($object->owner ('', @trace)) { - ok (1, ' and clearing it works'); -} else { - is ($object->error, '', ' and clearing it works'); -} -is ($object->owner, undef, ' at which point it is cleared'); -is ($object->owner ('ADMIN', @trace), 1, ' and setting it again works'); - -# Expires. -is ($object->expires, undef, 'Expires is not set to start'); -my $now = strftime ('%Y-%m-%d %T', localtime time); -if ($object->expires ($now, @trace)) { - ok (1, ' and setting it works'); -} else { - is ($object->error, '', ' and setting it works'); -} -is ($object->expires, $now, ' at which point it matches'); -ok (! $object->expires ('13/13/13 13:13:13', @trace), - ' but setting it to something bogus fails'); -is ($object->error, 'malformed expiration time 13/13/13 13:13:13', - ' with the right error'); -if ($object->expires ('', @trace)) { - ok (1, ' and clearing it works'); -} else { - is ($object->error, '', ' and clearing it works'); -} -is ($object->expires, undef, ' at which point it is cleared'); -is ($object->expires ($now, @trace), 1, ' and setting it again works'); - -# Comment. -is ($object->comment, undef, 'Comment is not set to start'); -if ($object->comment ('this is a comment', @trace)) { - ok (1, ' and setting it works'); -} else { - is ($object->error, '', ' and setting it works'); -} -is ($object->comment, 'this is a comment', ' at which point it matches'); -if ($object->comment ('', @trace)) { - ok (1, ' and clearing it works'); -} else { - is ($object->error, '', ' and clearing it works'); -} -is ($object->comment, undef, ' at which point it is cleared'); -is ($object->comment (join (' ', ('this is a comment') x 5), @trace), 1, - ' and setting it again works'); - -# ACLs. -for my $type (qw/get store show destroy flags/) { - is ($object->acl ($type), undef, "ACL $type is not set to start"); - if ($object->acl ($type, $acl->id, @trace)) { - ok (1, ' and setting it to ADMIN (numeric) works'); - } else { - is ($object->error, '', ' and setting it to ADMIN (numeric) works'); - } - is ($object->acl ($type), $acl->id, ' at which point it is ADMIN'); - ok (! $object->acl ($type, 22, @trace), - ' but setting it to something bogus fails'); - is ($object->error, 'ACL 22 not found', ' with the right error'); - if ($object->acl ($type, '', @trace)) { - ok (1, ' and clearing it works'); - } else { - is ($object->error, '', ' and clearing it works'); - } - is ($object->acl ($type), undef, ' at which point it is cleared'); - is ($object->acl ($type, $acl->id, @trace), 1, - ' and setting it again works'); -} - -# Flags. -my @flags = $object->flag_list; -is (scalar (@flags), 0, 'No flags set to start'); -is ($object->flag_check ('locked'), 0, ' and locked is not set'); -is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); -is ($object->flag_check ('locked'), 1, ' and now locked is set'); -@flags = $object->flag_list; -is (scalar (@flags), 1, ' and there is one flag'); -is ($flags[0], 'locked', ' which is locked'); -is ($object->flag_set ('locked', @trace), undef, 'Setting locked again fails'); -is ($object->error, - "cannot set flag locked on keytab:$princ: flag already set", - ' with the right error'); -is ($object->flag_set ('unchanging', @trace), 1, - ' but setting unchanging works'); -is ($object->flag_check ('unchanging'), 1, ' and unchanging is now set'); -@flags = $object->flag_list; -is (scalar (@flags), 2, ' and there are two flags'); -is ($flags[0], 'locked', ' which are locked'); -is ($flags[1], 'unchanging', ' and unchanging'); -is ($object->flag_clear ('locked', @trace), 1, 'Clearing locked works'); -is ($object->flag_check ('locked'), 0, ' and now it is not set'); -is ($object->flag_check ('unchanging'), 1, ' but unchanging still is'); -is ($object->flag_clear ('locked', @trace), undef, - ' and clearing it again fails'); -is ($object->error, - "cannot clear flag locked on keytab:$princ: flag not set", - ' with the right error'); -if ($object->flag_set ('locked', @trace)) { - ok (1, ' and setting it again works'); -} else { - is ($object->error, '', ' and setting it again works'); -} - -# Attributes. Very boring. -is ($object->attr ('foo'), undef, 'Retrieving an attribute fails'); -is ($object->error, 'unknown attribute foo', ' with the right error'); -is ($object->attr ('foo', [ 'foo' ], @trace), undef, ' and setting fails'); -is ($object->error, 'unknown attribute foo', ' with the right error'); - -# Test stub methods and locked status. -is ($object->store ("Some data", @trace), undef, 'Store fails'); -is ($object->error, "cannot store keytab:${princ}: object is locked", - ' because the object is locked'); -is ($object->owner ('', @trace), undef, ' and setting owner fails'); -is ($object->error, "cannot modify keytab:${princ}: object is locked", - ' for the same reason'); -is ($object->owner, 1, ' but retrieving the owner works'); -is ($object->expires ('', @trace), undef, ' and setting expires fails'); -is ($object->error, "cannot modify keytab:${princ}: object is locked", - ' for the same reason'); -is ($object->expires, $now, ' but retrieving expires works'); -for my $acl (qw/get store show destroy flags/) { - is ($object->acl ($acl, '', @trace), undef, " and setting $acl ACL fails"); - is ($object->error, "cannot modify keytab:${princ}: object is locked", - ' for the same reason'); - is ($object->acl ($acl), 1, " but retrieving $acl ACL works"); -} -is ($object->flag_check ('locked'), 1, ' and checking flags works'); -@flags = $object->flag_list; -is (scalar (@flags), 2, ' and listing flags works'); -is ("@flags", 'locked unchanging', ' and returns the right data'); -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->store ("Some data", @trace), 'Store fails'); -is ($object->error, "cannot store keytab:$princ: object type is immutable", - ' with the right error'); - -# Test show. -my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); -my $output = <<"EOO"; - Type: keytab - Name: $princ - Owner: ADMIN - Get ACL: ADMIN - Store ACL: ADMIN - Show ACL: ADMIN - Destroy ACL: ADMIN - Flags ACL: ADMIN - Expires: $now - Comment: this is a comment this is a comment this is a comment this is - a comment this is a comment - Flags: unchanging - Created by: $user - Created from: $host - Created on: $date - -Members of ACL ADMIN (id: 1) are: - krb5 $user -EOO -is ($object->show, $output, 'Show output is correct'); -is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); -$output = <<"EOO"; - Type: keytab - Name: $princ - Owner: ADMIN - Get ACL: ADMIN - Store ACL: ADMIN - Show ACL: ADMIN - Destroy ACL: ADMIN - Flags ACL: ADMIN - Expires: $now - Comment: this is a comment this is a comment this is a comment this is - a comment this is a comment - Flags: locked unchanging - Created by: $user - Created from: $host - Created on: $date - -Members of ACL ADMIN (id: 1) are: - krb5 $user -EOO -is ($object->show, $output, ' and show still works and is correct'); - -# Test destroy. -is ($object->destroy (@trace), undef, 'Destroy fails'); -is ($object->error, "cannot destroy keytab:${princ}: object is locked", - ' because of the locked status'); -is ($object->flag_clear ('locked', @trace), 1, - ' and clearing locked status works'); -if ($object->destroy (@trace)) { - ok (1, 'Destroy is successful'); -} else { - is ($object->error, '', 'Destroy is successful'); -} -$object = eval { Wallet::Object::Base->new ('keytab', $princ, $schema) }; -is ($@, "cannot find keytab:$princ\n", ' and object is all gone'); - -# Test history. -$object = eval { - Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) - }; -ok (defined ($object), 'Recreating the object succeeds'); -$output = <<"EOO"; -$date create - by $user from $host -$date set owner to ADMIN (1) - by $user from $host -$date unset owner (was ADMIN (1)) - by $user from $host -$date set owner to ADMIN (1) - by $user from $host -$date set expires to $now - by $user from $host -$date unset expires (was $now) - by $user from $host -$date set expires to $now - by $user from $host -$date set comment to this is a comment - by $user from $host -$date unset comment (was this is a comment) - by $user from $host -$date set comment to this is a comment this is a comment this is a comment this is a comment this is a comment - by $user from $host -$date set acl_get to ADMIN (1) - by $user from $host -$date unset acl_get (was ADMIN (1)) - by $user from $host -$date set acl_get to ADMIN (1) - by $user from $host -$date set acl_store to ADMIN (1) - by $user from $host -$date unset acl_store (was ADMIN (1)) - by $user from $host -$date set acl_store to ADMIN (1) - by $user from $host -$date set acl_show to ADMIN (1) - by $user from $host -$date unset acl_show (was ADMIN (1)) - by $user from $host -$date set acl_show to ADMIN (1) - by $user from $host -$date set acl_destroy to ADMIN (1) - by $user from $host -$date unset acl_destroy (was ADMIN (1)) - by $user from $host -$date set acl_destroy to ADMIN (1) - by $user from $host -$date set acl_flags to ADMIN (1) - by $user from $host -$date unset acl_flags (was ADMIN (1)) - by $user from $host -$date set acl_flags to ADMIN (1) - by $user from $host -$date set flag locked - by $user from $host -$date set flag unchanging - by $user from $host -$date clear flag locked - by $user from $host -$date set flag locked - by $user from $host -$date clear flag locked - by $user from $host -$date set flag locked - by $user from $host -$date clear flag locked - by $user from $host -$date destroy - by $user from $host -$date create - by $user from $host -EOO -is ($object->history, $output, ' and the history is correct'); - -# Clean up. -$admin->destroy; -END { - unlink 'wallet-db'; -} diff --git a/perl/t/object/base.t b/perl/t/object/base.t new file mode 100755 index 0000000..0432a23 --- /dev/null +++ b/perl/t/object/base.t @@ -0,0 +1,353 @@ +#!/usr/bin/perl -w +# +# Tests for the basic object implementation. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2011, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 137; + +use Wallet::ACL; +use Wallet::Admin; +use Wallet::Config; +use Wallet::Object::Base; + +use lib 't/lib'; +use Util; + +# Some global defaults to use. +my $user = 'admin@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($user, $host, time); +my $princ = 'service/test@EXAMPLE.COM'; + +# Use Wallet::Admin to set up the database. +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); +my $schema = $admin->schema; + +# Okay, now we have a database. Test create and new. We make believe this is +# a keytab object; it won't matter for what we're doing. +my $object = eval { + Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) + }; +is ($@, '', 'Object creation did not die'); +ok ($object->isa ('Wallet::Object::Base'), ' and returned the right class'); +my $other = eval { + Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) + }; +like ($@, qr/^cannot create object \Qkeytab:$princ: /, 'Repeating fails'); +$other = eval { Wallet::Object::Base->create ('', $princ, $schema, @trace) }; +is ($@, "invalid object type\n", 'Using an empty type fails'); +$other = eval { Wallet::Object::Base->create ('keytab', '', $schema, @trace) }; +is ($@, "invalid object name\n", ' as does an empty name'); +$object = eval { Wallet::Object::Base->new ('keytab', "a$princ", $schema) }; +is ($@, "cannot find keytab:a$princ\n", 'Searching for unknown object fails'); +$object = eval { Wallet::Object::Base->new ('keytab', $princ, $schema) }; +is ($@, '', 'Object new did not die'); +ok ($object->isa ('Wallet::Object::Base'), ' and returned the right class'); + +# Simple accessor tests. +is ($object->type, 'keytab', 'Type accessor works'); +is ($object->name, $princ, 'Name accessor works'); + +# We'll use this for later tests. +my $acl = Wallet::ACL->new ('ADMIN', $schema); + +# Owner. +is ($object->owner, undef, 'Owner is not set to start'); +if ($object->owner ('ADMIN', @trace)) { + ok (1, ' and setting it to ADMIN works'); +} else { + is ($object->error, '', ' and setting it to ADMIN works'); +} +is ($object->owner, $acl->id, ' at which point it is ADMIN'); +ok (! $object->owner ('unknown', @trace), + ' but setting it to something bogus fails'); +is ($object->error, 'ACL unknown not found', ' with the right error'); +if ($object->owner ('', @trace)) { + ok (1, ' and clearing it works'); +} else { + is ($object->error, '', ' and clearing it works'); +} +is ($object->owner, undef, ' at which point it is cleared'); +is ($object->owner ('ADMIN', @trace), 1, ' and setting it again works'); + +# Expires. +is ($object->expires, undef, 'Expires is not set to start'); +my $now = strftime ('%Y-%m-%d %T', localtime time); +if ($object->expires ($now, @trace)) { + ok (1, ' and setting it works'); +} else { + is ($object->error, '', ' and setting it works'); +} +is ($object->expires, $now, ' at which point it matches'); +ok (! $object->expires ('13/13/13 13:13:13', @trace), + ' but setting it to something bogus fails'); +is ($object->error, 'malformed expiration time 13/13/13 13:13:13', + ' with the right error'); +if ($object->expires ('', @trace)) { + ok (1, ' and clearing it works'); +} else { + is ($object->error, '', ' and clearing it works'); +} +is ($object->expires, undef, ' at which point it is cleared'); +is ($object->expires ($now, @trace), 1, ' and setting it again works'); + +# Comment. +is ($object->comment, undef, 'Comment is not set to start'); +if ($object->comment ('this is a comment', @trace)) { + ok (1, ' and setting it works'); +} else { + is ($object->error, '', ' and setting it works'); +} +is ($object->comment, 'this is a comment', ' at which point it matches'); +if ($object->comment ('', @trace)) { + ok (1, ' and clearing it works'); +} else { + is ($object->error, '', ' and clearing it works'); +} +is ($object->comment, undef, ' at which point it is cleared'); +is ($object->comment (join (' ', ('this is a comment') x 5), @trace), 1, + ' and setting it again works'); + +# ACLs. +for my $type (qw/get store show destroy flags/) { + is ($object->acl ($type), undef, "ACL $type is not set to start"); + if ($object->acl ($type, $acl->id, @trace)) { + ok (1, ' and setting it to ADMIN (numeric) works'); + } else { + is ($object->error, '', ' and setting it to ADMIN (numeric) works'); + } + is ($object->acl ($type), $acl->id, ' at which point it is ADMIN'); + ok (! $object->acl ($type, 22, @trace), + ' but setting it to something bogus fails'); + is ($object->error, 'ACL 22 not found', ' with the right error'); + if ($object->acl ($type, '', @trace)) { + ok (1, ' and clearing it works'); + } else { + is ($object->error, '', ' and clearing it works'); + } + is ($object->acl ($type), undef, ' at which point it is cleared'); + is ($object->acl ($type, $acl->id, @trace), 1, + ' and setting it again works'); +} + +# Flags. +my @flags = $object->flag_list; +is (scalar (@flags), 0, 'No flags set to start'); +is ($object->flag_check ('locked'), 0, ' and locked is not set'); +is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); +is ($object->flag_check ('locked'), 1, ' and now locked is set'); +@flags = $object->flag_list; +is (scalar (@flags), 1, ' and there is one flag'); +is ($flags[0], 'locked', ' which is locked'); +is ($object->flag_set ('locked', @trace), undef, 'Setting locked again fails'); +is ($object->error, + "cannot set flag locked on keytab:$princ: flag already set", + ' with the right error'); +is ($object->flag_set ('unchanging', @trace), 1, + ' but setting unchanging works'); +is ($object->flag_check ('unchanging'), 1, ' and unchanging is now set'); +@flags = $object->flag_list; +is (scalar (@flags), 2, ' and there are two flags'); +is ($flags[0], 'locked', ' which are locked'); +is ($flags[1], 'unchanging', ' and unchanging'); +is ($object->flag_clear ('locked', @trace), 1, 'Clearing locked works'); +is ($object->flag_check ('locked'), 0, ' and now it is not set'); +is ($object->flag_check ('unchanging'), 1, ' but unchanging still is'); +is ($object->flag_clear ('locked', @trace), undef, + ' and clearing it again fails'); +is ($object->error, + "cannot clear flag locked on keytab:$princ: flag not set", + ' with the right error'); +if ($object->flag_set ('locked', @trace)) { + ok (1, ' and setting it again works'); +} else { + is ($object->error, '', ' and setting it again works'); +} + +# Attributes. Very boring. +is ($object->attr ('foo'), undef, 'Retrieving an attribute fails'); +is ($object->error, 'unknown attribute foo', ' with the right error'); +is ($object->attr ('foo', [ 'foo' ], @trace), undef, ' and setting fails'); +is ($object->error, 'unknown attribute foo', ' with the right error'); + +# Test stub methods and locked status. +is ($object->store ("Some data", @trace), undef, 'Store fails'); +is ($object->error, "cannot store keytab:${princ}: object is locked", + ' because the object is locked'); +is ($object->owner ('', @trace), undef, ' and setting owner fails'); +is ($object->error, "cannot modify keytab:${princ}: object is locked", + ' for the same reason'); +is ($object->owner, 1, ' but retrieving the owner works'); +is ($object->expires ('', @trace), undef, ' and setting expires fails'); +is ($object->error, "cannot modify keytab:${princ}: object is locked", + ' for the same reason'); +is ($object->expires, $now, ' but retrieving expires works'); +for my $acl (qw/get store show destroy flags/) { + is ($object->acl ($acl, '', @trace), undef, " and setting $acl ACL fails"); + is ($object->error, "cannot modify keytab:${princ}: object is locked", + ' for the same reason'); + is ($object->acl ($acl), 1, " but retrieving $acl ACL works"); +} +is ($object->flag_check ('locked'), 1, ' and checking flags works'); +@flags = $object->flag_list; +is (scalar (@flags), 2, ' and listing flags works'); +is ("@flags", 'locked unchanging', ' and returns the right data'); +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->store ("Some data", @trace), 'Store fails'); +is ($object->error, "cannot store keytab:$princ: object type is immutable", + ' with the right error'); + +# Test show. +my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); +my $output = <<"EOO"; + Type: keytab + Name: $princ + Owner: ADMIN + Get ACL: ADMIN + Store ACL: ADMIN + Show ACL: ADMIN + Destroy ACL: ADMIN + Flags ACL: ADMIN + Expires: $now + Comment: this is a comment this is a comment this is a comment this is + a comment this is a comment + Flags: unchanging + Created by: $user + Created from: $host + Created on: $date + +Members of ACL ADMIN (id: 1) are: + krb5 $user +EOO +is ($object->show, $output, 'Show output is correct'); +is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); +$output = <<"EOO"; + Type: keytab + Name: $princ + Owner: ADMIN + Get ACL: ADMIN + Store ACL: ADMIN + Show ACL: ADMIN + Destroy ACL: ADMIN + Flags ACL: ADMIN + Expires: $now + Comment: this is a comment this is a comment this is a comment this is + a comment this is a comment + Flags: locked unchanging + Created by: $user + Created from: $host + Created on: $date + +Members of ACL ADMIN (id: 1) are: + krb5 $user +EOO +is ($object->show, $output, ' and show still works and is correct'); + +# Test destroy. +is ($object->destroy (@trace), undef, 'Destroy fails'); +is ($object->error, "cannot destroy keytab:${princ}: object is locked", + ' because of the locked status'); +is ($object->flag_clear ('locked', @trace), 1, + ' and clearing locked status works'); +if ($object->destroy (@trace)) { + ok (1, 'Destroy is successful'); +} else { + is ($object->error, '', 'Destroy is successful'); +} +$object = eval { Wallet::Object::Base->new ('keytab', $princ, $schema) }; +is ($@, "cannot find keytab:$princ\n", ' and object is all gone'); + +# Test history. +$object = eval { + Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) + }; +ok (defined ($object), 'Recreating the object succeeds'); +$output = <<"EOO"; +$date create + by $user from $host +$date set owner to ADMIN (1) + by $user from $host +$date unset owner (was ADMIN (1)) + by $user from $host +$date set owner to ADMIN (1) + by $user from $host +$date set expires to $now + by $user from $host +$date unset expires (was $now) + by $user from $host +$date set expires to $now + by $user from $host +$date set comment to this is a comment + by $user from $host +$date unset comment (was this is a comment) + by $user from $host +$date set comment to this is a comment this is a comment this is a comment this is a comment this is a comment + by $user from $host +$date set acl_get to ADMIN (1) + by $user from $host +$date unset acl_get (was ADMIN (1)) + by $user from $host +$date set acl_get to ADMIN (1) + by $user from $host +$date set acl_store to ADMIN (1) + by $user from $host +$date unset acl_store (was ADMIN (1)) + by $user from $host +$date set acl_store to ADMIN (1) + by $user from $host +$date set acl_show to ADMIN (1) + by $user from $host +$date unset acl_show (was ADMIN (1)) + by $user from $host +$date set acl_show to ADMIN (1) + by $user from $host +$date set acl_destroy to ADMIN (1) + by $user from $host +$date unset acl_destroy (was ADMIN (1)) + by $user from $host +$date set acl_destroy to ADMIN (1) + by $user from $host +$date set acl_flags to ADMIN (1) + by $user from $host +$date unset acl_flags (was ADMIN (1)) + by $user from $host +$date set acl_flags to ADMIN (1) + by $user from $host +$date set flag locked + by $user from $host +$date set flag unchanging + by $user from $host +$date clear flag locked + by $user from $host +$date set flag locked + by $user from $host +$date clear flag locked + by $user from $host +$date set flag locked + by $user from $host +$date clear flag locked + by $user from $host +$date destroy + by $user from $host +$date create + by $user from $host +EOO +is ($object->history, $output, ' and the history is correct'); + +# Clean up. +$admin->destroy; +END { + unlink 'wallet-db'; +} diff --git a/perl/t/object/duo.t b/perl/t/object/duo.t new file mode 100755 index 0000000..4229afe --- /dev/null +++ b/perl/t/object/duo.t @@ -0,0 +1,157 @@ +#!/usr/bin/perl +# +# Tests for the Duo integration object implementation. +# +# Written by Russ Allbery +# Copyright 2014 +# 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; + +BEGIN { + eval 'use Net::Duo'; + plan skip_all => 'Net::Duo required for testing duo' + if $@; + eval 'use Net::Duo::Mock::Agent'; + plan skip_all => 'Net::Duo::Mock::Agent required for testing duo' + if $@; +} + +BEGIN { + use_ok('Wallet::Admin'); + use_ok('Wallet::Config'); + use_ok('Wallet::Object::Duo'); +} + +use lib 't/lib'; +use Util; + +# Some global defaults to use. +my $user = 'admin@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($user, $host, time); +my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); + +# Flush all output immediately. +$| = 1; + +# Use Wallet::Admin to set up the database. +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); +my $schema = $admin->schema; + +# Create a mock object to use for Duo calls. +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->new ('duo', 'test', $schema); +}; +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->create ('duo', 'test', $schema, @trace); +}; +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. +$Wallet::Config::DUO_AGENT = $mock; +$Wallet::Config::DUO_KEY_FILE = 't/data/duo/keys.json'; + +# Test creating an integration. +note ('Test creating an integration'); +my $expected = { + name => 'test', + notes => 'Managed by wallet', + type => 'unix', +}; +$mock->expect ( + { + method => 'POST', + uri => '/admin/v1/integrations', + content => $expected, + response_file => 't/data/duo/integration.json', + } +); +$object = Wallet::Object::Duo->create ('duo', 'test', $schema, @trace); +isa_ok ($object, 'Wallet::Object::Duo'); + +# Check the metadata about the new wallet object. +$expected = <<"EOO"; + Type: duo + Name: test + Duo key: DIRWIH0ZZPV4G88B37VQ + Created by: $user + Created from: $host + Created on: $date +EOO +is ($object->show, $expected, 'Show output is correct'); + +# Test retrieving the integration information. +note ('Test retrieving an integration'); +$mock->expect ( + { + method => 'GET', + uri => '/admin/v1/integrations/DIRWIH0ZZPV4G88B37VQ', + response_file => 't/data/duo/integration.json', + } +); +my $data = $object->get (@trace); +ok (defined ($data), 'Retrieval succeeds'); +$expected = <<'EOO'; +[duo] +ikey = DIRWIH0ZZPV4G88B37VQ +skey = QO4ZLqQVRIOZYkHfdPDORfcNf8LeXIbCWwHazY7o +host = example-admin.duosecurity.com +EOO +is ($data, $expected, '...and integration data is correct'); + +# Ensure that we can't retrieve the object when locked. +is ($object->flag_set ('locked', @trace), 1, + 'Setting object to locked succeeds'); +is ($object->get, undef, '...and now get fails'); +is ($object->error, 'cannot get duo:test: object is locked', + '...with correct error'); +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->new ('duo', '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 +# calls and delete makes two calls. +note ('Test deleting an integration'); +$mock->expect ( + { + method => 'GET', + uri => '/admin/v1/integrations/DIRWIH0ZZPV4G88B37VQ', + response_file => 't/data/duo/integration.json', + } +); +TODO: { + local $TODO = 'Net::Duo::Mock::Agent not yet capable'; + + is ($object->destroy (@trace), 1, 'Duo object deletion succeeded'); + $object = eval { Wallet::Object::Duo->new ('duo', 'test', $schema) }; + is ($object, undef, '...and now object cannot be retrieved'); + is ($@, "cannot find duo:test\n", '...with correct error'); +} + +# Clean up. +$admin->destroy; +END { + unlink ('wallet-db'); +} + +# Done testing. +done_testing (); diff --git a/perl/t/object/file.t b/perl/t/object/file.t new file mode 100755 index 0000000..0aecd9d --- /dev/null +++ b/perl/t/object/file.t @@ -0,0 +1,150 @@ +#!/usr/bin/perl -w +# +# Tests for the file object implementation. +# +# Written by Russ Allbery +# Copyright 2008, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 56; + +use Wallet::Admin; +use Wallet::Config; +use Wallet::Object::File; + +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]); + +# Test error handling in the absence of configuration. +$object = eval { + Wallet::Object::File->create ('file', 'test', $schema, @trace) + }; +ok (defined ($object), 'Creating a basic file object succeeds'); +ok ($object->isa ('Wallet::Object::File'), ' and is the right class'); +is ($object->get (@trace), undef, ' and get fails'); +is ($object->error, 'file support not configured', ' with the right error'); +is ($object->store (@trace), undef, ' and store fails'); +is ($object->error, 'file 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::FILE_BUCKET = 'test-files'; + +# Okay, now we can test. First, the basic object without store. +$object = eval { + Wallet::Object::File->create ('file', 'test', $schema, @trace) + }; +ok (defined ($object), 'Creating a basic file object succeeds'); +ok ($object->isa ('Wallet::Object::File'), ' and is the right class'); +is ($object->get (@trace), undef, ' and get fails'); +is ($object->error, 'cannot get file:test: object has not been stored', + ' with the right error'); +is ($object->destroy (@trace), 1, ' but destroying the object succeeds'); + +# Now store something and be sure that we get something reasonable. +$object = eval { + Wallet::Object::File->create ('file', 'test', $schema, @trace) + }; +ok (defined ($object), 'Recreating the object succeeds'); +is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); +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'), '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 fails if we delete it'); +is ($object->error, 'cannot get file: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'); + +# Try exceeding the store size. +$Wallet::Config::FILE_MAX_SIZE = 1024; +is ($object->store ('x' x 1024, @trace), 1, + ' and storing exactly 1024 characters works'); +is ($object->get (@trace), 'x' x 1024, ' and get returns the right thing'); +is ($object->store ('x' x 1025, @trace), undef, + ' but storing 1025 characters fails'); +is ($object->error, 'data exceeds maximum of 1024 bytes', + ' with the right error'); + +# Try storing the empty data object. +is ($object->store ('', @trace), 1, 'Storing the empty object works'); +is ($object->get (@trace), '', ' and get returns the right thing'); + +# Test destruction. +is ($object->destroy (@trace), 1, 'Destroying the object works'); +ok (! -f 'test-files/09/test', ' and the file is gone'); + +# Now try some aggressive names. +$object = eval { + Wallet::Object::File->create ('file', '../foo', $schema, @trace) + }; +ok (defined ($object), 'Creating ../foo succeeds'); +is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); +ok (-d 'test-files/39', ' and the hash bucket was created'); +ok (-f 'test-files/39/%2E%2E%2Ffoo', ' and the file exists'); +is (contents ('test-files/39/%2E%2E%2Ffoo'), 'foo', + ' with the right contents'); +is ($object->get (@trace), "foo\n", ' and get returns correctly'); +is ($object->destroy (@trace), 1, 'Destroying the object works'); +ok (! -f 'test-files/39/%2E%2E%2Ffoo', ' and the file is gone'); +$object = eval { + Wallet::Object::File->create ('file', "\0", $schema, @trace) + }; +ok (defined ($object), 'Creating nul succeeds'); +is ($object->store ("foo\n", @trace), 1, ' and storing data in it succeeds'); +ok (-d 'test-files/93', ' and the hash bucket was created'); +ok (-f 'test-files/93/%00', ' and the file exists'); +is (contents ('test-files/93/%00'), 'foo', + ' with the right contents'); +is ($object->get (@trace), "foo\n", ' and get returns correctly'); +is ($object->destroy (@trace), 1, 'Destroying the object works'); +ok (! -f 'test-files/93/%00', ' and the file is gone'); + +# Test error handling in the file store. +system ('rm -r test-files') == 0 or die "cannot remove test-files\n"; +$object = eval { + Wallet::Object::File->create ('file', 'test', $schema, @trace) + }; +ok (defined ($object), 'Recreating the object succeeds'); +is ($object->store ("foo\n", @trace), undef, + ' and storing data in it fails'); +like ($object->error, qr/^cannot create file bucket 09: /, + ' with the right error'); +is ($object->get (@trace), undef, ' and get fails'); +like ($object->error, qr/^cannot create file bucket 09: /, + ' with the right error'); +is ($object->destroy (@trace), 1, ' but destroying the object succeeds'); + +# Clean up. +$admin->destroy; +END { + unlink ('wallet-db'); +} diff --git a/perl/t/object/keytab.t b/perl/t/object/keytab.t new file mode 100755 index 0000000..127762a --- /dev/null +++ b/perl/t/object/keytab.t @@ -0,0 +1,771 @@ +#!/usr/bin/perl -w +# +# Tests for the keytab object implementation. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2009, 2010, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 141; + +BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } + +use DBI; +use Wallet::Admin; +use Wallet::Config; +use Wallet::Kadmin; +use Wallet::Object::Keytab; + +use lib 't/lib'; +use Util; + +# Mapping of klist -ke encryption type names to the strings that Kerberos uses +# internally. It's very annoying to have to maintain this, and it probably +# breaks with Heimdal. +my %enctype = + ('triple des cbc mode with hmac/sha1' => 'des3-cbc-sha1', + 'des cbc mode with crc-32' => 'des-cbc-crc', + 'des cbc mode with rsa-md5' => 'des-cbc-md5', + 'aes-256 cts mode with 96-bit sha-1 hmac' => 'aes256-cts-hmac-sha1-96', + 'arcfour with hmac/md5' => 'rc4-hmac'); + +# Some global defaults to use. +my $user = 'admin@EXAMPLE.COM'; +my $host = 'localhost'; +my @trace = ($user, $host, time); + +# Flush all output immediately. +$| = 1; + +# Run a command and throw away the output, returning the exit status. +sub system_quiet { + my ($command, @args) = @_; + my $pid = fork; + if (not defined $pid) { + die "cannot fork: $!\n"; + } elsif ($pid == 0) { + open (STDIN, '<', '/dev/null') or die "cannot reopen stdin: $!\n"; + open (STDOUT, '>', '/dev/null') or die "cannot reopen stdout: $!\n"; + open (STDERR, '>', '/dev/null') or die "cannot reopen stderr: $!\n"; + exec ($command, @args) or die "cannot exec $command: $!\n"; + } else { + waitpid ($pid, 0); + return $?; + } +} + +# Create a principal out of Kerberos. Only usable once the configuration has +# been set up. +sub create { + my ($principal) = @_; + my $kadmin = Wallet::Kadmin->new; + return $kadmin->create ($principal); +} + +# Destroy a principal out of Kerberos. Only usable once the configuration has +# been set up. +sub destroy { + my ($principal) = @_; + my $kadmin = Wallet::Kadmin->new; + return $kadmin->destroy ($principal); +} + +# Check whether a principal exists. MIT uses kvno and Heimdal uses kgetcred. +# Note that the Kerberos type may be different than our local userspace, so +# don't use the Kerberos type to decide here. Instead, check for which +# program is available on the path. +sub created { + my ($principal) = @_; + $principal .= '@' . $Wallet::Config::KEYTAB_REALM; + local $ENV{KRB5CCNAME} = 'krb5cc_temp'; + getcreds ('t/data/test.keytab', $Wallet::Config::KEYTAB_PRINCIPAL); + if (grep { -x "$_/kvno" } split (':', $ENV{PATH})) { + return (system_quiet ('kvno', $principal) == 0); + } elsif (grep { -x "$_/kgetcred" } split (':', $ENV{PATH})) { + return (system_quiet ('kgetcred', $principal) == 0); + } else { + warn "# No kvno or kgetcred found\n"; + return; + } +} + +# Given keytab data, write it to a file and try to determine the enctypes of +# the keys present in that file. Returns the enctypes as a list, with UNKNOWN +# for encryption types that weren't recognized. This is an ugly way of doing +# this for MIT. Heimdal is much more straightforward, but MIT ktutil doesn't +# have the needed abilities. +sub enctypes { + my ($keytab) = @_; + open (KEYTAB, '>', 'keytab') or die "cannot create keytab: $!\n"; + print KEYTAB $keytab; + close KEYTAB; + + my @enctypes; + my $pid = open (KLIST, '-|'); + if (not defined $pid) { + die "cannot fork: $!\n"; + } elsif ($pid == 0) { + open (STDERR, '>', '/dev/null') or die "cannot reopen stderr: $!\n"; + exec ('klist', '-ke', 'keytab') + or die "cannot run klist: $!\n"; + } + local $_; + while () { + next unless /^ *\d+ /; + my ($string) = /\((.*)\)\s*$/; + next unless $string; + $enctype = $enctype{lc $string} || 'UNKNOWN'; + push (@enctypes, $enctype); + } + close KLIST; + + # If that failed, we may have a Heimdal user space instead, so try ktutil. + # If we try this directly, it will just hang with MIT ktutil. + if ($? != 0 || !@enctypes) { + @enctypes = (); + open (KTUTIL, '-|', 'ktutil', '-k', 'keytab', 'list') + or die "cannot run ktutil: $!\n"; + local $_; + while () { + next unless /^ *\d+ /; + my ($string) = /^\s*\d+\s+(\S+)/; + next unless $string; + push (@enctypes, $string); + } + close KTUTIL; + } + unlink 'keytab'; + return sort @enctypes; +} + +# Use Wallet::Admin to set up the database. +unlink ('krb5cc_temp', 'krb5cc_test', 'test-acl', 'test-pid'); +db_setup; +my $admin = eval { Wallet::Admin->new }; +is ($@, '', 'Database connection succeeded'); +is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); +my $schema = $admin->schema; +my $dbh = $admin->dbh; + +# 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]); + +# Basic keytab creation and manipulation tests. +SKIP: { + skip 'no keytab configuration', 52 unless -f 't/data/test.keytab'; + + # Set up our configuration. + $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; + $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); + $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); + my $realm = $Wallet::Config::KEYTAB_REALM; + + # Clean up the principals we're going to use. + destroy ('wallet/one'); + destroy ('wallet/two'); + + # Don't destroy the user's Kerberos ticket cache. + $ENV{KRB5CCNAME} = 'krb5cc_test'; + + # Test that object creation without KEYTAB_TMP fails. + undef $Wallet::Config::KEYTAB_TMP; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + is ($object, undef, 'Creating keytab without KEYTAB_TMP fails'); + is ($@, "KEYTAB_TMP configuration variable not set\n", + ' with the right error'); + $Wallet::Config::KEYTAB_TMP = '.'; + + # Okay, now we can test. First, create. + $object = eval { + Wallet::Object::Keytab->create ('keytab', "wallet\nf", $schema, + @trace) + }; + is ($object, undef, 'Creating malformed principal fails'); + if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + is ($@, "invalid principal name wallet\nf\n", ' with the right error'); + } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { + like ($@, qr/^error adding principal wallet\nf/, + ' with the right error'); + } + $object = eval { + Wallet::Object::Keytab->create ('keytab', '', $schema, @trace) + }; + is ($object, undef, 'Creating empty principal fails'); + if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + is ($@, "invalid principal name \n", ' with the right error'); + } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { + like ($@, qr/^error adding principal \@/, ' with the right error'); + } + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + if (defined ($object)) { + ok (defined ($object), 'Creating good principal succeeds'); + } else { + is ($@, '', 'Creating good principal succeeds'); + } + ok ($object->isa ('Wallet::Object::Keytab'), ' and is the right class'); + ok (created ('wallet/one'), ' and the principal was created'); + create ('wallet/two'); + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/two', $schema, + @trace) + }; + if (defined ($object)) { + ok (defined ($object), 'Creating an existing principal succeeds'); + } else { + is ($@, '', 'Creating an existing principal succeeds'); + } + ok ($object->isa ('Wallet::Object::Keytab'), ' and is the right class'); + is ($object->destroy (@trace), 1, ' and destroying it succeeds'); + is ($object->error, undef, ' with no error message'); + ok (! created ('wallet/two'), ' and now it does not exist'); + my @name = qw(keytab wallet-test/one); + $object = eval { Wallet::Object::Keytab->create (@name, $schema, @trace) }; + is ($object, undef, 'Creation without permissions fails'); + like ($@, qr{^error adding principal wallet-test/one\@\Q$realm: }, + ' with the right error'); + + # Now, try retrieving the keytab. + $object = Wallet::Object::Keytab->new ('keytab', 'wallet/one', $schema); + ok (defined ($object), 'Retrieving the object works'); + ok ($object->isa ('Wallet::Object::Keytab'), ' and is the right type'); + is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); + is ($object->get (@trace), undef, ' and get fails'); + is ($object->error, "cannot get keytab:wallet/one: object is locked", + ' because it is locked'); + is ($object->flag_clear ('locked', @trace), 1, + ' and clearing locked works'); + my $data = $object->get (@trace); + if (defined ($data)) { + ok (defined ($data), ' and getting the keytab works'); + } else { + is ($object->error, '', ' and getting the keytab works'); + } + ok (! -f "./keytab.$$", ' and the temporary file was cleaned up'); + ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); + + # For right now, this is the only backend type that we have for which we + # can do a get, so test display of the last download information. + my $expected = <<"EOO"; + Type: keytab + Name: wallet/one + Created by: $user + Created from: $host + Created on: $date + Downloaded by: $user +Downloaded from: $host + Downloaded on: $date +EOO + is ($object->show, $expected, 'Show output is correct'); + + # Test error handling on keytab retrieval. + SKIP: { + skip 'no kadmin program test for Heimdal', 2 + if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; + $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; + $data = $object->get (@trace); + is ($data, undef, 'Cope with a failure to run kadmin'); + like ($object->error, qr{^cannot run /some/nonexistent/file: }, + ' with the right error'); + $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; + } + destroy ('wallet/one'); + $data = $object->get (@trace); + is ($data, undef, 'Getting a keytab for a nonexistent principal fails'); + like ($object->error, + qr{^error creating keytab for wallet/one\@\Q$realm\E: }, + ' with the right error'); + is ($object->destroy (@trace), 1, ' but we can still destroy it'); + + # Test principal deletion on object destruction. + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + ok (defined ($object), 'Creating good principal succeeds'); + ok (created ('wallet/one'), ' and the principal was created'); + SKIP: { + skip 'no kadmin program test for Heimdal', 2 + if $Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal'; + $Wallet::Config::KEYTAB_KADMIN = '/some/nonexistent/file'; + is ($object->destroy (@trace), undef, + ' and destroying it with bad kadmin fails'); + like ($object->error, qr{^cannot run /some/nonexistent/file: }, + ' with the right error'); + $Wallet::Config::KEYTAB_KADMIN = 'kadmin'; + } + is ($object->flag_set ('locked', @trace), 1, ' and setting locked works'); + is ($object->destroy (@trace), undef, ' and destroying it fails'); + is ($object->error, "cannot destroy keytab:wallet/one: object is locked", + ' because it is locked'); + is ($object->flag_clear ('locked', @trace), 1, + ' and clearing locked works'); + is ($object->destroy (@trace), 1, ' and destroying it succeeds'); + ok (! created ('wallet/one'), ' and now it does not exist'); + + # Test history (which should still work after the object is deleted). + $history .= <<"EOO"; +$date create + by $user from $host +$date set flag locked + by $user from $host +$date clear flag locked + by $user from $host +$date get + by $user from $host +$date destroy + by $user from $host +$date create + by $user from $host +$date set flag locked + by $user from $host +$date clear flag locked + by $user from $host +$date destroy + by $user from $host +EOO + is ($object->history, $history, 'History is correct to this point'); + + # Test configuration errors. + undef $Wallet::Config::KEYTAB_FILE; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + is ($object, undef, 'Creating with bad configuration fails'); + is ($@, "keytab object implementation not configured\n", + ' with the right error'); + $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; + undef $Wallet::Config::KEYTAB_PRINCIPAL; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + is ($object, undef, ' likewise with another missing variable'); + is ($@, "keytab object implementation not configured\n", + ' with the right error'); + $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); + undef $Wallet::Config::KEYTAB_REALM; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + is ($object, undef, ' and another'); + is ($@, "keytab object implementation not configured\n", + ' with the right error'); + $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + undef $Wallet::Config::KEYTAB_KRBTYPE; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + is ($object, undef, ' and another'); + is ($@, "keytab object implementation not configured\n", + ' with the right error'); + $Wallet::Config::KEYTAB_KRBTYPE = 'Active Directory'; + $object = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + is ($object, undef, ' and one set to an invalid value'); + is ($@, "unknown KEYTAB_KRBTYPE setting: Active Directory\n", + ' with the right error'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); +} + +# Tests for unchanging support. Skip these if we don't have a keytab or if we +# can't find remctld. +SKIP: { + skip 'no keytab configuration', 31 unless -f 't/data/test.keytab'; + + # Set up our configuration. + $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; + $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); + $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); + $Wallet::Config::KEYTAB_TMP = '.'; + my $realm = $Wallet::Config::KEYTAB_REALM; + my $principal = $Wallet::Config::KEYTAB_PRINCIPAL; + + # Create the objects for testing and set the unchanging flag. + my $one = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + ok (defined ($one), 'Creating wallet/one succeeds'); + is ($one->flag_set ('unchanging', @trace), 1, ' and setting unchanging'); + my $two = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/two', $schema, + @trace); + }; + ok (defined ($two), 'Creating wallet/two succeeds'); + is ($two->flag_set ('unchanging', @trace), 1, ' and setting unchanging'); + + # Finally we can test. First the MIT Kerberos tests. + SKIP: { + skip 'skipping MIT unchanging tests for Heimdal', 16 + if (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'heimdal'); + + # We need remctld and Net::Remctl. + my @path = (split (':', $ENV{PATH}), '/usr/local/sbin', '/usr/sbin'); + my ($remctld) = grep { -x $_ } map { "$_/remctld" } @path; + skip 'remctld not found', 16 unless $remctld; + eval { require Net::Remctl }; + skip 'Net::Remctl not available', 16 if $@; + + # Now spawn our remctld server and get a ticket cache. + remctld_spawn ($remctld, $principal, 't/data/test.keytab', + 't/data/keytab.conf'); + $ENV{KRB5CCNAME} = 'krb5cc_test'; + getcreds ('t/data/test.keytab', $principal); + $ENV{KRB5CCNAME} = 'krb5cc_good'; + + # Do the unchanging tests for MIT Kerberos. + is ($one->get (@trace), undef, 'Get without configuration fails'); + is ($one->error, 'keytab unchanging support not configured', + ' with the right error'); + $Wallet::Config::KEYTAB_REMCTL_CACHE = 'krb5cc_test'; + is ($one->get (@trace), undef, ' and still fails without host'); + is ($one->error, 'keytab unchanging support not configured', + ' with the right error'); + $Wallet::Config::KEYTAB_REMCTL_HOST = 'localhost'; + $Wallet::Config::KEYTAB_REMCTL_PRINCIPAL = $principal; + $Wallet::Config::KEYTAB_REMCTL_PORT = 14373; + is ($one->get (@trace), undef, ' and still fails without ACL'); + is ($one->error, + "cannot retrieve keytab for wallet/one\@$realm: Access denied", + ' with the right error'); + open (ACL, '>', 'test-acl') or die "cannot create test-acl: $!\n"; + print ACL "$principal\n"; + close ACL; + is ($one->get (@trace), 'Keytab for wallet/one', 'Now get works'); + is ($ENV{KRB5CCNAME}, 'krb5cc_good', + ' and we did not nuke the cache name'); + is ($one->get (@trace), 'Keytab for wallet/one', + ' and we get the same thing the second time'); + is ($one->flag_clear ('unchanging', @trace), 1, + 'Clearing the unchanging flag works'); + my $data = $one->get (@trace); + ok (defined ($data), ' and getting the keytab works'); + ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); + is ($two->get (@trace), undef, 'Get for wallet/two does not work'); + is ($two->error, + "cannot retrieve keytab for wallet/two\@$realm: bite me", + ' with the right error'); + is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); + is ($two->destroy (@trace), 1, ' as does destroying wallet/two'); + remctld_stop; + unlink 'krb5cc_good'; + } + + # Now Heimdal. Since the keytab contains timestamps, before testing for + # equality we have to substitute out the timestamps. + SKIP: { + skip 'skipping Heimdal unchanging tests for MIT', 11 + if (lc ($Wallet::Config::KEYTAB_KRBTYPE) eq 'mit'); + my $data = $one->get (@trace); + ok (defined $data, 'Get of unchanging keytab works'); + ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); + my $second = $one->get (@trace); + ok (defined $second, ' and second retrieval also works'); + $data =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; + $second =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; + ok (keytab_valid ($second, 'wallet/one'), ' and the keytab is valid'); + ok (keytab_valid ($data, 'wallet/one'), ' as is the first keytab'); + is ($one->flag_clear ('unchanging', @trace), 1, + 'Clearing the unchanging flag works'); + $data = $one->get (@trace); + ok (defined ($data), ' and getting the keytab works'); + ok (keytab_valid ($data, 'wallet/one'), ' and the keytab is valid'); + $data =~ s/one.{8}/one\000\000\000\000\000\000\000\000/g; + ok ($data ne $second, ' and the new keytab is different'); + is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); + is ($two->destroy (@trace), 1, ' as does destroying wallet/two'); + } + + # Check that history has been updated correctly. + $history .= <<"EOO"; +$date create + by $user from $host +$date set flag unchanging + by $user from $host +$date get + by $user from $host +$date get + by $user from $host +$date clear flag unchanging + by $user from $host +$date get + by $user from $host +$date destroy + by $user from $host +EOO + is ($one->history, $history, 'History is correct to this point'); +} + +# Tests for synchronization support. This code is deactivated at present +# since no synchronization targets are supported, but we want to still test +# the basic stub code. +SKIP: { + skip 'no keytab configuration', 18 unless -f 't/data/test.keytab'; + + # Test setting synchronization attributes, which can also be done without + # configuration. + my $one = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + ok (defined ($one), 'Creating wallet/one succeeds'); + my $expected = <<"EOO"; + Type: keytab + Name: wallet/one + Created by: $user + Created from: $host + Created on: $date +EOO + is ($one->show, $expected, 'Show output displays no attributes'); + is ($one->attr ('foo', [ 'bar' ], @trace), undef, + 'Setting unknown attribute fails'); + is ($one->error, 'unknown attribute foo', ' with the right error'); + my @targets = $one->attr ('foo'); + is (scalar (@targets), 0, ' and getting an unknown attribute fails'); + is ($one->error, 'unknown attribute foo', ' with the right error'); + is ($one->attr ('sync', [ 'kaserver' ], @trace), undef, + ' and setting an unknown sync target fails'); + is ($one->error, 'unsupported synchronization target kaserver', + ' with the right error'); + is ($one->attr ('sync', [ 'kaserver', 'bar' ], @trace), undef, + ' and setting two targets fails'); + is ($one->error, 'only one synchronization target supported', + ' with the right error'); + + # Create a synchronization manually so that we can test the display and + # removal code. + my $sql = "insert into keytab_sync (ks_name, ks_target) values + ('wallet/one', 'kaserver')"; + $dbh->do ($sql); + @targets = $one->attr ('sync'); + is (scalar (@targets), 1, ' and now one target is set'); + is ($targets[0], 'kaserver', ' and it is correct'); + is ($one->error, undef, ' and there is no error'); + $expected = <<"EOO"; + Type: keytab + Name: wallet/one + Synced with: kaserver + Created by: $user + Created from: $host + Created on: $date +EOO + is ($one->show, $expected, ' and show now displays the attribute'); + $history .= <<"EOO"; +$date create + by $user from $host +EOO + is ($one->history, $history, ' and history is correct for attributes'); + is ($one->attr ('sync', [], @trace), 1, + 'Removing the kaserver sync attribute works'); + is ($one->destroy (@trace),1, ' and then destroying wallet/one works'); + $history .= <<"EOO"; +$date remove kaserver from attribute sync + by $user from $host +$date destroy + by $user from $host +EOO + is ($one->history, $history, ' and history is correct for removal'); +} + +# Tests for enctype restriction. +SKIP: { + skip 'no keytab configuration', 36 unless -f 't/data/test.keytab'; + + # Set up our configuration. + $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; + $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); + $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); + $Wallet::Config::KEYTAB_TMP = '.'; + my $realm = $Wallet::Config::KEYTAB_REALM; + my $principal = $Wallet::Config::KEYTAB_PRINCIPAL; + + # Create an object for testing and determine the enctypes we have to work + # with. + my $one = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + if (defined ($one)) { + ok (1, 'Creating wallet/one succeeds'); + } else { + is ($@, '', 'Creating wallet/one succeeds'); + } + my $keytab = $one->get (@trace); + ok (defined ($keytab), ' and retrieving the keytab works'); + my @enctypes = grep { $_ ne 'UNKNOWN' } enctypes ($keytab); + $history .= <<"EOO"; +$date create + by $user from $host +$date get + by $user from $host +EOO + is ($one->history, $history, ' and history is still correct'); + + # No enctypes we recognize? + skip 'no recognized enctypes', 34 unless @enctypes; + + # Set those encryption types and make sure we get back a limited keytab. + is ($one->attr ('enctypes', [ @enctypes ], @trace), 1, + 'Setting enctypes works'); + is ($one->error, undef, ' with no error'); + for my $enctype (@enctypes) { + $history .= "$date add $enctype to attribute enctypes\n"; + $history .= " by $user from $host\n"; + } + my @values = $one->attr ('enctypes'); + is ("@values", "@enctypes", ' and we get back the right enctype list'); + my $eshow = join ("\n" . (' ' x 17), @enctypes); + $eshow =~ s/\s+\z/\n/; + $expected = <<"EOO"; + Type: keytab + Name: wallet/one + Enctypes: $eshow + Created by: $user + Created from: $host + Created on: $date + Downloaded by: $user +Downloaded from: $host + Downloaded on: $date +EOO + is ($one->show, $expected, ' and show now displays the enctype list'); + $keytab = $one->get (@trace); + ok (defined ($keytab), ' and retrieving the keytab still works'); + @values = enctypes ($keytab); + is ("@values", "@enctypes", ' and the keytab has the right keys'); + is ($one->attr ('enctypes', [ 'foo-bar' ], @trace), undef, + 'Setting an unrecognized enctype fails'); + is ($one->error, 'unknown encryption type foo-bar', + ' with the right error message'); + is ($one->show, $expected, ' and we did rollback properly'); + $history .= <<"EOO"; +$date get + by $user from $host +EOO + is ($one->history, $history, 'History is correct to this point'); + + # Now, try testing limiting the enctypes to just one. + SKIP: { + skip 'insufficient recognized enctypes', 14 unless @enctypes > 1; + + is ($one->attr ('enctypes', [ $enctypes[0] ], @trace), 1, + 'Setting a single enctype works'); + for my $enctype (@enctypes) { + next if $enctype eq $enctypes[0]; + $history .= "$date remove $enctype from attribute enctypes\n"; + $history .= " by $user from $host\n"; + } + @values = $one->attr ('enctypes'); + is ("@values", $enctypes[0], ' and we get back the right value'); + $keytab = $one->get (@trace); + ok (defined ($keytab), ' and retrieving the keytab still works'); + if (defined ($keytab)) { + @values = enctypes ($keytab); + is ("@values", $enctypes[0], ' and it has the right enctype'); + } else { + ok (0, ' and it has the right keytab'); + } + is ($one->attr ('enctypes', [ $enctypes[1] ], @trace), 1, + 'Setting a different single enctype works'); + @values = $one->attr ('enctypes'); + is ("@values", $enctypes[1], ' and we get back the right value'); + $keytab = $one->get (@trace); + ok (defined ($keytab), ' and retrieving the keytab still works'); + @values = enctypes ($keytab); + is ("@values", $enctypes[1], ' and it has the right enctype'); + is ($one->attr ('enctypes', [ @enctypes[0..1] ], @trace), 1, + 'Setting two enctypes works'); + @values = $one->attr ('enctypes'); + is ("@values", "@enctypes[0..1]", ' and we get back the right values'); + $keytab = $one->get (@trace); + ok (defined ($keytab), ' and retrieving the keytab still works'); + @values = enctypes ($keytab); + is ("@values", "@enctypes[0..1]", ' and it has the right enctypes'); + + # Check the history trace. Put back all the enctypes for consistent + # status whether or not we skipped this section. + $history .= <<"EOO"; +$date get + by $user from $host +$date remove $enctypes[0] from attribute enctypes + by $user from $host +$date add $enctypes[1] to attribute enctypes + by $user from $host +$date get + by $user from $host +$date add $enctypes[0] to attribute enctypes + by $user from $host +$date get + by $user from $host +EOO + is ($one->attr ('enctypes', [ @enctypes ], @trace), 1, + 'Restoring all enctypes works'); + for my $enctype (@enctypes) { + next if $enctype eq $enctypes[0]; + next if $enctype eq $enctypes[1]; + $history .= "$date add $enctype to attribute enctypes\n"; + $history .= " by $user from $host\n"; + } + is ($one->history, $history, 'History is correct to this point'); + } + + # Test clearing enctypes. + is ($one->attr ('enctypes', [], @trace), 1, 'Clearing enctypes works'); + for my $enctype (@enctypes) { + $history .= "$date remove $enctype from attribute enctypes\n"; + $history .= " by $user from $host\n"; + } + @values = $one->attr ('enctypes'); + ok (@values == 0, ' and now there are no enctypes'); + is ($one->error, undef, ' and no error'); + + # Test deleting enctypes on object destruction. + is ($one->attr ('enctypes', [ $enctypes[0] ], @trace), 1, + 'Setting a single enctype works'); + is ($one->destroy (@trace), 1, ' and destroying the object works'); + $one = eval { + Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, + @trace) + }; + ok (defined ($one), ' as does recreating it'); + @values = $one->attr ('enctypes'); + ok (@values == 0, ' and now there are no enctypes'); + is ($one->error, undef, ' and no error'); + + # All done. Clean up and check history. + is ($one->destroy (@trace), 1, 'Destroying wallet/one works'); + $history .= <<"EOO"; +$date add $enctypes[0] to attribute enctypes + by $user from $host +$date destroy + by $user from $host +$date create + by $user from $host +$date destroy + by $user from $host +EOO + is ($one->history, $history, 'History is correct to this point'); +} + +# Clean up. +$admin->destroy; +END { + unlink ('wallet-db', 'krb5cc_temp', 'krb5cc_test', 'test-acl', 'test-pid'); +} diff --git a/perl/t/object/wa-keyring.t b/perl/t/object/wa-keyring.t new file mode 100755 index 0000000..8d8e1fe --- /dev/null +++ b/perl/t/object/wa-keyring.t @@ -0,0 +1,184 @@ +#!/usr/bin/perl +# +# Tests for the WebAuth keyring object implementation. +# +# Written by Russ Allbery +# Copyright 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use strict; +use warnings; + +use Test::More; + +BEGIN { + eval 'use WebAuth 3.06 qw(WA_KEY_AES WA_AES_128)'; + plan skip_all => 'WebAuth 3.06 required for testing wa-keyring' + if $@; +} + +use POSIX qw(strftime); +use WebAuth::Key 1.01 (); +use WebAuth::Keyring 1.02 (); + +BEGIN { + plan tests => 68; + use_ok('Wallet::Admin'); + use_ok('Wallet::Config'); + use_ok('Wallet::Object::WAKeyring'); +} + +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-keyrings') == 0 or die "cannot remove test-keyrings\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; + +# Create a WebAuth context to use. +my $wa = WebAuth->new; + +# Test error handling in the absence of configuration. +my $object = eval { + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) + }; +ok (defined ($object), 'Creating a basic WebAuth keyring object succeeds'); +ok ($object->isa ('Wallet::Object::WAKeyring'), ' and is the right class'); +is ($object->get (@trace), undef, ' and get fails'); +is ($object->error, 'WebAuth keyring support not configured', + ' with the right error'); +is ($object->store (@trace), undef, ' and store fails'); +is ($object->error, 'WebAuth keyring support not configured', + ' with the right error'); +is ($object->destroy (@trace), 1, ' but destroy succeeds'); + +# Set up our configuration. +mkdir 'test-keyrings' or die "cannot create test-keyrings: $!\n"; +$Wallet::Config::WAKEYRING_BUCKET = 'test-keyrings'; + +# Okay, now we can test. First, the basic object without store. +$object = eval { + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) + }; +ok (defined ($object), 'Creating a basic WebAuth keyring object succeeds'); +ok ($object->isa ('Wallet::Object::WAKeyring'), ' and is the right class'); +my $data = $object->get (@trace); +ok ($data, ' and get succeeds'); +my $keyring = WebAuth::Keyring->decode ($wa, $data); +ok ($keyring->isa ('WebAuth::Keyring'), ' and resulting keyring decodes'); +my @entries = $keyring->entries; +is (scalar (@entries), 3, ' and has three entries'); +is ($entries[0]->creation, 0, 'First has good creation'); +is ($entries[0]->key->type, WA_KEY_AES, ' and key type'); +is ($entries[0]->key->length, WA_AES_128, ' and key length'); +is ($entries[0]->valid_after, 0, ' and validity'); +ok ((time - $entries[1]->creation) < 2, 'Second has good creation'); +is ($entries[1]->key->type, WA_KEY_AES, ' and key type'); +is ($entries[1]->key->length, WA_AES_128, ' and key length'); +ok (($entries[1]->valid_after - time) <= 60 * 60 * 24, + ' and validity (upper)'); +ok (($entries[1]->valid_after - time) > 60 * 60 * 24 - 2, + ' and validity (lower)'); +ok ((time - $entries[2]->creation) < 2, 'Third has good creation'); +is ($entries[2]->key->type, WA_KEY_AES, ' and key type'); +is ($entries[2]->key->length, WA_AES_128, ' and key length'); +ok (($entries[2]->valid_after - time) <= 2 * 60 * 60 * 24, + ' and validity (upper)'); +ok (($entries[2]->valid_after - time) > 2 * 60 * 60 * 24 - 2, + ' and validity (lower)'); +my $data2 = $object->get (@trace); +is ($data2, $data, 'Getting the object again returns the same data'); +is ($object->error, undef, ' with no error'); +is ($object->destroy (@trace), 1, 'Destroying the object succeeds'); + +# Now store something and be sure that we get something reasonable. +$object = eval { + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) + }; +ok (defined ($object), 'Recreating the object succeeds'); +my $key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); +$keyring = WebAuth::Keyring->new ($wa, $key); +$data = $keyring->encode; +is ($object->store ($data, @trace), 1, ' and storing data in it succeeds'); +ok (-d 'test-keyrings/09', ' and the hash bucket was created'); +ok (-f 'test-keyrings/09/test', ' and the file exists'); +is (contents ('test-keyrings/09/test'), $data, ' with the right contents'); +$data = $object->get (@trace); +$keyring = WebAuth::Keyring->decode ($wa, $data); +ok ($keyring->isa ('WebAuth::Keyring'), ' and get returns a valid keyring'); +@entries = $keyring->entries; +is (scalar (@entries), 2, ' and has three entries'); +is ($entries[0]->creation, 0, 'First has good creation'); +is ($entries[0]->key->type, WA_KEY_AES, ' and key type'); +is ($entries[0]->key->length, WA_AES_128, ' and key length'); +is ($entries[0]->valid_after, 0, ' and validity'); +is ($entries[0]->key->data, $key->data, ' and matches the original key'); +ok ((time - $entries[1]->creation) < 2, 'Second has good creation'); +is ($entries[1]->key->type, WA_KEY_AES, ' and key type'); +is ($entries[1]->key->length, WA_AES_128, ' and key length'); +ok (($entries[1]->valid_after - time) <= 2 * 60 * 60 * 24, + ' and validity (upper)'); +ok (($entries[1]->valid_after - time) > 2 * 60 * 60 * 24 - 2, + ' and validity (lower)'); + +# Test pruning. Add another old key and a couple of more current keys to the +# current keyring. +$key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); +$keyring->add (0, 0, $key); +$key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); +$keyring->add (time - 24 * 60 * 60, time - 24 * 60 * 60, $key); +$key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); +$keyring->add (time, time, $key); +$data = $keyring->encode; +is ($object->store ($data, @trace), 1, 'Storing modified keyring succeeds'); +$data = $object->get (@trace); +$keyring = WebAuth::Keyring->decode ($wa, $data); +ok ($keyring->isa ('WebAuth::Keyring'), ' and get returns a valid keyring'); +@entries = $keyring->entries; +is (scalar (@entries), 3, ' and has three entries'); +ok ((time - $entries[0]->creation) < 2, 'First has good creation'); +ok (($entries[0]->valid_after - time) <= 2 * 60 * 60 * 24, + ' and validity (upper)'); +ok (($entries[0]->valid_after - time) > 2 * 60 * 60 * 24 - 2, + ' and validity (lower)'); +ok ((time - $entries[1]->creation) < 24 * 60 * 60 + 2, + 'Second has good creation'); +ok ((time - $entries[1]->valid_after) <= 60 * 60 * 24 + 2, + ' and validity'); +ok ((time - $entries[2]->creation) < 2, 'Third has good creation'); +ok ((time - $entries[2]->valid_after) < 2, ' and validity'); +is ($object->destroy (@trace), 1, 'Destroying the object succeeds'); + +# Test error handling in the file store. +system ('rm -r test-keyrings') == 0 or die "cannot remove test-keyrings\n"; +$object = eval { + Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) + }; +ok (defined ($object), 'Recreating the object succeeds'); +is ($object->get (@trace), undef, ' but retrieving it fails'); +like ($object->error, qr/^cannot create keyring bucket 09: /, + ' with the right error'); +is ($object->store ("foo\n", @trace), undef, ' and store fails'); +like ($object->error, qr/^cannot create keyring bucket 09: /, + ' with the right error'); +is ($object->destroy (@trace), 1, ' but destroying the object succeeds'); + +# Clean up. +$admin->destroy; +END { + unlink ('wallet-db'); +} diff --git a/perl/t/pod-spelling.t b/perl/t/pod-spelling.t deleted file mode 100755 index 577a99e..0000000 --- a/perl/t/pod-spelling.t +++ /dev/null @@ -1,74 +0,0 @@ -#!/usr/bin/perl -w -# -# Check for spelling errors in POD documentation -# -# Checks all POD files in the tree for spelling problems using Pod::Spell and -# either aspell or ispell. aspell is preferred. This test is disabled unless -# RRA_MAINTAINER_TESTS is set, since spelling dictionaries vary too much -# between environments. -# -# Copyright 2008, 2009 Russ Allbery -# -# See LICENSE for licensing terms. - -use strict; -use Test::More; - -# Skip all spelling tests unless the maintainer environment variable is set. -plan skip_all => 'Spelling tests only run for maintainer' - unless $ENV{RRA_MAINTAINER_TESTS}; - -# Load required Perl modules. -eval 'use Test::Pod 1.00'; -plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; -eval 'use Pod::Spell'; -plan skip_all => 'Pod::Spell required to test POD spelling' if $@; - -# Locate a spell-checker. hunspell is not currently supported due to its lack -# of support for contractions (at least in the version in Debian). -my @spell; -my %options = (aspell => [ qw(-d en_US --home-dir=./ list) ], - ispell => [ qw(-d american -l -p /dev/null) ]); -SEARCH: for my $program (qw/aspell ispell/) { - for my $dir (split ':', $ENV{PATH}) { - if (-x "$dir/$program") { - @spell = ("$dir/$program", @{ $options{$program} }); - } - last SEARCH if @spell; - } -} -plan skip_all => 'aspell or ispell required to test POD spelling' - unless @spell; - -# Prerequisites are satisfied, so we're going to do some testing. Figure out -# what POD files we have and from that develop our plan. -$| = 1; -my @pod = all_pod_files (); -plan tests => scalar @pod; - -# Finally, do the checks. -for my $pod (@pod) { - my $child = open (CHILD, '-|'); - if (not defined $child) { - die "Cannot fork: $!\n"; - } elsif ($child == 0) { - my $pid = open (SPELL, '|-', @spell) or die "Cannot run @spell: $!\n"; - open (POD, '<', $pod) or die "Cannot open $pod: $!\n"; - my $parser = Pod::Spell->new; - $parser->parse_from_filehandle (\*POD, \*SPELL); - close POD; - close SPELL; - exit ($? >> 8); - } else { - my @words = ; - close CHILD; - SKIP: { - skip "@spell failed for $pod", 1 unless $? == 0; - for (@words) { - s/^\s+//; - s/\s+$//; - } - is ("@words", '', $pod); - } - } -} diff --git a/perl/t/pod.t b/perl/t/pod.t deleted file mode 100755 index dfcf88e..0000000 --- a/perl/t/pod.t +++ /dev/null @@ -1,15 +0,0 @@ -#!/usr/bin/perl -w -# -# Test POD formatting for the wallet Perl modules. -# -# Written by Russ Allbery -# Copyright 2007, 2010 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use strict; -use Test::More; -eval 'use Test::Pod 1.00'; -plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; -all_pod_files_ok (); diff --git a/perl/t/policy/stanford.t b/perl/t/policy/stanford.t new file mode 100755 index 0000000..555086c --- /dev/null +++ b/perl/t/policy/stanford.t @@ -0,0 +1,260 @@ +#!/usr/bin/perl +# +# Tests for the Stanford naming policy. +# +# The naming policy code is included primarily an example for non-Stanford +# sites, but it's used at Stanford and this test suite is used to verify +# behavior at Stanford. +# +# Written by Russ Allbery +# Copyright 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use 5.008; +use strict; +use warnings; + +use Test::More tests => 101; + +use lib 't/lib'; +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::Server'); +} + +# 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 + group-example-01/cgi afs/testcell.stanford.edu); + +# Various invalid keytab names. +my @INVALID_KEYTABS = qw(example host/example service/example.stanford.edu + thisistoolong/cgi not-valid/cgi unknown/example.stanford.edu + afs/testcell); + +# Various valid file names. +my @VALID_FILES = qw(htpasswd/example.stanford.edu/web + password-ipmi/example.stanford.edu + password-root/example.stanford.edu + password-tivoli/example.stanford.edu + ssh-dsa/example.stanford.edu + ssh-rsa/example.stanford.edu + ssl-key/example.stanford.edu + ssl-key/example.stanford.edu/mysql + ssl-keypair/example.stanford.edu + ssl-keypair/example.stanford.edu/mysql + tivoli-key/example.stanford.edu + config/its-idg/example/foo + db/its-idg/example/s_foo + gpg-key/its-idg/debian + password/its-idg/example/backup + properties/its-idg/accounts + properties/its-idg/accounts/sponsorship + ssl-keystore/its-idg/accounts + ssl-keystore/its-idg/accounts/sponsorship + ssl-pkcs12/its-idg/accounts + ssl-pkcs12/its-idg/accounts/sponsorship); + +# Various valid legacy file names. +my @VALID_LEGACY_FILES = qw(apps-example-config-file crcsg-example-db-s_example + idg-debian-gpg-key idg-devnull-password-root sulair-accounts-properties + idg-accounts-ssl-keystore idg-accounts-ssl-pkcs12 + crcsg-example-htpasswd-web sulair-example-password-ipmi + sulair-example-password-root sulair-example-password-tivoli + sulair-example-ssh-dsa sulair-example-ssh-rsa idg-mdm-ssl-key + idg-openafs-tivoli-key); + +# Various invalid file names. +my @INVALID_FILES = qw(unknown foo-example-ssh-rsa idg-accounts-foo !!bad + htpasswd/example.stanford.edu htpasswd/example password-root/example + password-root/example.stanford.edu/foo ssh-foo/example.stanford.edu + tivoli-key/example.stanford.edu/foo tivoli-key config config/its-idg + config/its-idg/example db/its-idg/example password/its-idg/example + its-idg/password/example properties//accounts properties/its-idg/ + ssl-keystore/idg/accounts); + +# Global variables for the wallet server setup. +my $ADMIN = 'admin@EXAMPLE.COM'; +my $HOST = 'localhost'; +my @TRACE = ($ADMIN, $HOST); + +# Start by testing lots of straightforward naming validity. +for my $name (@VALID_KEYTABS) { + is(verify_name('keytab', $name), undef, "Valid keytab $name"); +} +for my $name (@INVALID_KEYTABS) { + isnt(verify_name('keytab', $name), undef, "Invalid keytab $name"); +} +for my $name (@VALID_FILES) { + is(verify_name('file', $name), undef, "Valid file $name"); +} +for my $name (@VALID_LEGACY_FILES) { + is(verify_name('file', $name), undef, "Valid file $name"); +} +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'); + +# 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' +); + +# 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' +); + +# 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'); + +# 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' +); + +# 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 a type that isn't host-based. +is(default_owner('keytab', 'service/foo'), undef, + 'No default owner for service/foo'); + +# Check for an unknown object type. +is(default_owner('unknown', 'foo'), undef, + 'No default owner for unknown type'); + +# 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 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; +END { + unlink 'wallet-db'; +} diff --git a/perl/t/report.t b/perl/t/report.t deleted file mode 100755 index 9563362..0000000 --- a/perl/t/report.t +++ /dev/null @@ -1,330 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the wallet reporting interface. -# -# Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 197; - -use Wallet::Admin; -use Wallet::Report; -use Wallet::Server; - -use lib 't/lib'; -use Util; - -# Use Wallet::Admin to set up the database. -db_setup; -my $admin = eval { Wallet::Admin->new }; -is ($@, '', 'Wallet::Admin creation did not die'); -is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, - 'Database initialization succeeded'); -$admin->register_object ('base', 'Wallet::Object::Base'); -$admin->register_verifier ('base', 'Wallet::ACL::Base'); - -# We have an empty database, so we should see no objects and one ACL. -my $report = eval { Wallet::Report->new }; -is ($@, '', 'Wallet::Report creation did not die'); -ok ($report->isa ('Wallet::Report'), ' and returned the right class'); -my @objects = $report->objects; -is (scalar (@objects), 0, 'No objects in the database'); -is ($report->error, undef, ' and no error'); -my @acls = $report->acls; -is (scalar (@acls), 1, 'One ACL in the database'); -is ($acls[0][0], 1, ' and that is ACL ID 1'); -is ($acls[0][1], 'ADMIN', ' with the right name'); - -# Create an object. -$server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; -is ($@, '', 'Creating a server instance did not die'); -is ($server->create ('base', 'service/admin'), 1, - ' and creating base:service/admin succeeds'); - -# Now, we should see one object. -@objects = $report->objects; -is (scalar (@objects), 1, ' and now there is one object'); -is ($objects[0][0], 'base', ' with the right type'); -is ($objects[0][1], 'service/admin', ' and the right name'); - -# That object should be unused. -@objects = $report->objects ('unused'); -is (scalar (@objects), 1, ' and that object is unused'); -is ($objects[0][0], 'base', ' with the right type'); -is ($objects[0][1], 'service/admin', ' and the right name'); - -# Create another ACL. -is ($server->acl_create ('first'), 1, 'ACL creation succeeds'); -@acls = $report->acls; -is (scalar (@acls), 2, ' and now there are two ACLs'); -is ($acls[0][0], 1, ' and the first ID is correct'); -is ($acls[0][1], 'ADMIN', ' and the first name is correct'); -is ($acls[1][0], 2, ' and the second ID is correct'); -is ($acls[1][1], 'first', ' and the second name is correct'); - -# Delete that ACL and create another. -is ($server->acl_create ('second'), 1, 'Second ACL creation succeeds'); -is ($server->acl_destroy ('first'), 1, ' and deletion of the first succeeds'); -@acls = $report->acls; -is (scalar (@acls), 2, ' and there are still two ACLs'); -is ($acls[0][0], 1, ' and the first ID is still the same'); -is ($acls[0][1], 'ADMIN', ' and the first name is still the same'); -is ($acls[1][0], 3, ' but the second ID has changed'); -is ($acls[1][1], 'second', ' and the second name is correct'); - -# Currently, we have no owners, so we should get an empty owner report. -my @lines = $report->owners ('%', '%'); -is (scalar (@lines), 0, 'Owner report is currently empty'); -is ($report->error, undef, ' and there is no error'); - -# Set an owner and make sure we now see something in the report. -is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, - 'Setting an owner works'); -@lines = $report->owners ('%', '%'); -is (scalar (@lines), 1, ' and now there is one owner in the report'); -is ($lines[0][0], 'krb5', ' with the right scheme'); -is ($lines[0][1], 'admin@EXAMPLE.COM', ' and the right identifier'); -@lines = $report->owners ('keytab', '%'); -is (scalar (@lines), 0, 'Owners of keytabs is empty'); -is ($report->error, undef, ' with no error'); -@lines = $report->owners ('base', 'foo/%'); -is (scalar (@lines), 0, 'Owners of base foo/* objects is empty'); -is ($report->error, undef, ' with no error'); - -# Create a second object with the same owner. -is ($server->create ('base', 'service/foo'), 1, - 'Creating base:service/foo succeeds'); -is ($server->owner ('base', 'service/foo', 'ADMIN'), 1, - ' and setting the owner to the same value works'); -@lines = $report->owners ('base', 'service/%'); -is (scalar (@lines), 1, ' and there is still owner in the report'); -is ($lines[0][0], 'krb5', ' with the right scheme'); -is ($lines[0][1], 'admin@EXAMPLE.COM', ' and the right identifier'); - -# Both objects should now show as unused. -@objects = $report->objects ('unused'); -is (scalar (@objects), 2, 'There are now two unused objects'); -is ($objects[0][0], 'base', ' and the first has the right type'); -is ($objects[0][1], 'service/admin', ' and the right name'); -is ($objects[1][0], 'base', ' and the second has the right type'); -is ($objects[1][1], 'service/foo', ' and the right name'); - -# Change the owner of the second object to an empty ACL. -is ($server->owner ('base', 'service/foo', 'second'), 1, - ' and changing the owner to an empty ACL works'); -@lines = $report->owners ('base', '%'); -is (scalar (@lines), 1, ' and there is still owner in the report'); -is ($lines[0][0], 'krb5', ' with the right scheme'); -is ($lines[0][1], 'admin@EXAMPLE.COM', ' and the right identifier'); - -# Add a few things to the second ACL to see what happens. -is ($server->acl_add ('second', 'base', 'foo'), 1, - 'Adding an ACL line to the new ACL works'); -is ($server->acl_add ('second', 'base', 'bar'), 1, - ' and adding another ACL line to the new ACL works'); -@lines = $report->owners ('base', '%'); -is (scalar (@lines), 3, ' and now there are three owners in the report'); -is ($lines[0][0], 'base', ' first has the right scheme'); -is ($lines[0][1], 'bar', ' and the right identifier'); -is ($lines[1][0], 'base', ' second has the right scheme'); -is ($lines[1][1], 'foo', ' and the right identifier'); -is ($lines[2][0], 'krb5', ' third has the right scheme'); -is ($lines[2][1], 'admin@EXAMPLE.COM', ' and the right identifier'); - -# Test ownership and other ACL values. Change one keytab to be not owned by -# ADMIN, but have group permission on it. We'll need a third object neither -# owned by ADMIN or with any permissions from it. -is ($server->create ('base', 'service/null'), 1, - 'Creating base:service/null succeeds'); -is ($server->acl ('base', 'service/foo', 'get', 'ADMIN'), 1, - 'Changing the get ACL for the search also does'); -@lines = $report->objects ('owner', 'ADMIN'); -is (scalar (@lines), 1, 'Searching for objects owned by ADMIN finds one'); -is ($lines[0][0], 'base', ' and it has the right type'); -is ($lines[0][1], 'service/admin', ' and the right name'); -@lines = $report->objects ('owner', 'null'); -is (scalar (@lines), 1, 'Searching for objects with no set owner finds one'); -is ($lines[0][0], 'base', ' and it has the right type'); -is ($lines[0][1], 'service/null', ' and the right name'); -@lines = $report->objects ('acl', 'ADMIN'); -is (scalar (@lines), 2, 'ADMIN has any rights at all on two objects'); -is ($lines[0][0], 'base', ' and the first has the right type'); -is ($lines[0][1], 'service/admin', ' and the right name'); -is ($lines[1][0], 'base', ' and the second has the right type'); -is ($lines[1][1], 'service/foo', ' and the right name'); - -# Listing objects of a specific type. -@lines = $report->objects ('type', 'base'); -is (scalar (@lines), 3, 'Searching for all objects of type base finds three'); -is ($lines[0][0], 'base', ' and the first has the right type'); -is ($lines[0][1], 'service/admin', ' and the right name'); -is ($lines[1][0], 'base', ' and the second has the right type'); -is ($lines[1][1], 'service/foo', ' and the right name'); -is ($lines[2][0], 'base', ' and the third has the right type'); -is ($lines[2][1], 'service/null', ' and the right name'); -@lines = $report->objects ('type', 'keytab'); -is (scalar (@lines), 0, 'Searching for all objects of type keytab finds none'); - -# Test setting a flag, searching for objects with it, and then clearing it. -is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, - 'Setting a flag works'); -@lines = $report->objects ('flag', 'unchanging'); -is (scalar (@lines), 1, 'Searching for all objects with that flag finds one'); -is ($lines[0][0], 'base', ' and it has the right type'); -is ($lines[0][1], 'service/admin', ' and the right name'); -is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, - 'Clearing the flag works'); -@lines = $report->objects ('flag', 'unchanging'); -is (scalar (@lines), 0, ' and now there are no objects in the report'); -is ($report->error, undef, ' with no error'); - -# All of our ACLs should be in use. -@lines = $report->acls ('unused'); -is (scalar (@lines), 0, 'Searching for unused ACLs returns nothing'); -is ($report->error, undef, ' with no error'); - -# Create some unused ACLs that should show up in the report. -is ($server->acl_create ('third'), 1, 'Creating an empty ACL succeeds'); -is ($server->acl_create ('fourth'), 1, ' and creating another succeeds'); -@lines = $report->acls ('unused'); -is (scalar (@lines), 2, ' and now we see two unused ACLs'); -is ($server->error, undef, ' with no error'); -is ($lines[0][0], 4, ' and the first has the right ID'); -is ($lines[0][1], 'third', ' and the right name'); -is ($lines[1][0], 5, ' and the second has the right ID'); -is ($lines[1][1], 'fourth', ' and the right name'); - -# Use one of those ACLs and ensure it drops out of the report. Test that we -# try all of the possible ACL types. -for my $type (qw/get store show destroy flags/) { - is ($server->acl ('base', 'service/admin', $type, 'fourth'), 1, - "Setting ACL $type to fourth succeeds"); - @lines = $report->acls ('unused'); - is (scalar (@lines), 1, ' and now we see only one unused ACL'); - is ($lines[0][0], 4, ' with the right ID'); - is ($lines[0][1], 'third', ' and the right name'); - is ($server->acl ('base', 'service/admin', $type, ''), 1, - ' and clearing the ACL succeeds'); - @lines = $report->acls ('unused'); - is (scalar (@lines), 2, ' and now we see two unused ACLs'); - is ($lines[0][0], 4, ' and the first has the right ID'); - is ($lines[0][1], 'third', ' and the right name'); - is ($lines[1][0], 5, ' and the second has the right ID'); - is ($lines[1][1], 'fourth', ' and the right name'); -} - -# The naming audit returns nothing if there's no naming policy. -@lines = $report->audit ('objects', 'name'); -is (scalar (@lines), 0, 'Searching for naming violations finds none'); -is ($report->error, undef, ' with no error'); - -# Set a naming policy and then look for objects that fail that policy. We -# have to deactivate this policy until now so that it doesn't prevent the -# creation of that name originally, which is the reason for the variable -# reference. -our $naming_active = 1; -package Wallet::Config; -sub verify_name { - my ($type, $name) = @_; - return unless $naming_active; - return 'admin not allowed' if $name eq 'service/admin'; - return; -} -package main; -@lines = $report->audit ('objects', 'name'); -is (scalar (@lines), 1, 'Searching for naming violations finds one'); -is ($lines[0][0], 'base', ' and the first has the right type'); -is ($lines[0][1], 'service/admin', ' and the right name'); - -# Set an ACL naming policy and then look for objects that fail that policy. -# Use the same deactivation trick as above. -package Wallet::Config; -sub verify_acl_name { - my ($name) = @_; - return unless $naming_active; - return 'second not allowed' if $name eq 'second'; - return; -} -package main; -@lines = $report->audit ('acls', 'name'); -is (scalar (@lines), 1, 'Searching for ACL naming violations finds one'); -is ($lines[0][0], 3, ' and the first has the right ID'); -is ($lines[0][1], 'second', ' and the right name'); - -# Set up a file bucket so that we can create an object we can retrieve. -system ('rm -rf test-files') == 0 or die "cannot remove test-files\n"; -mkdir 'test-files' or die "cannot create test-files: $!\n"; -$Wallet::Config::FILE_BUCKET = 'test-files'; - -# Create a file object and ensure that it shows up in the unused list. -is ($server->create ('file', 'test'), 1, 'Creating file:test succeeds'); -is ($server->owner ('file', 'test', 'ADMIN'), 1, - ' and setting its owner works'); -@objects = $report->objects ('unused'); -is (scalar (@objects), 4, 'There are now four unused objects'); -is ($objects[0][0], 'base', ' and the first has the right type'); -is ($objects[0][1], 'service/admin', ' and the right name'); -is ($objects[1][0], 'base', ' and the second has the right type'); -is ($objects[1][1], 'service/foo', ' and the right name'); -is ($objects[2][0], 'base', ' and the third has the right type'); -is ($objects[2][1], 'service/null', ' and the right name'); -is ($objects[3][0], 'file', ' and the fourth has the right type'); -is ($objects[3][1], 'test', ' and the right name'); - -# Store something and retrieve it, and then check that the file object fell -# off of the list. -is ($server->store ('file', 'test', 'Some data'), 1, - 'Storing data in file:test succeeds'); -is ($server->get ('file', 'test'), 'Some data', ' and retrieving it works'); -@objects = $report->objects ('unused'); -is (scalar (@objects), 3, ' and now there are three unused objects'); -is ($objects[0][0], 'base', ' and the first has the right type'); -is ($objects[0][1], 'service/admin', ' and the right name'); -is ($objects[1][0], 'base', ' and the second has the right type'); -is ($objects[1][1], 'service/foo', ' and the right name'); -is ($objects[2][0], 'base', ' and the third has the right type'); -is ($objects[2][1], 'service/null', ' and the right name'); - -# The third and fourth ACLs are both empty and should show up as duplicate. -@acls = $report->acls ('duplicate'); -is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); -is (scalar (@{ $acls[0] }), 2, ' with two members'); -is ($acls[0][0], 'fourth', ' and the first member is correct'); -is ($acls[0][1], 'third', ' and the second member is correct'); - -# Add the same line to both ACLs. They should still show up as duplicate. -is ($server->acl_add ('fourth', 'base', 'bar'), 1, - 'Adding a line to the fourth ACL works'); -is ($server->acl_add ('third', 'base', 'bar'), 1, - ' and adding a line to the third ACL works'); -@acls = $report->acls ('duplicate'); -is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); -is (scalar (@{ $acls[0] }), 2, ' with two members'); -is ($acls[0][0], 'fourth', ' and the first member is correct'); -is ($acls[0][1], 'third', ' and the second member is correct'); - -# Add another line to the third ACL. Now we match second. -is ($server->acl_add ('third', 'base', 'foo'), 1, - 'Adding another line to the third ACL works'); -@acls = $report->acls ('duplicate'); -is (scalar (@acls), 1, 'There is one set of duplicate ACLs'); -is (scalar (@{ $acls[0] }), 2, ' with two members'); -is ($acls[0][0], 'second', ' and the first member is correct'); -is ($acls[0][1], 'third', ' and the second member is correct'); - -# Add yet another line to the third ACL. Now all ACLs are distinct. -is ($server->acl_add ('third', 'base', 'baz'), 1, - 'Adding another line to the third ACL works'); -@acls = $report->acls ('duplicate'); -is (scalar (@acls), 0, 'There are no duplicate ACLs'); -is ($report->error, undef, ' and no error'); - -# Clean up. -$admin->destroy; -system ('rm -r test-files') == 0 or die "cannot remove test-files\n"; -END { - unlink 'wallet-db'; -} diff --git a/perl/t/server.t b/perl/t/server.t deleted file mode 100755 index 9026439..0000000 --- a/perl/t/server.t +++ /dev/null @@ -1,1040 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the wallet server API. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011, 2012, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 382; - -use POSIX qw(strftime); -use Wallet::Admin; -use Wallet::Config; -use Wallet::Schema; -use Wallet::Server; - -use lib 't/lib'; -use Util; - -# Some global defaults to use. -my $admin = 'admin@EXAMPLE.COM'; -my $user1 = 'alice@EXAMPLE.COM'; -my $user2 = 'bob@EXAMPLE.COM'; -my $host = 'localhost'; -my @trace = ($admin, $host); - -# Use Wallet::Admin to set up the database. -db_setup; -my $setup = eval { Wallet::Admin->new }; -is ($@, '', 'Database initialization did not die'); -is ($setup->reinitialize ($admin), 1, 'Database initialization succeeded'); - -# Now test the new method. -$server = eval { Wallet::Server->new (@trace) }; -is ($@, '', 'Reopening with new did not die'); -ok ($server->isa ('Wallet::Server'), ' and returned the right class'); -my $schema = $server->schema; -ok (defined ($schema), ' and returns a defined schema object'); - -# Allow creation of base objects for testing purposes. -$setup->register_object ('base', 'Wallet::Object::Base'); - -# We're currently running as the administrator, so everything should succeed. -# Set up a bunch of data for us to test with, starting with some ACLs. Test -# the error handling while we're at it. -is ($server->acl_show ('ADMIN'), - "Members of ACL ADMIN (id: 1) are:\n krb5 $admin\n", - 'Showing the ADMIN ACL works'); -is ($server->acl_show (1), - "Members of ACL ADMIN (id: 1) are:\n krb5 $admin\n", - ' including by number'); -my $history = <<"EOO"; -DATE create - by $admin from $host -DATE add krb5 $admin - by $admin from $host -EOO -my $result = $server->acl_history ('ADMIN'); -$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($result, $history, ' and displaying history works'); -$result = $server->acl_history (1); -$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($result, $history, ' including by number'); -is ($server->acl_create (3), undef, 'Cannot create ACL with a numeric name'); -is ($server->error, 'ACL name may not be all numbers', - ' and returns the right error'); -is ($server->acl_check ('user1'), 0, 'user1 ACL does not exist'); -is ($server->acl_create ('user1'), 1, 'Can create regular ACL'); -is ($server->acl_check ('user1'), 1, 'user1 now exists'); -is ($server->acl_show ('user1'), "Members of ACL user1 (id: 2) are:\n", - ' and show works'); -is ($server->acl_create ('user1'), undef, ' but not twice'); -like ($server->error, qr/^cannot create ACL user1: /, - ' and returns a good error'); -is ($server->acl_create ('ADMIN'), undef, ' and cannot create ADMIN'); -like ($server->error, qr/^cannot create ACL ADMIN: /, - ' and returns a good error'); -is ($server->acl_create ('user2'), 1, 'Create another ACL'); -is ($server->acl_create ('both'), 1, ' and one for both users'); -is ($server->acl_create ('test2'), 1, ' and an empty one'); -is ($server->acl_create ('test'), 1, ' and another test one'); -is ($server->acl_rename ('empty', 'test'), undef, - 'Cannot rename nonexistent ACL'); -is ($server->error, 'ACL empty not found', ' and returns the right error'); -is ($server->acl_rename ('test', 'test2'), undef, - ' and cannot rename to an existing name'); -like ($server->error, qr/^cannot rename ACL 6 to test2: /, - ' and returns the right error'); -is ($server->acl_rename ('test', 'empty'), 1, 'Renaming does work'); -is ($server->acl_rename ('test', 'empty'), undef, ' but not twice'); -is ($server->error, 'ACL test not found', ' and returns the right error'); -is ($server->acl_show ('test'), undef, ' and show fails'); -is ($server->error, 'ACL test not found', ' and returns the right error'); -is ($server->acl_history ('test'), undef, ' and history fails'); -is ($server->error, 'ACL test not found', ' and returns the right error'); -is ($server->acl_destroy ('test'), undef, 'Destroying the old name fails'); -is ($server->error, 'ACL test not found', ' and returns the right error'); -is ($server->acl_check ('test2'), 1, ' but the other ACL exists'); -is ($server->acl_destroy ('test2'), 1, ' and destroying it works'); -is ($server->acl_destroy ('test2'), undef, ' but not twice'); -is ($server->acl_check ('test2'), 0, ' and now it does not exist'); -is ($server->error, 'ACL test2 not found', ' and returns the right error'); -is ($server->acl_add ('user1', 'krb4', $user1), undef, - 'Adding with a bad scheme fails'); -is ($server->error, 'unknown ACL scheme krb4', ' with the right error'); -is ($server->acl_add ('user1', 'krb5', $user1), 1, - ' but works with the right scheme'); -is ($server->acl_add ('user2', 'krb5', $user2), 1, 'Add another entry'); -is ($server->acl_add ('both', 'krb5', $user1), 1, ' and another'); -is ($server->acl_add ('both', 'krb5', $user2), 1, - ' and another to the same ACL'); -is ($server->acl_show ('both'), - "Members of ACL both (id: 4) are:\n krb5 $user1\n krb5 $user2\n", - ' and show returns the correct result'); -$history = <<"EOO"; -DATE create - by $admin from $host -DATE add krb5 $user1 - by $admin from $host -DATE add krb5 $user2 - by $admin from $host -EOO -$result = $server->acl_history ('both'); -$result =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($result, $history, ' as does history'); -is ($server->acl_add ('empty', 'krb5', $user1), 1, ' and another to empty'); -is ($server->acl_add ('test', 'krb5', $user1), undef, - ' but adding to an unknown ACL fails'); -is ($server->error, 'ACL test not found', ' and returns the right error'); -is ($server->acl_remove ('test', 'krb5', $user1), undef, - 'Removing from a nonexistent ACL fails'); -is ($server->error, 'ACL test not found', ' and returns the right error'); -is ($server->acl_remove ('empty', 'krb5', $user2), undef, - ' and removing an entry not there fails'); -is ($server->error, - "cannot remove krb5:$user2 from 6: entry not found in ACL", - ' and returns the right error'); -is ($server->acl_show ('empty'), - "Members of ACL empty (id: 6) are:\n krb5 $user1\n", - ' and show returns the correct status'); -is ($server->acl_remove ('empty', 'krb5', $user1), 1, - ' but removing a good one works'); -is ($server->acl_remove ('empty', 'krb5', $user1), undef, - ' but does not work twice'); -is ($server->error, - "cannot remove krb5:$user1 from 6: entry not found in ACL", - ' and returns the right error'); -is ($server->acl_show ('empty'), "Members of ACL empty (id: 6) are:\n", - ' and show returns the correct status'); - -# Make sure we can't cripple the ADMIN ACL. -is ($server->acl_destroy ('ADMIN'), undef, 'Cannot destroy the ADMIN ACL'); -is ($server->error, 'cannot destroy the ADMIN ACL', ' with the right error'); -is ($server->acl_rename ('ADMIN', 'foo'), undef, ' or rename it'); -is ($server->error, 'cannot rename the ADMIN ACL', ' with the right error'); -is ($server->acl_remove ('ADMIN', 'krb5', $admin), undef, - ' or remove its last entry'); -is ($server->error, 'cannot remove last ADMIN ACL entry', - ' with the right error'); -is ($server->acl_add ('ADMIN', 'krb5', $user1), 1, - ' but we can add another entry'); -is ($server->acl_remove ('ADMIN', 'krb5', $user1), 1, ' and then remove it'); -is ($server->acl_remove ('ADMIN', 'krb5', $user1), undef, - ' and remove a user not on it'); -is ($server->error, - "cannot remove krb5:$user1 from 1: entry not found in ACL", - ' and get the right error'); - -# Now, create a few objects to use for testing and test the object API while -# we're at it. -is ($server->create ('base', 'service/admin'), 1, - 'Creating an object works'); -is ($server->create ('base', 'service/admin'), undef, ' but not twice'); -like ($server->error, qr{^cannot create object base:service/admin: }, - ' and returns the right error'); -is ($server->check ('base', 'service/admin'), 1, ' and check works'); -is ($server->create ('srvtab', 'service.admin'), undef, - 'Creating an unknown object fails'); -is ($server->error, 'unknown object type srvtab', ' with the right error'); -is ($server->check ('srvtab', 'service.admin'), undef, ' and check fails'); -is ($server->error, 'unknown object type srvtab', ' with the right error'); -is ($server->create ('', 'service.admin'), undef, - ' and likewise with an empty type'); -is ($server->error, 'unknown object type ', ' with the right error'); -is ($server->create ('base', 'service/user1'), 1, - ' but we can create a base object'); -is ($server->create ('base', 'service/user2'), 1, ' and another'); -is ($server->create ('base', 'service/both'), 1, ' and another'); -is ($server->create ('base', 'service/test'), 1, ' and another'); -is ($server->create ('base', ''), undef, ' but not with an empty name'); -is ($server->error, 'invalid object name', ' with the right error'); -is ($server->destroy ('base', 'service/none'), undef, - 'Destroying an unknown object fails'); -is ($server->error, 'cannot find base:service/none', ' with the right error'); -is ($server->destroy ('srvtab', 'service/test'), undef, - ' and destroying an unknown type fails'); -is ($server->error, 'unknown object type srvtab', ' with a different error'); -is ($server->destroy ('base', 'service/test'), 1, - ' but destroying a good object works'); -is ($server->check ('base', 'service/test'), 0, - ' and now check says it is not there'); -is ($server->destroy ('base', 'service/test'), undef, ' but not twice'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); - -# Test manipulating comments. -is ($server->comment ('base', 'service/test'), undef, - 'Retrieving comment on an unknown object fails'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->comment ('base', 'service/test', 'this is a comment'), undef, - ' and setting it also fails'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->comment ('base', 'service/admin'), undef, - 'Retrieving comment for the right object returns undef'); -is ($server->error, undef, ' but there is no error'); -is ($server->comment ('base', 'service/admin', 'this is a comment'), 1, - ' and we can set it'); -is ($server->comment ('base', 'service/admin'), 'this is a comment', - ' and get the value back'); -is ($server->comment ('base', 'service/admin', ''), 1, ' and clear it'); -is ($server->comment ('base', 'service/admin'), undef, ' and now it is gone'); -is ($server->error, undef, ' and still no error'); - -# Test manipulating expires. -my $now = strftime ('%Y-%m-%d %T', localtime time); -is ($server->expires ('base', 'service/test'), undef, - 'Retrieving expires on an unknown object fails'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->expires ('base', 'service/test', $now), undef, - ' and setting it also fails'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->expires ('base', 'service/admin'), undef, - 'Retrieving expires for the right object returns undef'); -is ($server->error, undef, ' but there is no error'); -is ($server->expires ('base', 'service/admin', $now), 1, - ' and we can set it'); -is ($server->expires ('base', 'service/admin'), $now, - ' and get the value back'); -is ($server->expires ('base', 'service/admin', ''), 1, ' and clear it'); -is ($server->expires ('base', 'service/admin'), undef, ' and now it is gone'); -is ($server->error, undef, ' and still no error'); - -# Test attributes. -is ($server->attr ('base', 'service/admin', 'foo'), undef, - 'Getting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but called the method'); -is ($server->attr ('base', 'service/admin', 'foo', 'foo'), undef, - ' and setting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' and called the method'); - -# Because we're admin, we should be able to show one of these objects, but we -# still shouldn't be able to get or store since there are no ACLs. -is ($server->show ('base', 'service/test'), undef, - 'Cannot show nonexistent object'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -my $show = $server->show ('base', 'service/admin'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/; -my $expected = <<"EOO"; - Type: base - Name: service/admin - Created by: $admin - Created from: $host - Created on: 0 -EOO -is ($show, $expected, ' but showing an existing object works'); -is ($server->get ('base', 'service/admin'), undef, 'Getting an object fails'); -is ($server->error, "$admin not authorized to get base:service/admin", - ' with the right error'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and storing the object also fails'); -is ($server->error, "$admin not authorized to store base:service/admin", - ' with the right error'); - -# Grant only the get ACL, which should give us partial permissions. -is ($server->acl ('base', 'service/test', 'get', 'ADMIN'), undef, - 'Setting ACL on unknown object fails'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->acl ('base', 'service/admin', 'foo', 'ADMIN'), undef, - ' as does setting an unknown ACL'); -is ($server->error, 'invalid ACL type foo', ' with the right error'); -is ($server->acl ('base', 'service/admin', 'get', 'test2'), undef, - ' as does setting it to an unknown ACL'); -is ($server->error, 'ACL test2 not found', ' with the right error'); -is ($server->acl ('base', 'service/admin', 'get', 'ADMIN'), 1, - ' but setting the right ACL works'); -$result = eval { $server->get ('base', 'service/admin') }; -is ($result, undef, 'Get still fails'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' but the method is called'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and storing the object still fails'); -is ($server->error, "$admin not authorized to store base:service/admin", - ' with the right error'); -is ($server->acl ('base', 'service/admin', 'get', ''), 1, - 'Clearing the ACL works'); -is ($server->get ('base', 'service/admin'), undef, ' and now get fails'); -is ($server->error, "$admin not authorized to get base:service/admin", - ' with the right error'); -is ($server->acl ('base', 'service/admin', 'store', 'ADMIN'), 1, - 'Setting the store ACL works'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and now store fails'); -is ($server->error, - "cannot store base:service/admin: object type is immutable", - ' with a different error message'); -is ($server->get ('base', 'service/admin'), undef, ' and get still fails'); -is ($server->error, "$admin not authorized to get base:service/admin", - ' with the right error'); -is ($server->acl ('base', 'service/admin', 'store', ''), 1, - 'Clearing the ACL works'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and storing the object now fails'); -is ($server->error, "$admin not authorized to store base:service/admin", - ' with the right error'); - -# Test manipulating the owner. -is ($server->owner ('base', 'service/test'), undef, - 'Owner of nonexistent object fails'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->owner ('base', 'service/test', 'ADMIN'), undef, - ' as does setting it'); -is ($server->error, 'cannot find base:service/test', ' with the right error'); -is ($server->owner ('base', 'service/admin'), undef, - 'Owner of existing object is also undef'); -is ($server->error, undef, ' but there is no error'); -is ($server->owner ('base', 'service/admin', 'test2'), undef, - 'Setting it to an unknown ACL fails'); -is ($server->error, 'ACL test2 not found', ' with the right error'); -is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, - 'Setting it to ADMIN works'); -$result = eval { $server->get ('base', 'service/admin') }; -is ($result, undef, ' and get still fails'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' but the method is called'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and now store fails'); -is ($server->error, - "cannot store base:service/admin: object type is immutable", - ' with a different error message'); -is ($server->acl ('base', 'service/admin', 'get', 'empty'), 1, - 'Setting the get ACL succeeds'); -is ($server->get ('base', 'service/admin'), undef, ' and get now fails'); -is ($server->error, "$admin not authorized to get base:service/admin", - ' with the right error'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' but store fails'); -is ($server->error, - "cannot store base:service/admin: object type is immutable", - ' with the same error message'); -is ($server->acl ('base', 'service/admin', 'store', 'empty'), 1, - ' until we do the same thing with store'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and now store fails'); -is ($server->error, "$admin not authorized to store base:service/admin", - ' due to permissions'); -is ($server->acl ('base', 'service/admin', 'store', ''), 1, - 'Clearing the store ACL works'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and fixes that'); -is ($server->error, - "cannot store base:service/admin: object type is immutable", - ' since we are back to immutable'); -is ($server->owner ('base', 'service/admin', ''), 1, - ' but clearing the owner works'); -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' and now store fails'); -is ($server->error, "$admin not authorized to store base:service/admin", - ' due to permissions again'); -is ($server->owner ('base', 'service/admin', 'ADMIN'), 1, - ' and setting the owner again works'); - -# Test manipulating flags. -is ($server->flag_clear ('base', 'service/admin', 'locked'), undef, - 'Clearing an unset flag fails'); -is ($server->error, - "cannot clear flag locked on base:service/admin: flag not set", - ' with the right error'); -if ($server->flag_set ('base', 'service/admin', 'locked')) { - ok (1, ' but setting it works'); -} else { - is ($server->error, '', ' but setting it works'); -} -is ($server->store ('base', 'service/admin', 'stuff'), undef, - ' now store fails'); -is ($server->error, 'cannot store base:service/admin: object is locked', - ' because the object is locked'); -is ($server->expires ('base', 'service/admin', ''), undef, - ' and expires fails'); -is ($server->error, 'cannot modify base:service/admin: object is locked', - ' because the object is locked'); -is ($server->owner ('base', 'service/admin', ''), undef, ' and owner fails'); -is ($server->error, 'cannot modify base:service/admin: object is locked', - ' because the object is locked'); -for my $acl (qw/get store show destroy flags/) { - is ($server->acl ('base', 'service/admin', $acl, ''), undef, - " and setting $acl ACL fails"); - is ($server->error, 'cannot modify base:service/admin: object is locked', - ' for the same reason'); -} -is ($server->flag_clear ('base', 'service/admin', 'locked'), 1, - ' and then clearing it works'); -is ($server->owner ('base', 'service/admin', ''), 1, - ' and then clearing owner works'); -is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, - ' and setting unchanging works'); -is ($server->flag_clear ('base', 'service/admin', 'locked'), undef, - ' and clearing locked still does not'); -is ($server->error, - "cannot clear flag locked on base:service/admin: flag not set", - ' with the right error'); -is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1, - ' and clearing unchanging works'); - -# Test history. -$history = <<"EOO"; -DATE create - by $admin from $host -DATE set comment to this is a comment - by $admin from $host -DATE unset comment (was this is a comment) - by $admin from $host -DATE set expires to $now - by $admin from $host -DATE unset expires (was $now) - by $admin from $host -DATE set acl_get to ADMIN (1) - by $admin from $host -DATE unset acl_get (was ADMIN (1)) - by $admin from $host -DATE set acl_store to ADMIN (1) - by $admin from $host -DATE unset acl_store (was ADMIN (1)) - by $admin from $host -DATE set owner to ADMIN (1) - by $admin from $host -DATE set acl_get to empty (6) - by $admin from $host -DATE set acl_store to empty (6) - by $admin from $host -DATE unset acl_store (was empty (6)) - by $admin from $host -DATE unset owner (was ADMIN (1)) - by $admin from $host -DATE set owner to ADMIN (1) - by $admin from $host -DATE set flag locked - by $admin from $host -DATE clear flag locked - by $admin from $host -DATE unset owner (was ADMIN (1)) - by $admin from $host -DATE set flag unchanging - by $admin from $host -DATE clear flag unchanging - by $admin from $host -EOO -my $seen = $server->history ('base', 'service/admin'); -$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($seen, $history, 'History for service/admin is correct'); - -# Now let's set up some additional ACLs for future tests. -is ($server->owner ('base', 'service/user1', 'user1'), 1, 'Set user1 owner'); -is ($server->owner ('base', 'service/user2', 'user2'), 1, 'Set user2 owner'); -is ($server->owner ('base', 'service/both', 'both'), 1, 'Set both owner'); -is ($server->acl ('base', 'service/both', 'show', 'user1'), 1, ' and show'); -is ($server->acl ('base', 'service/both', 'destroy', 'user2'), 1, - ' and destroy'); -is ($server->acl ('base', 'service/both', 'flags', 'user1'), 1, ' and flags'); -is ($server->acl ('base', 'service/admin', 'store', 'user1'), 1, - 'Set admin store'); - -# Okay, now we can switch users and be sure we don't have admin rights. -$server = eval { Wallet::Server->new ($user1, $host) }; -is ($@, '', 'Switching users works'); -is ($server->acl_create ('new'), undef, ' and now we cannot create ACLs'); -is ($server->error, "$user1 not authorized to create ACL", ' with error'); -is ($server->acl_rename ('user1', 'alice'), undef, ' or rename ACLs'); -is ($server->error, "$user1 not authorized to rename ACL user1", - ' with error'); -is ($server->acl_show ('user1'), undef, ' or show ACLs'); -is ($server->error, "$user1 not authorized to show ACL user1", ' with error'); -is ($server->acl_history ('user1'), undef, ' or see history for ACLs'); -is ($server->error, "$user1 not authorized to see history of ACL user1", - ' with error'); -is ($server->acl_destroy ('user2'), undef, ' or destroy ACLs'); -is ($server->error, "$user1 not authorized to destroy ACL user2", - ' with error'); -is ($server->acl_add ('user1', 'krb5', $user2), undef, ' or add to ACLs'); -is ($server->error, "$user1 not authorized to add to ACL user1", - ' with error'); -is ($server->acl_remove ('user1', 'krb5', $user1), undef, - ' or remove from ACLs'); -is ($server->error, "$user1 not authorized to remove from ACL user1", - ' with error'); -is ($server->create ('base', 'service/test'), undef, - ' nor can we create objects'); -is ($server->error, "$user1 not authorized to create base:service/test", - ' with error'); -is ($server->owner ('base', 'service/user1', 'user2'), undef, - ' or set the owner'); -is ($server->error, - "$user1 not authorized to set owner for base:service/user1", - ' with error'); -is ($server->expires ('base', 'service/user1', $now), undef, - ' or set expires'); -is ($server->error, - "$user1 not authorized to set expires for base:service/user1", - ' with error'); -is ($server->acl ('base', 'service/user1', 'get', 'user1'), undef, - ' or set an ACL'); -is ($server->error, - "$user1 not authorized to set ACL for base:service/user1", - ' with error'); -is ($server->flag_set ('base', 'service/user1', 'unchanging'), undef, - ' or set flags'); -is ($server->error, - "$user1 not authorized to set flags for base:service/user1", - ' with error'); -is ($server->flag_clear ('base', 'service/user1', 'unchanging'), undef, - ' or clear flags'); -is ($server->error, - "$user1 not authorized to set flags for base:service/user1", - ' with error'); - -# However, we can perform object actions on things we own. -$result = eval { $server->get ('base', 'service/user1') }; -is ($result, undef, 'We can get an object we own'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' and the method is called'); -is ($server->store ('base', 'service/user1', 'stuff'), undef, - ' or store an object we own'); -is ($server->error, - "cannot store base:service/user1: object type is immutable", - ' and the method is called'); -is ($server->comment ('base', 'service/user1', 'this is a comment'), 1, - ' and set a comment'); -$show = $server->show ('base', 'service/user1'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; -$expected = <<"EOO"; - Type: base - Name: service/user1 - Owner: user1 - Comment: this is a comment - Created by: $admin - Created from: $host - Created on: 0 - -Members of ACL user1 (id: 2) are: - krb5 $user1 -EOO -is ($show, $expected, ' and show an object we own'); -$history = <<"EOO"; -DATE create - by $admin from $host -DATE set owner to user1 (2) - by $admin from $host -DATE set comment to this is a comment - by $user1 from $host -EOO -$seen = $server->history ('base', 'service/user1'); -$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($seen, $history, ' and see history for an object we own'); -is ($server->attr ('base', 'service/user1', 'foo'), undef, - ' and getting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but calls the method'); -is ($server->attr ('base', 'service/user1', 'foo', 'foo'), undef, - ' and setting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but calls the method'); - -# But not on things we don't own. -is ($server->get ('base', 'service/user2'), undef, - 'But we cannot get an object we do not own'); -is ($server->error, "$user1 not authorized to get base:service/user2", - ' with the right error'); -is ($server->store ('base', 'service/user2', 'stuff'), undef, - ' or store it'); -is ($server->error, "$user1 not authorized to store base:service/user2", - ' with the right error'); -is ($server->show ('base', 'service/user2'), undef, ' or show it'); -is ($server->error, "$user1 not authorized to show base:service/user2", - ' with the right error'); -is ($server->history ('base', 'service/user2'), undef, - ' or see history for it'); -is ($server->error, "$user1 not authorized to show base:service/user2", - ' with the right error'); -is ($server->attr ('base', 'service/user2', 'foo'), undef, - ' or get attributes'); -is ($server->error, - "$user1 not authorized to get attributes for base:service/user2", - ' with the right error'); -is ($server->attr ('base', 'service/user2', 'foo', ''), undef, - ' and set attributes'); -is ($server->error, - "$user1 not authorized to set attributes for base:service/user2", - ' with the right error'); -is ($server->comment ('base', 'service/user2', 'this is a comment'), undef, - ' and set comment'); -is ($server->error, - "$user1 not authorized to set comment for base:service/user2", - ' with the right error'); - -# And only some things on an object we own with some ACLs. -$result = eval { $server->get ('base', 'service/both') }; -is ($result, undef, 'We can get an object we jointly own'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' and the method is called'); -is ($server->store ('base', 'service/both', 'stuff'), undef, - ' or store an object we jointly own'); -is ($server->error, - "cannot store base:service/both: object type is immutable", - ' and the method is called'); -is ($server->flag_set ('base', 'service/both', 'unchanging'), 1, - ' and set flags on an object we have an ACL'); -is ($server->flag_set ('base', 'service/both', 'locked'), 1, ' both flags'); -$show = $server->show ('base', 'service/both'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; -$expected = <<"EOO"; - Type: base - Name: service/both - Owner: both - Show ACL: user1 - Destroy ACL: user2 - Flags ACL: user1 - Flags: locked unchanging - Created by: $admin - Created from: $host - Created on: 0 - -Members of ACL both (id: 4) are: - krb5 $user1 - krb5 $user2 - -Members of ACL user1 (id: 2) are: - krb5 $user1 - -Members of ACL user2 (id: 3) are: - krb5 $user2 -EOO -is ($show, $expected, ' and show an object we jointly own'); -$history = <<"EOO"; -DATE create - by $admin from $host -DATE set owner to both (4) - by $admin from $host -DATE set acl_show to user1 (2) - by $admin from $host -DATE set acl_destroy to user2 (3) - by $admin from $host -DATE set acl_flags to user1 (2) - by $admin from $host -DATE set flag unchanging - by $user1 from $host -DATE set flag locked - by $user1 from $host -EOO -$seen = $server->history ('base', 'service/both'); -$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($seen, $history, ' and see history for an object we jointly own'); -is ($server->store ('base', 'service/both', 'stuff'), undef, - ' but not store data'); -is ($server->error, 'cannot store base:service/both: object is locked', - ' when the object is locked'); -is ($server->flag_clear ('base', 'service/both', 'locked'), 1, - ' and clear flags'); -is ($server->destroy ('base', 'service/both'), undef, - ' but not destroy it'); -is ($server->error, "$user1 not authorized to destroy base:service/both", - ' due to permissions'); -is ($server->attr ('base', 'service/both', 'foo'), undef, - 'Getting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but calls the method'); -is ($server->attr ('base', 'service/both', 'foo', ''), undef, - ' and setting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but calls the method'); -is ($server->attr ('base', 'service/admin', 'foo', ''), undef, - ' but setting an attribute on service/admin fails'); -is ($server->error, 'unknown attribute foo', ' and calls the method'); -is ($server->attr ('base', 'service/admin', 'foo'), undef, - ' while getting an attribute on service/admin fails'); -is ($server->error, - "$user1 not authorized to get attributes for base:service/admin", - ' with a permission error'); - -# Now switch to the other user and make sure we can do things on objects we -# own. -$server = eval { Wallet::Server->new ($user2, $host) }; -is ($@, '', 'Switching users works'); -$result = eval { $server->get ('base', 'service/user2') }; -is ($result, undef, 'We can get an object we own'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' and the method is called'); -is ($server->store ('base', 'service/user2', 'stuff'), undef, - ' or store an object we own'); -is ($server->error, - "cannot store base:service/user2: object type is immutable", - ' and the method is called'); -$show = $server->show ('base', 'service/user2'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; -$expected = <<"EOO"; - Type: base - Name: service/user2 - Owner: user2 - Created by: $admin - Created from: $host - Created on: 0 - -Members of ACL user2 (id: 3) are: - krb5 $user2 -EOO -is ($show, $expected, ' and show an object we own'); -$history = <<"EOO"; -DATE create - by $admin from $host -DATE set owner to user2 (3) - by $admin from $host -EOO -$seen = $server->history ('base', 'service/user2'); -$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm; -is ($seen, $history, ' and see history for an object we own'); - -# But not on things we don't own. -is ($server->get ('base', 'service/user1'), undef, - 'But we cannot get an object we do not own'); -is ($server->error, "$user2 not authorized to get base:service/user1", - ' with the right error'); -is ($server->store ('base', 'service/user1', 'stuff'), undef, - ' or store it'); -is ($server->error, "$user2 not authorized to store base:service/user1", - ' with the right error'); -is ($server->show ('base', 'service/user1'), undef, ' or show it'); -is ($server->error, "$user2 not authorized to show base:service/user1", - ' with the right error'); -is ($server->history ('base', 'service/user1'), undef, - ' or see history for it'); -is ($server->error, "$user2 not authorized to show base:service/user1", - ' with the right error'); -is ($server->comment ('base', 'service/user1', 'this is a comment'), undef, - ' or set a comment for it'); -is ($server->error, - "$user2 not authorized to set comment for base:service/user1", - ' with the right error'); - -# Test that setting a comment is controlled by the owner but retrieving it is -# controlled by the show ACL. -$result = eval { $server->get ('base', 'service/both') }; -is ($result, undef, 'We can get an object we jointly own'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' and the method is called'); -is ($server->comment ('base', 'service/both', 'this is a comment'), 1, - ' and can set a comment on it'); -is ($server->error, undef, ' with no error'); -is ($server->comment ('base', 'service/both'), undef, - ' but cannot see the comment on it'); -is ($server->error, "$user2 not authorized to show base:service/both", - ' with the right error'); - -# And can only do some things on an object we own with some ACLs. -$result = eval { $server->get ('base', 'service/both') }; -is ($result, undef, 'We can get an object we jointly own'); -is ($@, "Do not instantiate Wallet::Object::Base directly\n", - ' and the method is called'); -is ($server->store ('base', 'service/both', 'stuff'), undef, - ' or store an object we jointly own'); -is ($server->error, - "cannot store base:service/both: object type is immutable", - ' and the method is called'); -is ($server->show ('base', 'service/both'), undef, ' but we cannot show it'); -is ($server->error, "$user2 not authorized to show base:service/both", - ' with the right error'); -is ($server->history ('base', 'service/both'), undef, - ' or see history for it'); -is ($server->error, "$user2 not authorized to show base:service/both", - ' with the right error'); -is ($server->flag_set ('base', 'service/both', 'locked'), undef, - ' or set flags on it'); -is ($server->error, - "$user2 not authorized to set flags for base:service/both", - ' with the right error'); -is ($server->flag_clear ('base', 'service/both', 'unchanging'), undef, - ' or clear flags on it'); -is ($server->error, - "$user2 not authorized to set flags for base:service/both", - ' with the right error'); -is ($server->attr ('base', 'service/both', 'foo'), undef, - ' or getting an attribute'); -is ($server->error, - "$user2 not authorized to get attributes for base:service/both", - ' with the right error'); -is ($server->attr ('base', 'service/both', 'foo', 'foo'), undef, - ' but setting an attribute fails'); -is ($server->error, 'unknown attribute foo', ' but calls the method'); -is ($server->destroy ('base', 'service/both'), 1, ' and we can destroy it'); -is ($server->get ('base', 'service/both'), undef, ' and now cannot get it'); -is ($server->error, 'cannot find base:service/both', ' because it is gone'); -is ($server->store ('base', 'service/both', 'stuff'), undef, - ' or store it'); -is ($server->error, 'cannot find base:service/both', ' because it is gone'); - -# Switch back to user1 and test destroy. -$server = eval { Wallet::Server->new ($user1, $host) }; -is ($@, '', 'Switching users works'); -is ($server->destroy ('base', 'service/user1'), 1, - 'Destroy of an object we own with no destroy ACLs works'); - -# Test default ACLs on object creation. -# -# Create a default_acl sub that permits $user2 to create service/default with -# a default owner of default (the same as the both ACL), $user1 to create -# service/default-both with a default owner of both (but a different -# definition than the existing ACL), and $user2 to create service/default-2 -# with a default owner of user2 (with the same definition as the existing -# ACL). -# -# Also add service/default-get and service/default-store to test auto-creation -# on get and store, and service/default-admin to test auto-creation when one -# is an admin. -package Wallet::Config; -sub default_owner { - my ($type, $name) = @_; - if ($type eq 'base' and $name eq 'service/default') { - return ('default', [ 'krb5', $user1 ], [ 'krb5', $user2 ]); - } elsif ($type eq 'base' and $name eq 'service/default-both') { - return ('both', [ 'krb5', $user1 ]); - } elsif ($type eq 'base' and $name eq 'service/default-2') { - return ('user2', [ 'krb5', $user2 ]); - } elsif ($type eq 'base' and $name eq 'service/default-get') { - return ('user2', [ 'krb5', $user2 ]); - } elsif ($type eq 'base' and $name eq 'service/default-store') { - return ('user2', [ 'krb5', $user2 ]); - } elsif ($type eq 'base' and $name eq 'service/default-admin') { - return ('auto-admin', [ 'krb5', $admin ]); - } elsif ($type eq 'base' and $name eq 'host/default') { - return ('auto-host', [ 'krb5', $admin ]); - } else { - return; - } -} -package main; - -# Switch back to user2, so we should now be able to create service/default. -# Make sure we can and that the ACLs all look good. -$server = eval { Wallet::Server->new ($user2, $host) }; -is ($@, '', 'Switching users works'); -is ($server->create ('base', 'service/default'), undef, - 'Creating an object with the default ACL fails'); -is ($server->error, "$user2 not authorized to create base:service/default", - ' due to lack of authorization'); -is ($server->autocreate ('base', 'service/default'), 1, - ' but autocreation succeeds'); -is ($server->autocreate ('base', 'service/foo'), undef, - ' but not any object'); -is ($server->error, "$user2 not authorized to create base:service/foo", - ' with the right error'); -$show = $server->show ('base', 'service/default'); -if (defined $show) { - $show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; - $expected = <<"EOO"; - Type: base - Name: service/default - Owner: default - Created by: $user2 - Created from: $host - Created on: 0 - -Members of ACL default (id: 7) are: - krb5 $user1 - krb5 $user2 -EOO - is ($show, $expected, ' and the created object and ACL are correct'); -} else { - is ($server->error, undef, ' and the created object and ACL are correct'); -} - -# Try the other basic cases in default_owner. -is ($server->autocreate ('base', 'service/default-both'), undef, - 'Creating an object with an ACL mismatch fails'); -is ($server->error, "ACL both exists and doesn't match default", - ' with the right error'); -is ($server->autocreate ('base', 'service/default-2'), 1, - 'Creating an object with an existing ACL works'); -$show = $server->show ('base', 'service/default-2'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; -$expected = <<"EOO"; - Type: base - Name: service/default-2 - Owner: user2 - Created by: $user2 - Created from: $host - Created on: 0 - -Members of ACL user2 (id: 3) are: - krb5 $user2 -EOO -is ($show, $expected, ' and the created object and ACL are correct'); - -# Auto-creation does not work on get or store; this is done by the client. -$result = eval { $server->get ('base', 'service/default-get') }; -is ($result, undef, 'Auto-creation on get fails'); -is ($@, '', ' does not die'); -is ($server->error, 'cannot find base:service/default-get', - ' and fails with the right error'); -is ($server->store ('base', 'service/default-store', 'stuff'), undef, - 'Auto-creation on store fails'); -is ($server->error, 'cannot find base:service/default-store', - ' with the right error'); - -# Switch back to admin to test auto-creation. -$server = eval { Wallet::Server->new ($admin, $host) }; -is ($@, '', 'Switching users back to admin works'); -is ($server->autocreate ('base', 'service/default-admin'), 1, - 'Autocreation works for admin'); -$show = $server->show ('base', 'service/default-admin'); -$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m; -$expected = <<"EOO"; - Type: base - Name: service/default-admin - Owner: auto-admin - Created by: $admin - Created from: $host - Created on: 0 - -Members of ACL auto-admin (id: 8) are: - krb5 $admin -EOO -is ($show, $expected, ' and the created object and ACL are correct'); -is ($server->destroy ('base', 'service/default-admin'), 1, - ' and we can destroy it'); - -# Test naming enforcement. Permit any base service/* name, but only permit -# base host/* if the host is fully qualified and ends in .example.edu. -package Wallet::Config; -sub verify_name { - my ($type, $name) = @_; - if ($type eq 'base' and $name =~ m,^service/,) { - return; - } elsif ($type eq 'base' and $name =~ m,^host/(.*),) { - my $host = $1; - return "host $host must be fully qualified (add .example.edu)" - unless $host =~ /\./; - return "host $host not in .example.edu domain" - unless $host =~ /\.example\.edu$/; - return; - } else { - return; - } -} -package main; - -# Recreate service/default-admin, which should succeed, and then try the -# various host/* principals. -is ($server->create ('base', 'service/default-admin'), 1, - 'Creating default/admin succeeds'); -if ($server->create ('base', 'host/default.example.edu')) { - ok (1, ' as does creating host/default.example.edu'); -} else { - is ($server->error, '', ' as does creating host/default.example.edu'); -} -is ($server->destroy ('base', 'service/default-admin'), 1, - ' and destroying default-admin works'); -is ($server->destroy ('base', 'host/default.example.edu'), 1, - ' and destroying host/default.example.edu works'); -is ($server->create ('base', 'host/default'), undef, - ' but an unqualified host fails'); -is ($server->error, 'base:host/default rejected: host default must be fully' - . ' qualified (add .example.edu)', ' with the right error'); -is ($server->create ('base', 'host/default.stanford.edu'), undef, - ' and a host in the wrong domain fails'); -is ($server->error, 'base:host/default.stanford.edu rejected: host' - . ' default.stanford.edu not in .example.edu domain', - ' with the right error'); -is ($server->autocreate ('base', 'service/default-admin'), 1, - 'Creating default/admin succeeds'); -is ($server->autocreate ('base', 'host/default'), undef, - ' but an unqualified host fails'); -is ($server->error, 'base:host/default rejected: host default must be fully' - . ' qualified (add .example.edu)', ' with the right error'); -is ($server->acl_show ('auto-host'), undef, ' and the ACL is not present'); -is ($server->error, 'ACL auto-host not found', ' with the right error'); -is ($server->autocreate ('base', 'host/default.stanford.edu'), undef, - ' and a host in the wrong domain fails'); -is ($server->error, 'base:host/default.stanford.edu rejected: host' - . ' default.stanford.edu not in .example.edu domain', - ' with the right error'); - -# Ensure that we can't destroy an ACL that's in use. -is ($server->acl_create ('test-destroy'), 1, 'Creating an ACL works'); -is ($server->create ('base', 'service/acl-user'), 1, 'Creating object works'); -is ($server->owner ('base', 'service/acl-user', 'test-destroy'), 1, - ' and setting owner'); -is ($server->acl_destroy ('test-destroy'), undef, - ' and now we cannot destroy that ACL'); -is ($server->error, - 'cannot destroy ACL 9: ACL in use by base:service/acl-user', - ' with the right error'); -is ($server->owner ('base', 'service/acl-user', ''), 1, - ' but after we clear the owner'); -is ($server->acl_destroy ('test-destroy'), 1, ' now we can destroy the ACL'); -is ($server->destroy ('base', 'service/acl-user'), 1, ' and the object'); - -# Test ACL naming enforcement. Require that ACL names not contain a slash. -package Wallet::Config; -sub verify_acl_name { - my ($name, $user) = @_; - return 'ACL names may not contain slash' if $name =~ m,/,; - return; -} -package main; -is ($server->acl_create ('test/naming'), undef, - 'Creating an ACL with a disallowed name fails'); -is ($server->error, 'test/naming rejected: ACL names may not contain slash', - ' with the right error message'); -is ($server->acl_create ('test-naming'), 1, - 'Creating test-naming succeeds'); -is ($server->acl_rename ('test-naming', 'test/naming'), undef, - ' but renaming it fails'); -is ($server->error, 'test/naming rejected: ACL names may not contain slash', - ' with the right error message'); -is ($server->acl_destroy ('test-naming'), 1, 'Destroying it succeeds'); - -# Clean up. -$setup->destroy; -END { - unlink 'wallet-db'; -} - -# Now test handling of some configuration errors. -undef $Wallet::Config::DB_DRIVER; -$server = eval { Wallet::Server->new ($user2, $host) }; -is ($@, "database connection information not configured\n", - 'Fail if DB_DRIVER is not set'); -$Wallet::Config::DB_DRIVER = 'SQLite'; -undef $Wallet::Config::DB_INFO; -$server = eval { Wallet::Server->new ($user2, $host) }; -is ($@, "database connection information not configured\n", - ' or if DB_INFO is not set'); -$Wallet::Config::DB_INFO = 't'; -$server = eval { Wallet::Server->new ($user2, $host) }; -like ($@, qr/unable to open database file/, - ' or if the database connection fails'); diff --git a/perl/t/stanford-naming.t b/perl/t/stanford-naming.t deleted file mode 100755 index 555086c..0000000 --- a/perl/t/stanford-naming.t +++ /dev/null @@ -1,260 +0,0 @@ -#!/usr/bin/perl -# -# Tests for the Stanford naming policy. -# -# The naming policy code is included primarily an example for non-Stanford -# sites, but it's used at Stanford and this test suite is used to verify -# behavior at Stanford. -# -# Written by Russ Allbery -# Copyright 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use 5.008; -use strict; -use warnings; - -use Test::More tests => 101; - -use lib 't/lib'; -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::Server'); -} - -# 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 - group-example-01/cgi afs/testcell.stanford.edu); - -# Various invalid keytab names. -my @INVALID_KEYTABS = qw(example host/example service/example.stanford.edu - thisistoolong/cgi not-valid/cgi unknown/example.stanford.edu - afs/testcell); - -# Various valid file names. -my @VALID_FILES = qw(htpasswd/example.stanford.edu/web - password-ipmi/example.stanford.edu - password-root/example.stanford.edu - password-tivoli/example.stanford.edu - ssh-dsa/example.stanford.edu - ssh-rsa/example.stanford.edu - ssl-key/example.stanford.edu - ssl-key/example.stanford.edu/mysql - ssl-keypair/example.stanford.edu - ssl-keypair/example.stanford.edu/mysql - tivoli-key/example.stanford.edu - config/its-idg/example/foo - db/its-idg/example/s_foo - gpg-key/its-idg/debian - password/its-idg/example/backup - properties/its-idg/accounts - properties/its-idg/accounts/sponsorship - ssl-keystore/its-idg/accounts - ssl-keystore/its-idg/accounts/sponsorship - ssl-pkcs12/its-idg/accounts - ssl-pkcs12/its-idg/accounts/sponsorship); - -# Various valid legacy file names. -my @VALID_LEGACY_FILES = qw(apps-example-config-file crcsg-example-db-s_example - idg-debian-gpg-key idg-devnull-password-root sulair-accounts-properties - idg-accounts-ssl-keystore idg-accounts-ssl-pkcs12 - crcsg-example-htpasswd-web sulair-example-password-ipmi - sulair-example-password-root sulair-example-password-tivoli - sulair-example-ssh-dsa sulair-example-ssh-rsa idg-mdm-ssl-key - idg-openafs-tivoli-key); - -# Various invalid file names. -my @INVALID_FILES = qw(unknown foo-example-ssh-rsa idg-accounts-foo !!bad - htpasswd/example.stanford.edu htpasswd/example password-root/example - password-root/example.stanford.edu/foo ssh-foo/example.stanford.edu - tivoli-key/example.stanford.edu/foo tivoli-key config config/its-idg - config/its-idg/example db/its-idg/example password/its-idg/example - its-idg/password/example properties//accounts properties/its-idg/ - ssl-keystore/idg/accounts); - -# Global variables for the wallet server setup. -my $ADMIN = 'admin@EXAMPLE.COM'; -my $HOST = 'localhost'; -my @TRACE = ($ADMIN, $HOST); - -# Start by testing lots of straightforward naming validity. -for my $name (@VALID_KEYTABS) { - is(verify_name('keytab', $name), undef, "Valid keytab $name"); -} -for my $name (@INVALID_KEYTABS) { - isnt(verify_name('keytab', $name), undef, "Invalid keytab $name"); -} -for my $name (@VALID_FILES) { - is(verify_name('file', $name), undef, "Valid file $name"); -} -for my $name (@VALID_LEGACY_FILES) { - is(verify_name('file', $name), undef, "Valid file $name"); -} -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'); - -# 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' -); - -# 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' -); - -# 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'); - -# 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' -); - -# 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 a type that isn't host-based. -is(default_owner('keytab', 'service/foo'), undef, - 'No default owner for service/foo'); - -# Check for an unknown object type. -is(default_owner('unknown', 'foo'), undef, - 'No default owner for unknown type'); - -# 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 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; -END { - unlink 'wallet-db'; -} diff --git a/perl/t/util/kadmin.t b/perl/t/util/kadmin.t new file mode 100755 index 0000000..8eabc6b --- /dev/null +++ b/perl/t/util/kadmin.t @@ -0,0 +1,117 @@ +#!/usr/bin/perl -w +# +# Tests for the kadmin object implementation. +# +# Written by Jon Robertson +# Copyright 2009, 2010, 2012, 2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use POSIX qw(strftime); +use Test::More tests => 34; + +BEGIN { $Wallet::Config::KEYTAB_TMP = '.' } + +use Wallet::Admin; +use Wallet::Config; +use Wallet::Kadmin; +use Wallet::Kadmin::MIT; + +# Only load Wallet::Kadmin::Heimdal if a required module is found. +my $heimdal_kadm5 = 0; +eval 'use Heimdal::Kadm5'; +if (!$@) { + $heimdal_kadm5 = 1; + require Wallet::Kadmin::Heimdal; +} + +use lib 't/lib'; +use Util; + +# Test creating an MIT object and seeing if the callback works. +$Wallet::Config::KEYTAB_KRBTYPE = 'MIT'; +my $kadmin = Wallet::Kadmin->new; +ok (defined ($kadmin), 'MIT kadmin object created'); +my $callback = sub { return 1 }; +$kadmin->fork_callback ($callback); +is ($kadmin->{fork_callback} (), 1, ' and callback works'); +$callback = sub { return 2 }; +$kadmin->fork_callback ($callback); +is ($kadmin->{fork_callback} (), 2, ' and changing it works'); + +# Check principal validation in the Wallet::Kadmin::MIT module. This is +# specific to that module, since Heimdal doesn't require passing the principal +# through the kadmin client. +for my $bad (qw{service\* = host/foo+bar host/foo/bar /bar bar/ rcmd.foo}) { + ok (! Wallet::Kadmin::MIT->valid_principal ($bad), + "Invalid principal name $bad"); +} +for my $good (qw{service service/foo bar foo/bar host/example.org + aservice/foo}) { + ok (Wallet::Kadmin::MIT->valid_principal ($good), + "Valid principal name $good"); +} + +# Test creating a Heimdal object. We deliberately connect without +# configuration to get the error. That tests that we can find the Heimdal +# module and it dies how it should. +SKIP: { + skip 'Heimdal::Kadm5 not installed', 2 unless $heimdal_kadm5; + undef $Wallet::Config::KEYTAB_PRINCIPAL; + undef $Wallet::Config::KEYTAB_FILE; + undef $Wallet::Config::KEYTAB_REALM; + undef $kadmin; + $Wallet::Config::KEYTAB_KRBTYPE = 'Heimdal'; + $kadmin = eval { Wallet::Kadmin->new }; + is ($kadmin, undef, 'Heimdal fails properly'); + is ($@, "keytab object implementation not configured\n", + ' with the right error'); +} + +# Now, check the generic API. We can run this test no matter which +# implementation is configured. This retests some things that are also tested +# by the keytab test, but specifically through the Wallet::Kadmin API. +SKIP: { + skip 'no keytab configuration', 16 unless -f 't/data/test.keytab'; + + # Set up our configuration. + $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; + $Wallet::Config::KEYTAB_PRINCIPAL = contents ('t/data/test.principal'); + $Wallet::Config::KEYTAB_REALM = contents ('t/data/test.realm'); + $Wallet::Config::KEYTAB_KRBTYPE = contents ('t/data/test.krbtype'); + $Wallet::Config::KEYTAB_TMP = '.'; + + # Don't destroy the user's Kerberos ticket cache. + $ENV{KRB5CCNAME} = 'krb5cc_test'; + + # Create the object and clean up the principal we're going to use. + $kadmin = eval { Wallet::Kadmin->new }; + ok (defined $kadmin, 'Creating Wallet::Kadmin object succeeds'); + is ($@, '', ' and there is no error'); + is ($kadmin->destroy ('wallet/one'), 1, 'Deleting wallet/one works'); + is ($kadmin->exists ('wallet/one'), 0, ' and it does not exist'); + is ($kadmin->error, undef, ' with no error message'); + + # Create the principal and check that keytab returns something. We'll + # check the details of the return in the keytab check. + is ($kadmin->create ('wallet/one'), 1, 'Creating wallet/one works'); + is ($kadmin->error, undef, ' with no error message'); + is ($kadmin->exists ('wallet/one'), 1, ' and it now exists'); + my $data = $kadmin->keytab_rekey ('wallet/one'); + ok (defined ($data), ' and retrieving a keytab works'); + is (keytab_valid ($data, 'wallet/one'), 1, + ' and works for authentication'); + + # Delete the principal and confirm behavior. + is ($kadmin->destroy ('wallet/one'), 1, 'Deleting principal works'); + is ($kadmin->exists ('wallet/one'), 0, ' and now it does not exist'); + is ($kadmin->keytab_rekey ('wallet/one', './tmp.keytab'), undef, + ' and retrieving the keytab does not work'); + ok (! -f './tmp.keytab', ' and no file was created'); + like ($kadmin->error, qr%^error creating keytab for wallet/one%, + ' and the right error message is set'); + is ($kadmin->destroy ('wallet/one'), 1, ' and deleting it again works'); + + unlink 'krb5cc_test'; +} diff --git a/perl/t/verifier-ldap-attr.t b/perl/t/verifier-ldap-attr.t deleted file mode 100755 index d8e416b..0000000 --- a/perl/t/verifier-ldap-attr.t +++ /dev/null @@ -1,73 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the LDAP attribute ACL verifier. -# -# This test can only be run by someone local to Stanford with appropriate -# access to the LDAP server and will be skipped in all other environments. -# -# Written by Russ Allbery -# Copyright 2012, 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More; - -use lib 't/lib'; -use Util; - -# Skip all spelling tests unless the maintainer environment variable is set. -plan skip_all => 'LDAP verifier tests only run for maintainer' - unless $ENV{RRA_MAINTAINER_TESTS}; - -# Declare a plan. -plan tests => 10; - -require_ok ('Wallet::ACL::LDAP::Attribute'); - -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'; - -# Remove the realm from principal names. -package Wallet::Config; -sub ldap_map_principal { - my ($principal) = @_; - $principal =~ s/\@.*//; - return $principal; -} -package main; - -# Determine the local principal. -my $klist = `klist 2>&1` || ''; -SKIP: { - skip "tests useful only with Stanford Kerberos tickets", 9 - unless ($klist =~ /[Pp]rincipal: \S+\@stanford\.edu$/m); - - # Set up our configuration. - $Wallet::Config::LDAP_HOST = $host; - $Wallet::Config::LDAP_CACHE = $ENV{KRB5CCNAME}; - $Wallet::Config::LDAP_BASE = $base; - $Wallet::Config::LDAP_FILTER_ATTR = $filter; - - # Finally, we can test. - my $verifier = eval { Wallet::ACL::LDAP::Attribute->new }; - isa_ok ($verifier, 'Wallet::ACL::LDAP::Attribute'); - is ($verifier->check ($user, "$attr=$value"), 1, - "Checking $attr=$value succeeds"); - is ($verifier->error, undef, '...with no error'); - is ($verifier->check ($user, "$attr=BOGUS"), 0, - "Checking $attr=BOGUS fails"); - is ($verifier->error, undef, '...with no error'); - 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', - '...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'); -} diff --git a/perl/t/verifier-netdb.t b/perl/t/verifier-netdb.t deleted file mode 100755 index d8fe561..0000000 --- a/perl/t/verifier-netdb.t +++ /dev/null @@ -1,45 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the NetDB wallet ACL verifiers. -# -# This test can only be run by someone local to Stanford with appropriate -# access to the NetDB role server and will be skipped in all other -# environments. -# -# Written by Russ Allbery -# Copyright 2008, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 5; - -use Wallet::ACL::NetDB; - -use lib 't/lib'; -use Util; - -my $netdb = 'netdb-node-roles-rc.stanford.edu'; -my $host = 'windlord.stanford.edu'; -my $user = 'rra@stanford.edu'; - -# Determine the local principal. -my $klist = `klist 2>&1` || ''; -SKIP: { - skip "tests useful only with Stanford Kerberos tickets", 5 - unless ($klist =~ /^(Default p|\s+P)rincipal: \S+\@stanford\.edu$/m); - - # Set up our configuration. - $Wallet::Config::NETDB_REALM = 'stanford.edu'; - $Wallet::Config::NETDB_REMCTL_CACHE = $ENV{KRB5CCNAME}; - $Wallet::Config::NETDB_REMCTL_HOST = $netdb; - - # Finally, we can test. - $verifier = eval { Wallet::ACL::NetDB->new }; - ok (defined $verifier, ' and now creation succeeds'); - is ($@, q{}, ' with no errors'); - ok ($verifier->isa ('Wallet::ACL::NetDB'), ' and returns the right class'); - is ($verifier->check ($user, $host), 1, "Checking $host succeeds"); - is ($verifier->check ('test-user@stanford.edu', $host), 0, - ' but fails with another user'); -} diff --git a/perl/t/verifier.t b/perl/t/verifier.t deleted file mode 100755 index 5697ae6..0000000 --- a/perl/t/verifier.t +++ /dev/null @@ -1,155 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the basic wallet ACL verifiers. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 57; - -use Wallet::ACL::Base; -use Wallet::ACL::Krb5; -use Wallet::ACL::Krb5::Regex; -use Wallet::ACL::NetDB; -use Wallet::ACL::NetDB::Root; -use Wallet::Config; - -use lib 't/lib'; -use Util; - -my $verifier = Wallet::ACL::Base->new; -ok (defined $verifier, 'Wallet::ACL::Base creation'); -ok ($verifier->isa ('Wallet::ACL::Base'), ' and class verification'); -is ($verifier->check ('eagle@eyrie.org', 'eagle@eyrie.org'), 0, - 'Default check declines'); -is ($verifier->error, undef, 'No error set'); - -$verifier = Wallet::ACL::Krb5->new; -ok (defined $verifier, 'Wallet::ACL::Krb5 creation'); -ok ($verifier->isa ('Wallet::ACL::Krb5'), ' and class verification'); -is ($verifier->check ('eagle@eyrie.org', 'eagle@eyrie.org'), 1, - 'Simple check'); -is ($verifier->check ('eagle@eyrie.org', 'thoron@stanford.edu'), 0, - 'Simple failure'); -is ($verifier->error, undef, 'No error set'); -is ($verifier->check (undef, 'eagle@eyrie.org'), undef, - 'Undefined principal'); -is ($verifier->error, 'no principal specified', ' and right error'); -is ($verifier->check ('eagle@eyrie.org', ''), undef, 'Empty ACL'); -is ($verifier->error, 'malformed krb5 ACL', ' and right error'); - -$verifier = Wallet::ACL::Krb5::Regex->new; -isa_ok ($verifier, 'Wallet::ACL::Krb5::Regex', 'krb5-regex verifier'); -is ($verifier->check ('rra@stanford.edu', '.*@stanford\.edu\z'), 1, - 'Simple check'); -is ($verifier->check ('rra@stanford.edu', '^a.*@stanford\.edu'), 0, - 'Simple failure'); -is ($verifier->error, undef, 'No error set'); -is ($verifier->check (undef, '^rra@stanford\.edu\z'), undef, - 'Undefined principal'); -is ($verifier->error, 'no principal specified', ' and right error'); -is ($verifier->check ('eagle@eyrie.org', ''), undef, 'Empty ACL'); -is ($verifier->error, 'no ACL specified', ' and right error'); -is ($verifier->check ('eagle@eyrie.org', '(rra'), undef, 'Malformed regex'); -is ($verifier->error, 'malformed krb5-regex ACL', ' and right error'); - -# Tests for the NetDB verifiers. Skip these if we don't have a keytab or if -# we can't find remctld. -SKIP: { - skip 'no keytab configuration', 34 unless -f 't/data/test.keytab'; - my @path = (split (':', $ENV{PATH}), '/usr/local/sbin', '/usr/sbin'); - my ($remctld) = grep { -x $_ } map { "$_/remctld" } @path; - skip 'remctld not found', 34 unless $remctld; - eval { require Net::Remctl }; - skip 'Net::Remctl not available', 34 if $@; - - # Set up our configuration. - $Wallet::Config::NETDB_REALM = 'EXAMPLE.COM'; - my $principal = contents ('t/data/test.principal'); - - # Now spawn our remctld server and get a ticket cache. - unlink ('krb5cc_test', 'test-acl', 'test-pid'); - remctld_spawn ($remctld, $principal, 't/data/test.keytab', - 't/data/netdb.conf'); - $ENV{KRB5CCNAME} = 'krb5cc_test'; - getcreds ('t/data/test.keytab', $principal); - - # Finally, we can test. - my $verifier = eval { Wallet::ACL::NetDB->new }; - is ($verifier, undef, 'Constructor fails without configuration'); - is ($@, "NetDB ACL support not configured\n", ' with the right exception'); - $Wallet::Config::NETDB_REMCTL_CACHE = 'krb5cc_test'; - $verifier = eval { Wallet::ACL::NetDB->new }; - is ($verifier, undef, ' and still fails without host'); - is ($@, "NetDB ACL support not configured\n", ' with the right exception'); - $Wallet::Config::NETDB_REMCTL_HOST = 'localhost'; - $Wallet::Config::NETDB_REMCTL_PRINCIPAL = $principal; - $Wallet::Config::NETDB_REMCTL_PORT = 14373; - $verifier = eval { Wallet::ACL::NetDB->new }; - ok (defined $verifier, ' and now creation succeeds'); - ok ($verifier->isa ('Wallet::ACL::NetDB'), ' and returns the right class'); - is ($verifier->check ('test-user', 'all'), undef, - ' but verification fails without an ACL'); - is ($verifier->error, 'cannot check NetDB ACL: Access denied', - ' with the right error'); - - # Create an ACL so that tests will start working. - open (ACL, '>', 'test-acl') or die "cannot create test-acl: $!\n"; - print ACL "$principal\n"; - close ACL; - is ($verifier->check ('test-user', 'all'), 1, - ' and now verification works'); - - # Test the successful verifications. - for my $node (qw/admin team user/) { - is ($verifier->check ('test-user', $node), 1, - "Verification succeeds for $node"); - } - - # Test various failures. - is ($verifier->check ('test-user', 'unknown'), 0, - 'Verification fails for unknown'); - is ($verifier->check ('test-user', 'none'), 0, ' and for none'); - is ($verifier->check (undef, 'all'), undef, - 'Undefined principal'); - is ($verifier->error, 'no principal specified', ' and right error'); - is ($verifier->check ('test-user', ''), undef, 'Empty ACL'); - is ($verifier->error, 'malformed netdb ACL', ' and right error'); - is ($verifier->check ('error', 'normal'), undef, 'Regular error'); - is ($verifier->error, 'error checking NetDB ACL: some error', - ' and correct error return'); - is ($verifier->check ('error', 'status'), undef, 'Status-only error'); - is ($verifier->error, 'error checking NetDB ACL', ' and correct error'); - is ($verifier->check ('unknown', 'unknown'), undef, 'Unknown node'); - is ($verifier->error, - 'error checking NetDB ACL: Unknown principal unknown', - ' and correct error'); - - # Test the Wallet::ACL::NetDB::Root subclass. We don't retest shared code - # (kind of grey-box of us), just the changed check behavior. - $verifier = eval { Wallet::ACL::NetDB::Root->new }; - if (defined $verifier) { - ok (1, 'Wallet::ACL::NetDB::Root creation succeeds'); - } else { - is ($@, '', 'Wallet::ACL::NetDB::Root creation succeeds'); - } - ok ($verifier->isa ('Wallet::ACL::NetDB::Root'), - ' and returns the right class'); - for my $node (qw/admin team user/) { - is ($verifier->check ('test-user', $node), 0, - "Verification fails for non-root user for $node"); - } - for my $node (qw/admin team user/) { - is ($verifier->check ('test-user/root', $node), 1, - "Verification succeeds for root user for $node"); - } - is ($verifier->check (undef, 'all'), undef, - 'Undefined principal'); - is ($verifier->error, 'no principal specified', ' and right error'); - - remctld_stop; - unlink ('krb5cc_test', 'test-acl', 'test-pid'); -} diff --git a/perl/t/verifier/basic.t b/perl/t/verifier/basic.t new file mode 100755 index 0000000..5697ae6 --- /dev/null +++ b/perl/t/verifier/basic.t @@ -0,0 +1,155 @@ +#!/usr/bin/perl -w +# +# Tests for the basic wallet ACL verifiers. +# +# Written by Russ Allbery +# Copyright 2007, 2008, 2010, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 57; + +use Wallet::ACL::Base; +use Wallet::ACL::Krb5; +use Wallet::ACL::Krb5::Regex; +use Wallet::ACL::NetDB; +use Wallet::ACL::NetDB::Root; +use Wallet::Config; + +use lib 't/lib'; +use Util; + +my $verifier = Wallet::ACL::Base->new; +ok (defined $verifier, 'Wallet::ACL::Base creation'); +ok ($verifier->isa ('Wallet::ACL::Base'), ' and class verification'); +is ($verifier->check ('eagle@eyrie.org', 'eagle@eyrie.org'), 0, + 'Default check declines'); +is ($verifier->error, undef, 'No error set'); + +$verifier = Wallet::ACL::Krb5->new; +ok (defined $verifier, 'Wallet::ACL::Krb5 creation'); +ok ($verifier->isa ('Wallet::ACL::Krb5'), ' and class verification'); +is ($verifier->check ('eagle@eyrie.org', 'eagle@eyrie.org'), 1, + 'Simple check'); +is ($verifier->check ('eagle@eyrie.org', 'thoron@stanford.edu'), 0, + 'Simple failure'); +is ($verifier->error, undef, 'No error set'); +is ($verifier->check (undef, 'eagle@eyrie.org'), undef, + 'Undefined principal'); +is ($verifier->error, 'no principal specified', ' and right error'); +is ($verifier->check ('eagle@eyrie.org', ''), undef, 'Empty ACL'); +is ($verifier->error, 'malformed krb5 ACL', ' and right error'); + +$verifier = Wallet::ACL::Krb5::Regex->new; +isa_ok ($verifier, 'Wallet::ACL::Krb5::Regex', 'krb5-regex verifier'); +is ($verifier->check ('rra@stanford.edu', '.*@stanford\.edu\z'), 1, + 'Simple check'); +is ($verifier->check ('rra@stanford.edu', '^a.*@stanford\.edu'), 0, + 'Simple failure'); +is ($verifier->error, undef, 'No error set'); +is ($verifier->check (undef, '^rra@stanford\.edu\z'), undef, + 'Undefined principal'); +is ($verifier->error, 'no principal specified', ' and right error'); +is ($verifier->check ('eagle@eyrie.org', ''), undef, 'Empty ACL'); +is ($verifier->error, 'no ACL specified', ' and right error'); +is ($verifier->check ('eagle@eyrie.org', '(rra'), undef, 'Malformed regex'); +is ($verifier->error, 'malformed krb5-regex ACL', ' and right error'); + +# Tests for the NetDB verifiers. Skip these if we don't have a keytab or if +# we can't find remctld. +SKIP: { + skip 'no keytab configuration', 34 unless -f 't/data/test.keytab'; + my @path = (split (':', $ENV{PATH}), '/usr/local/sbin', '/usr/sbin'); + my ($remctld) = grep { -x $_ } map { "$_/remctld" } @path; + skip 'remctld not found', 34 unless $remctld; + eval { require Net::Remctl }; + skip 'Net::Remctl not available', 34 if $@; + + # Set up our configuration. + $Wallet::Config::NETDB_REALM = 'EXAMPLE.COM'; + my $principal = contents ('t/data/test.principal'); + + # Now spawn our remctld server and get a ticket cache. + unlink ('krb5cc_test', 'test-acl', 'test-pid'); + remctld_spawn ($remctld, $principal, 't/data/test.keytab', + 't/data/netdb.conf'); + $ENV{KRB5CCNAME} = 'krb5cc_test'; + getcreds ('t/data/test.keytab', $principal); + + # Finally, we can test. + my $verifier = eval { Wallet::ACL::NetDB->new }; + is ($verifier, undef, 'Constructor fails without configuration'); + is ($@, "NetDB ACL support not configured\n", ' with the right exception'); + $Wallet::Config::NETDB_REMCTL_CACHE = 'krb5cc_test'; + $verifier = eval { Wallet::ACL::NetDB->new }; + is ($verifier, undef, ' and still fails without host'); + is ($@, "NetDB ACL support not configured\n", ' with the right exception'); + $Wallet::Config::NETDB_REMCTL_HOST = 'localhost'; + $Wallet::Config::NETDB_REMCTL_PRINCIPAL = $principal; + $Wallet::Config::NETDB_REMCTL_PORT = 14373; + $verifier = eval { Wallet::ACL::NetDB->new }; + ok (defined $verifier, ' and now creation succeeds'); + ok ($verifier->isa ('Wallet::ACL::NetDB'), ' and returns the right class'); + is ($verifier->check ('test-user', 'all'), undef, + ' but verification fails without an ACL'); + is ($verifier->error, 'cannot check NetDB ACL: Access denied', + ' with the right error'); + + # Create an ACL so that tests will start working. + open (ACL, '>', 'test-acl') or die "cannot create test-acl: $!\n"; + print ACL "$principal\n"; + close ACL; + is ($verifier->check ('test-user', 'all'), 1, + ' and now verification works'); + + # Test the successful verifications. + for my $node (qw/admin team user/) { + is ($verifier->check ('test-user', $node), 1, + "Verification succeeds for $node"); + } + + # Test various failures. + is ($verifier->check ('test-user', 'unknown'), 0, + 'Verification fails for unknown'); + is ($verifier->check ('test-user', 'none'), 0, ' and for none'); + is ($verifier->check (undef, 'all'), undef, + 'Undefined principal'); + is ($verifier->error, 'no principal specified', ' and right error'); + is ($verifier->check ('test-user', ''), undef, 'Empty ACL'); + is ($verifier->error, 'malformed netdb ACL', ' and right error'); + is ($verifier->check ('error', 'normal'), undef, 'Regular error'); + is ($verifier->error, 'error checking NetDB ACL: some error', + ' and correct error return'); + is ($verifier->check ('error', 'status'), undef, 'Status-only error'); + is ($verifier->error, 'error checking NetDB ACL', ' and correct error'); + is ($verifier->check ('unknown', 'unknown'), undef, 'Unknown node'); + is ($verifier->error, + 'error checking NetDB ACL: Unknown principal unknown', + ' and correct error'); + + # Test the Wallet::ACL::NetDB::Root subclass. We don't retest shared code + # (kind of grey-box of us), just the changed check behavior. + $verifier = eval { Wallet::ACL::NetDB::Root->new }; + if (defined $verifier) { + ok (1, 'Wallet::ACL::NetDB::Root creation succeeds'); + } else { + is ($@, '', 'Wallet::ACL::NetDB::Root creation succeeds'); + } + ok ($verifier->isa ('Wallet::ACL::NetDB::Root'), + ' and returns the right class'); + for my $node (qw/admin team user/) { + is ($verifier->check ('test-user', $node), 0, + "Verification fails for non-root user for $node"); + } + for my $node (qw/admin team user/) { + is ($verifier->check ('test-user/root', $node), 1, + "Verification succeeds for root user for $node"); + } + is ($verifier->check (undef, 'all'), undef, + 'Undefined principal'); + is ($verifier->error, 'no principal specified', ' and right error'); + + remctld_stop; + unlink ('krb5cc_test', 'test-acl', 'test-pid'); +} diff --git a/perl/t/verifier/ldap-attr.t b/perl/t/verifier/ldap-attr.t new file mode 100755 index 0000000..d8e416b --- /dev/null +++ b/perl/t/verifier/ldap-attr.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl -w +# +# Tests for the LDAP attribute ACL verifier. +# +# This test can only be run by someone local to Stanford with appropriate +# access to the LDAP server and will be skipped in all other environments. +# +# Written by Russ Allbery +# Copyright 2012, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More; + +use lib 't/lib'; +use Util; + +# Skip all spelling tests unless the maintainer environment variable is set. +plan skip_all => 'LDAP verifier tests only run for maintainer' + unless $ENV{RRA_MAINTAINER_TESTS}; + +# Declare a plan. +plan tests => 10; + +require_ok ('Wallet::ACL::LDAP::Attribute'); + +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'; + +# Remove the realm from principal names. +package Wallet::Config; +sub ldap_map_principal { + my ($principal) = @_; + $principal =~ s/\@.*//; + return $principal; +} +package main; + +# Determine the local principal. +my $klist = `klist 2>&1` || ''; +SKIP: { + skip "tests useful only with Stanford Kerberos tickets", 9 + unless ($klist =~ /[Pp]rincipal: \S+\@stanford\.edu$/m); + + # Set up our configuration. + $Wallet::Config::LDAP_HOST = $host; + $Wallet::Config::LDAP_CACHE = $ENV{KRB5CCNAME}; + $Wallet::Config::LDAP_BASE = $base; + $Wallet::Config::LDAP_FILTER_ATTR = $filter; + + # Finally, we can test. + my $verifier = eval { Wallet::ACL::LDAP::Attribute->new }; + isa_ok ($verifier, 'Wallet::ACL::LDAP::Attribute'); + is ($verifier->check ($user, "$attr=$value"), 1, + "Checking $attr=$value succeeds"); + is ($verifier->error, undef, '...with no error'); + is ($verifier->check ($user, "$attr=BOGUS"), 0, + "Checking $attr=BOGUS fails"); + is ($verifier->error, undef, '...with no error'); + 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', + '...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'); +} diff --git a/perl/t/verifier/netdb.t b/perl/t/verifier/netdb.t new file mode 100755 index 0000000..d8fe561 --- /dev/null +++ b/perl/t/verifier/netdb.t @@ -0,0 +1,45 @@ +#!/usr/bin/perl -w +# +# Tests for the NetDB wallet ACL verifiers. +# +# This test can only be run by someone local to Stanford with appropriate +# access to the NetDB role server and will be skipped in all other +# environments. +# +# Written by Russ Allbery +# Copyright 2008, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# See LICENSE for licensing terms. + +use Test::More tests => 5; + +use Wallet::ACL::NetDB; + +use lib 't/lib'; +use Util; + +my $netdb = 'netdb-node-roles-rc.stanford.edu'; +my $host = 'windlord.stanford.edu'; +my $user = 'rra@stanford.edu'; + +# Determine the local principal. +my $klist = `klist 2>&1` || ''; +SKIP: { + skip "tests useful only with Stanford Kerberos tickets", 5 + unless ($klist =~ /^(Default p|\s+P)rincipal: \S+\@stanford\.edu$/m); + + # Set up our configuration. + $Wallet::Config::NETDB_REALM = 'stanford.edu'; + $Wallet::Config::NETDB_REMCTL_CACHE = $ENV{KRB5CCNAME}; + $Wallet::Config::NETDB_REMCTL_HOST = $netdb; + + # Finally, we can test. + $verifier = eval { Wallet::ACL::NetDB->new }; + ok (defined $verifier, ' and now creation succeeds'); + is ($@, q{}, ' with no errors'); + ok ($verifier->isa ('Wallet::ACL::NetDB'), ' and returns the right class'); + is ($verifier->check ($user, $host), 1, "Checking $host succeeds"); + is ($verifier->check ('test-user@stanford.edu', $host), 0, + ' but fails with another user'); +} diff --git a/perl/t/wa-keyring.t b/perl/t/wa-keyring.t deleted file mode 100755 index 8d8e1fe..0000000 --- a/perl/t/wa-keyring.t +++ /dev/null @@ -1,184 +0,0 @@ -#!/usr/bin/perl -# -# Tests for the WebAuth keyring object implementation. -# -# Written by Russ Allbery -# Copyright 2013, 2014 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use strict; -use warnings; - -use Test::More; - -BEGIN { - eval 'use WebAuth 3.06 qw(WA_KEY_AES WA_AES_128)'; - plan skip_all => 'WebAuth 3.06 required for testing wa-keyring' - if $@; -} - -use POSIX qw(strftime); -use WebAuth::Key 1.01 (); -use WebAuth::Keyring 1.02 (); - -BEGIN { - plan tests => 68; - use_ok('Wallet::Admin'); - use_ok('Wallet::Config'); - use_ok('Wallet::Object::WAKeyring'); -} - -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-keyrings') == 0 or die "cannot remove test-keyrings\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; - -# Create a WebAuth context to use. -my $wa = WebAuth->new; - -# Test error handling in the absence of configuration. -my $object = eval { - Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) - }; -ok (defined ($object), 'Creating a basic WebAuth keyring object succeeds'); -ok ($object->isa ('Wallet::Object::WAKeyring'), ' and is the right class'); -is ($object->get (@trace), undef, ' and get fails'); -is ($object->error, 'WebAuth keyring support not configured', - ' with the right error'); -is ($object->store (@trace), undef, ' and store fails'); -is ($object->error, 'WebAuth keyring support not configured', - ' with the right error'); -is ($object->destroy (@trace), 1, ' but destroy succeeds'); - -# Set up our configuration. -mkdir 'test-keyrings' or die "cannot create test-keyrings: $!\n"; -$Wallet::Config::WAKEYRING_BUCKET = 'test-keyrings'; - -# Okay, now we can test. First, the basic object without store. -$object = eval { - Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) - }; -ok (defined ($object), 'Creating a basic WebAuth keyring object succeeds'); -ok ($object->isa ('Wallet::Object::WAKeyring'), ' and is the right class'); -my $data = $object->get (@trace); -ok ($data, ' and get succeeds'); -my $keyring = WebAuth::Keyring->decode ($wa, $data); -ok ($keyring->isa ('WebAuth::Keyring'), ' and resulting keyring decodes'); -my @entries = $keyring->entries; -is (scalar (@entries), 3, ' and has three entries'); -is ($entries[0]->creation, 0, 'First has good creation'); -is ($entries[0]->key->type, WA_KEY_AES, ' and key type'); -is ($entries[0]->key->length, WA_AES_128, ' and key length'); -is ($entries[0]->valid_after, 0, ' and validity'); -ok ((time - $entries[1]->creation) < 2, 'Second has good creation'); -is ($entries[1]->key->type, WA_KEY_AES, ' and key type'); -is ($entries[1]->key->length, WA_AES_128, ' and key length'); -ok (($entries[1]->valid_after - time) <= 60 * 60 * 24, - ' and validity (upper)'); -ok (($entries[1]->valid_after - time) > 60 * 60 * 24 - 2, - ' and validity (lower)'); -ok ((time - $entries[2]->creation) < 2, 'Third has good creation'); -is ($entries[2]->key->type, WA_KEY_AES, ' and key type'); -is ($entries[2]->key->length, WA_AES_128, ' and key length'); -ok (($entries[2]->valid_after - time) <= 2 * 60 * 60 * 24, - ' and validity (upper)'); -ok (($entries[2]->valid_after - time) > 2 * 60 * 60 * 24 - 2, - ' and validity (lower)'); -my $data2 = $object->get (@trace); -is ($data2, $data, 'Getting the object again returns the same data'); -is ($object->error, undef, ' with no error'); -is ($object->destroy (@trace), 1, 'Destroying the object succeeds'); - -# Now store something and be sure that we get something reasonable. -$object = eval { - Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) - }; -ok (defined ($object), 'Recreating the object succeeds'); -my $key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); -$keyring = WebAuth::Keyring->new ($wa, $key); -$data = $keyring->encode; -is ($object->store ($data, @trace), 1, ' and storing data in it succeeds'); -ok (-d 'test-keyrings/09', ' and the hash bucket was created'); -ok (-f 'test-keyrings/09/test', ' and the file exists'); -is (contents ('test-keyrings/09/test'), $data, ' with the right contents'); -$data = $object->get (@trace); -$keyring = WebAuth::Keyring->decode ($wa, $data); -ok ($keyring->isa ('WebAuth::Keyring'), ' and get returns a valid keyring'); -@entries = $keyring->entries; -is (scalar (@entries), 2, ' and has three entries'); -is ($entries[0]->creation, 0, 'First has good creation'); -is ($entries[0]->key->type, WA_KEY_AES, ' and key type'); -is ($entries[0]->key->length, WA_AES_128, ' and key length'); -is ($entries[0]->valid_after, 0, ' and validity'); -is ($entries[0]->key->data, $key->data, ' and matches the original key'); -ok ((time - $entries[1]->creation) < 2, 'Second has good creation'); -is ($entries[1]->key->type, WA_KEY_AES, ' and key type'); -is ($entries[1]->key->length, WA_AES_128, ' and key length'); -ok (($entries[1]->valid_after - time) <= 2 * 60 * 60 * 24, - ' and validity (upper)'); -ok (($entries[1]->valid_after - time) > 2 * 60 * 60 * 24 - 2, - ' and validity (lower)'); - -# Test pruning. Add another old key and a couple of more current keys to the -# current keyring. -$key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); -$keyring->add (0, 0, $key); -$key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); -$keyring->add (time - 24 * 60 * 60, time - 24 * 60 * 60, $key); -$key = WebAuth::Key->new ($wa, WA_KEY_AES, WA_AES_128); -$keyring->add (time, time, $key); -$data = $keyring->encode; -is ($object->store ($data, @trace), 1, 'Storing modified keyring succeeds'); -$data = $object->get (@trace); -$keyring = WebAuth::Keyring->decode ($wa, $data); -ok ($keyring->isa ('WebAuth::Keyring'), ' and get returns a valid keyring'); -@entries = $keyring->entries; -is (scalar (@entries), 3, ' and has three entries'); -ok ((time - $entries[0]->creation) < 2, 'First has good creation'); -ok (($entries[0]->valid_after - time) <= 2 * 60 * 60 * 24, - ' and validity (upper)'); -ok (($entries[0]->valid_after - time) > 2 * 60 * 60 * 24 - 2, - ' and validity (lower)'); -ok ((time - $entries[1]->creation) < 24 * 60 * 60 + 2, - 'Second has good creation'); -ok ((time - $entries[1]->valid_after) <= 60 * 60 * 24 + 2, - ' and validity'); -ok ((time - $entries[2]->creation) < 2, 'Third has good creation'); -ok ((time - $entries[2]->valid_after) < 2, ' and validity'); -is ($object->destroy (@trace), 1, 'Destroying the object succeeds'); - -# Test error handling in the file store. -system ('rm -r test-keyrings') == 0 or die "cannot remove test-keyrings\n"; -$object = eval { - Wallet::Object::WAKeyring->create ('wa-keyring', 'test', $schema, @trace) - }; -ok (defined ($object), 'Recreating the object succeeds'); -is ($object->get (@trace), undef, ' but retrieving it fails'); -like ($object->error, qr/^cannot create keyring bucket 09: /, - ' with the right error'); -is ($object->store ("foo\n", @trace), undef, ' and store fails'); -like ($object->error, qr/^cannot create keyring bucket 09: /, - ' with the right error'); -is ($object->destroy (@trace), 1, ' but destroying the object succeeds'); - -# Clean up. -$admin->destroy; -END { - unlink ('wallet-db'); -} diff --git a/tests/client/full-t.in b/tests/client/full-t.in index b73a375..9822b37 100644 --- a/tests/client/full-t.in +++ b/tests/client/full-t.in @@ -15,7 +15,7 @@ BEGIN { $ENV{WALLET_CONFIG} = "$ENV{SOURCE}/data/wallet.conf" } BEGIN { our $total = 59 } use Test::More tests => $total; -use lib "$ENV{SOURCE}/../perl"; +use lib "$ENV{SOURCE}/../perl/lib"; use Wallet::Admin; use lib "$ENV{SOURCE}/../perl/t/lib"; diff --git a/tests/client/prompt-t.in b/tests/client/prompt-t.in index 566d1a4..8467411 100644 --- a/tests/client/prompt-t.in +++ b/tests/client/prompt-t.in @@ -3,7 +3,7 @@ # Password prompting tests for the wallet client. # # Written by Russ Allbery -# Copyright 2008, 2010 +# Copyright 2008, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -11,7 +11,7 @@ BEGIN { our $total = 5 } use Test::More tests => $total; -use lib "$ENV{SOURCE}/..//perl"; +use lib "$ENV{SOURCE}/../perl/lib"; use Wallet::Admin; use lib "$ENV{SOURCE}/../perl/t/lib"; diff --git a/tests/data/cmd-wrapper b/tests/data/cmd-wrapper index 79b1943..b5b6d26 100755 --- a/tests/data/cmd-wrapper +++ b/tests/data/cmd-wrapper @@ -5,4 +5,4 @@ WALLET_CONFIG="$SOURCE/data/wallet.conf" export WALLET_CONFIG -exec perl -I"$SOURCE/../perl" "$SOURCE/../server/wallet-backend" -q "$@" +exec perl -I"$SOURCE/../perl/lib" "$SOURCE/../server/wallet-backend" -q "$@" -- cgit v1.2.3 From 1329e6db944a6fce5578b249de08a8250a920877 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 11 Jul 2014 22:36:11 -0700 Subject: Test for Perl strict and minimum version Fix strictness issues across the whole code base, and ensure that all Perl scripts enable warnings. (Hopefully enabling warnings won't cause problems for the server.) Change-Id: I4dee49f7a6bcbeeee21d74bf61a1fd26514f832c Reviewed-on: https://gerrit.stanford.edu/1532 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 8 ++-- README | 34 ++++++++++++----- contrib/wallet-summary | 33 +++++++++-------- contrib/wallet-unknown-hosts | 36 ++++++++++-------- perl/lib/Wallet/ACL.pm | 3 +- perl/lib/Wallet/ACL/Base.pm | 3 +- perl/lib/Wallet/ACL/Krb5.pm | 3 +- perl/lib/Wallet/ACL/Krb5/Regex.pm | 3 +- perl/lib/Wallet/ACL/LDAP/Attribute.pm | 3 +- perl/lib/Wallet/ACL/NetDB.pm | 3 +- perl/lib/Wallet/ACL/NetDB/Root.pm | 3 +- perl/lib/Wallet/Admin.pm | 3 +- perl/lib/Wallet/Config.pm | 1 + perl/lib/Wallet/Database.pm | 3 +- perl/lib/Wallet/Kadmin.pm | 3 +- perl/lib/Wallet/Kadmin/Heimdal.pm | 1 + perl/lib/Wallet/Kadmin/MIT.pm | 3 +- perl/lib/Wallet/Object/Base.pm | 3 +- perl/lib/Wallet/Object/Duo.pm | 1 + perl/lib/Wallet/Object/File.pm | 3 +- perl/lib/Wallet/Object/Keytab.pm | 3 +- perl/lib/Wallet/Object/WAKeyring.pm | 3 +- perl/lib/Wallet/Report.pm | 3 +- perl/lib/Wallet/Server.pm | 3 +- perl/t/data/perl.conf | 7 ++++ perl/t/general/acl.t | 5 ++- perl/t/general/admin.t | 7 +++- perl/t/general/config.t | 7 +++- perl/t/general/init.t | 5 ++- perl/t/general/report.t | 7 +++- perl/t/general/server.t | 7 +++- perl/t/lib/Util.pm | 3 +- perl/t/object/base.t | 5 ++- perl/t/object/file.t | 7 +++- perl/t/object/keytab.t | 11 ++++-- perl/t/style/minimum-version.t | 47 ++++++++++++++++++++++++ perl/t/style/strict.t | 56 ++++++++++++++++++++++++++++ perl/t/util/kadmin.t | 7 +++- perl/t/verifier/basic.t | 5 ++- perl/t/verifier/ldap-attr.t | 5 ++- perl/t/verifier/netdb.t | 7 +++- server/keytab-backend | 1 + server/wallet-backend | 1 + tests/TESTS | 2 + tests/client/full-t.in | 12 +++--- tests/client/prompt-t.in | 14 ++++--- tests/data/fake-kadmin | 7 +++- tests/perl/minimum-version-t | 69 +++++++++++++++++++++++++++++++++++ tests/perl/strict-t | 66 +++++++++++++++++++++++++++++++++ 49 files changed, 437 insertions(+), 98 deletions(-) create mode 100644 perl/t/data/perl.conf create mode 100755 perl/t/style/minimum-version.t create mode 100755 perl/t/style/strict.t create mode 100755 tests/perl/minimum-version-t create mode 100755 tests/perl/strict-t (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index 19dbe11..8e65151 100644 --- a/Makefile.am +++ b/Makefile.am @@ -66,6 +66,7 @@ PERL_FILES = perl/Build.PL perl/MANIFEST perl/MANIFEST.SKIP \ perl/t/general/server.t perl/t/lib/Util.pm perl/t/object/base.t \ perl/t/object/duo.t perl/t/object/file.t perl/t/object/keytab.t \ perl/t/object/wa-keyring.t perl/t/policy/stanford.t \ + perl/t/style/minimum-version.t perl/t/style/strict.t \ perl/t/util/kadmin.t perl/t/verifier/basic.t \ perl/t/verifier/ldap-attr.t perl/t/verifier/netdb.t @@ -99,9 +100,10 @@ EXTRA_DIST = .gitignore LICENSE autogen client/wallet.pod \ tests/data/fake-keytab-partial-result tests/data/fake-keytab-rekey \ tests/data/fake-keytab-unknown tests/data/fake-srvtab \ tests/data/full.conf tests/data/perl.conf tests/data/wallet.conf \ - tests/docs/pod-spelling-t tests/docs/pod-t tests/server/admin-t \ - tests/server/backend-t tests/server/keytab-t tests/server/report-t \ - tests/tap/kerberos.sh tests/tap/libtap.sh \ + tests/docs/pod-spelling-t tests/docs/pod-t \ + tests/perl/minimum-version-t tests/perl/strict-t \ + tests/server/admin-t tests/server/backend-t tests/server/keytab-t \ + tests/server/report-t tests/tap/kerberos.sh tests/tap/libtap.sh \ tests/tap/perl/Test/RRA.pm tests/tap/perl/Test/RRA/Automake.pm \ tests/tap/perl/Test/RRA/Config.pm tests/tap/remctl.sh \ tests/util/xmalloc-t $(PERL_FILES) diff --git a/README b/README index e72bc80..ef910bd 100644 --- a/README +++ b/README @@ -118,16 +118,30 @@ REQUIREMENTS server. To run the full test suite, all of the above software requirements must - be met. Tests requiring some bit of software that's not installed - should be skipped, but not all the permutations have been checked. The - full test suite also requires the Test::Pod Perl module (available from - CPAN), that remctld be installed and available on the user's path or in - /usr/local/sbin or /usr/sbin, that sqlite3 be installed and available on - the user's path, that test cases can run services on and connect to port - 14373 on 127.0.0.1, and that kinit and either kvno or kgetcred (which - come with Kerberos) be installed and available on the user's path. The - full test suite also requires a local keytab and some additional - configuration. + be met. The full test suite also requires that remctld be installed and + available on the user's path or in /usr/local/sbin or /usr/sbin, that + sqlite3 be installed and available on the user's path, that test cases + can run services on and connect to port 14373 on 127.0.0.1, and that + kinit and either kvno or kgetcred (which come with Kerberos) be + installed and available on the user's path. The full test suite also + requires a local keytab and some additional configuration. + + The following additional Perl modules will be used if present: + + Test::MinimumVersion + Test::Pod + Test::Spelling + Test::Strict + + All are available on CPAN. Those tests will be skipped if the modules + are not available. + + To enable tests that don't detect functionality problems but are used to + sanity-check the release, set the environment variable RELEASE_TESTING + to a true value. To enable tests that may be sensitive to the local + environment or that produce a lot of false positives without uncovering + many problems, set the environment variable AUTHOR_TESTING to a true + value. To bootstrap from a Git checkout, or if you change the Automake files and need to regenerate Makefile.in, you will need Automake 1.11 or diff --git a/contrib/wallet-summary b/contrib/wallet-summary index 55501ad..5cbf6e0 100755 --- a/contrib/wallet-summary +++ b/contrib/wallet-summary @@ -1,7 +1,22 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Summarize keytabs in the wallet database. +############################################################################## +# Modules and declarations +############################################################################## + +require 5.005; + +use strict; +use vars qw($ADDRESS $DUMPFILE @PATTERNS $REPORTS); +use warnings; + +use Getopt::Long qw(GetOptions); +use File::Path qw(mkpath); +use POSIX qw(strftime); +use Wallet::Report (); + ############################################################################## # Site configuration ############################################################################## @@ -29,20 +44,6 @@ $ADDRESS = 'nobody@example.com'; [qr(^webauth/), 'webauth/*', 'WebAuth v3'], [qr(^service/), 'service/*', 'Service principals']); -############################################################################## -# Modules and declarations -############################################################################## - -require 5.005; - -use strict; -use vars qw($ADDRESS $DUMPFILE @PATTERNS $REPORTS); - -use Getopt::Long qw(GetOptions); -use File::Path qw(mkpath); -use POSIX qw(strftime); -use Wallet::Report (); - ############################################################################## # Database queries ############################################################################## @@ -145,7 +146,7 @@ if ($mail) { } # Run the report. -my @principals = read_dump; +my @principals = read_dump (); report_principals (@principals); # If -m was given, take the saved report and mail it as well. diff --git a/contrib/wallet-unknown-hosts b/contrib/wallet-unknown-hosts index 339983d..50b5a04 100755 --- a/contrib/wallet-unknown-hosts +++ b/contrib/wallet-unknown-hosts @@ -1,7 +1,20 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Report host keytabs in wallet for unknown hosts. +############################################################################## +# Modules and declarations +############################################################################## + +require 5.006; + +use strict; +use warnings; + +use DB_File (); +use Wallet::Report (); +use Wallet::Server (); + ############################################################################## # Site configuration ############################################################################## @@ -22,9 +35,10 @@ our $MIN = 3; our $THRESHOLD = time - 30 * 24 * 60 * 60; # Set up a Net::DNS resolver that will be used by local_check_keytab. +my $DNS; BEGIN { use Net::DNS; - our $DNS = Net::DNS::Resolver->new; + $DNS = Net::DNS::Resolver->new; } # Pre-filter. This is called for all host-based keytabs and is the place to @@ -54,18 +68,6 @@ sub local_check_keytab { return; } -############################################################################## -# Modules and declarations -############################################################################## - -require 5.006; - -use strict; - -use DB_File (); -use Wallet::Report (); -use Wallet::Server (); - ############################################################################## # Utility functions ############################################################################## @@ -97,6 +99,7 @@ sub check_host { # Do a scan of all host-based keytabs in wallet and record those that are not # found in DNS or which should not be used according to site configuration. sub check { + my %history; tie %history, 'DB_File', $HISTORY; my @keytabs = list_keytabs; for my $keytab (@keytabs) { @@ -124,6 +127,7 @@ sub check { # list (given as a threshold time in seconds since epoch). sub report { my ($min, $threshold) = @_; + my %history; tie %history, 'DB_File', $HISTORY; for my $keytab (sort keys %history) { my ($count, $time) = split (',', $history{$keytab}); @@ -142,6 +146,7 @@ sub report { sub purge { my ($user, $min, $threshold) = @_; my $wallet = Wallet::Server->new ($user, 'localhost'); + my %history; tie %history, 'DB_File', $HISTORY; for my $keytab (sort keys %history) { my ($count, $time) = split (',', $history{$keytab}); @@ -161,7 +166,7 @@ sub purge { my $command = shift or die "Usage: $0 (check | report | purge)\n"; if ($command eq 'check') { - check; + check (); } elsif ($command eq 'report') { my ($min, $threshold) = @_; $min = $MIN unless defined ($min); @@ -170,6 +175,7 @@ if ($command eq 'check') { report ($min, $threshold); } elsif ($command eq 'purge') { my $user = $ENV{REMOTE_USER} or die "$0: REMOTE_USER must be set\n"; + my ($min, $threshold) = @_; $min = $MIN unless defined ($min); die "$0: minimum count must be at least 1\n" if $min < 1; $threshold = $THRESHOLD unless defined ($threshold); diff --git a/perl/lib/Wallet/ACL.pm b/perl/lib/Wallet/ACL.pm index 808be3c..9507c64 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 -# Copyright 2007, 2008, 2010, 2013 +# Copyright 2007, 2008, 2010, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL; require 5.006; use strict; +use warnings; use vars qw($VERSION); use DBI; diff --git a/perl/lib/Wallet/ACL/Base.pm b/perl/lib/Wallet/ACL/Base.pm index b6e4ce3..a2b07cc 100644 --- a/perl/lib/Wallet/ACL/Base.pm +++ b/perl/lib/Wallet/ACL/Base.pm @@ -1,7 +1,7 @@ # Wallet::ACL::Base -- Parent class for wallet ACL verifiers. # # Written by Russ Allbery -# Copyright 2007, 2010 +# Copyright 2007, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::Base; require 5.006; use strict; +use warnings; use vars qw($VERSION); # This version should be increased on any code change to this module. Always diff --git a/perl/lib/Wallet/ACL/Krb5.pm b/perl/lib/Wallet/ACL/Krb5.pm index ed0b7df..80d32bd 100644 --- a/perl/lib/Wallet/ACL/Krb5.pm +++ b/perl/lib/Wallet/ACL/Krb5.pm @@ -1,7 +1,7 @@ # Wallet::ACL::Krb5 -- Wallet Kerberos v5 principal ACL verifier. # # Written by Russ Allbery -# Copyright 2007, 2010 +# Copyright 2007, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::Krb5; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::ACL::Base; diff --git a/perl/lib/Wallet/ACL/Krb5/Regex.pm b/perl/lib/Wallet/ACL/Krb5/Regex.pm index 30f5527..4934cfc 100644 --- a/perl/lib/Wallet/ACL/Krb5/Regex.pm +++ b/perl/lib/Wallet/ACL/Krb5/Regex.pm @@ -1,7 +1,7 @@ # Wallet::ACL::Krb5::Regex -- Wallet Kerberos v5 principal regex ACL verifier # # Written by Russ Allbery -# Copyright 2007, 2010 +# Copyright 2007, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::Krb5::Regex; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::ACL::Krb5; diff --git a/perl/lib/Wallet/ACL/LDAP/Attribute.pm b/perl/lib/Wallet/ACL/LDAP/Attribute.pm index aea8a72..c27729e 100644 --- a/perl/lib/Wallet/ACL/LDAP/Attribute.pm +++ b/perl/lib/Wallet/ACL/LDAP/Attribute.pm @@ -1,7 +1,7 @@ # Wallet::ACL::LDAP::Attribute -- Wallet LDAP attribute ACL verifier. # # Written by Russ Allbery -# Copyright 2012, 2013 +# Copyright 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::LDAP::Attribute; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Authen::SASL (); diff --git a/perl/lib/Wallet/ACL/NetDB.pm b/perl/lib/Wallet/ACL/NetDB.pm index b76d4ed..ad2164b 100644 --- a/perl/lib/Wallet/ACL/NetDB.pm +++ b/perl/lib/Wallet/ACL/NetDB.pm @@ -1,7 +1,7 @@ # Wallet::ACL::NetDB -- Wallet NetDB role ACL verifier. # # Written by Russ Allbery -# Copyright 2007, 2010 +# Copyright 2007, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::NetDB; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::ACL::Base; diff --git a/perl/lib/Wallet/ACL/NetDB/Root.pm b/perl/lib/Wallet/ACL/NetDB/Root.pm index 6c95c6e..34163e7 100644 --- a/perl/lib/Wallet/ACL/NetDB/Root.pm +++ b/perl/lib/Wallet/ACL/NetDB/Root.pm @@ -1,7 +1,7 @@ # Wallet::ACL::NetDB::Root -- Wallet NetDB role ACL verifier (root instances). # # Written by Russ Allbery -# Copyright 2007, 2010 +# Copyright 2007, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::ACL::NetDB::Root; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::ACL::NetDB; diff --git a/perl/lib/Wallet/Admin.pm b/perl/lib/Wallet/Admin.pm index 3a05284..d39c272 100644 --- a/perl/lib/Wallet/Admin.pm +++ b/perl/lib/Wallet/Admin.pm @@ -1,7 +1,7 @@ # Wallet::Admin -- Wallet system administrative interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2011, 2012, 2013 +# Copyright 2008, 2009, 2010, 2011, 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Admin; require 5.006; use strict; +use warnings; use vars qw($VERSION); use Wallet::ACL; diff --git a/perl/lib/Wallet/Config.pm b/perl/lib/Wallet/Config.pm index 5b0ab1c..527658c 100644 --- a/perl/lib/Wallet/Config.pm +++ b/perl/lib/Wallet/Config.pm @@ -10,6 +10,7 @@ package Wallet::Config; require 5.006; use strict; +use warnings; use vars qw($PATH $VERSION); # This version should be increased on any code change to this module. Always diff --git a/perl/lib/Wallet/Database.pm b/perl/lib/Wallet/Database.pm index 031be9e..3a4e130 100644 --- a/perl/lib/Wallet/Database.pm +++ b/perl/lib/Wallet/Database.pm @@ -6,7 +6,7 @@ # like DBIx::Class objects in the rest of the code. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2012, 2013 +# Copyright 2008, 2009, 2010, 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -19,6 +19,7 @@ package Wallet::Database; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::Schema; diff --git a/perl/lib/Wallet/Kadmin.pm b/perl/lib/Wallet/Kadmin.pm index 4ea7920..65a5700 100644 --- a/perl/lib/Wallet/Kadmin.pm +++ b/perl/lib/Wallet/Kadmin.pm @@ -1,7 +1,7 @@ # Wallet::Kadmin -- Kerberos administration API for wallet keytab backend. # # Written by Jon Robertson -# Copyright 2009, 2010 +# Copyright 2009, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Kadmin; require 5.006; use strict; +use warnings; use vars qw($VERSION); use Wallet::Config (); diff --git a/perl/lib/Wallet/Kadmin/Heimdal.pm b/perl/lib/Wallet/Kadmin/Heimdal.pm index 42de8e0..1208801 100644 --- a/perl/lib/Wallet/Kadmin/Heimdal.pm +++ b/perl/lib/Wallet/Kadmin/Heimdal.pm @@ -14,6 +14,7 @@ package Wallet::Kadmin::Heimdal; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Heimdal::Kadm5 qw(KRB5_KDB_DISALLOW_ALL_TIX); diff --git a/perl/lib/Wallet/Kadmin/MIT.pm b/perl/lib/Wallet/Kadmin/MIT.pm index 1ae01bf..ac45265 100644 --- a/perl/lib/Wallet/Kadmin/MIT.pm +++ b/perl/lib/Wallet/Kadmin/MIT.pm @@ -2,7 +2,7 @@ # # Written by Russ Allbery # Pulled into a module by Jon Robertson -# Copyright 2007, 2008, 2009, 2010 +# Copyright 2007, 2008, 2009, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -15,6 +15,7 @@ package Wallet::Kadmin::MIT; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::Config (); diff --git a/perl/lib/Wallet/Object/Base.pm b/perl/lib/Wallet/Object/Base.pm index 8debac9..a009d76 100644 --- a/perl/lib/Wallet/Object/Base.pm +++ b/perl/lib/Wallet/Object/Base.pm @@ -1,7 +1,7 @@ # Wallet::Object::Base -- Parent class for any object stored in the wallet. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011 +# Copyright 2007, 2008, 2010, 2011, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Object::Base; require 5.006; use strict; +use warnings; use vars qw($VERSION); use DBI; diff --git a/perl/lib/Wallet/Object/Duo.pm b/perl/lib/Wallet/Object/Duo.pm index e5773c8..e3fe2da 100644 --- a/perl/lib/Wallet/Object/Duo.pm +++ b/perl/lib/Wallet/Object/Duo.pm @@ -14,6 +14,7 @@ package Wallet::Object::Duo; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use JSON; diff --git a/perl/lib/Wallet/Object/File.pm b/perl/lib/Wallet/Object/File.pm index 4afef04..1ff1288 100644 --- a/perl/lib/Wallet/Object/File.pm +++ b/perl/lib/Wallet/Object/File.pm @@ -1,7 +1,7 @@ # Wallet::Object::File -- File object implementation for the wallet. # # Written by Russ Allbery -# Copyright 2008, 2010 +# Copyright 2008, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Object::File; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Digest::MD5 qw(md5_hex); diff --git a/perl/lib/Wallet/Object/Keytab.pm b/perl/lib/Wallet/Object/Keytab.pm index 24c3302..975179b 100644 --- a/perl/lib/Wallet/Object/Keytab.pm +++ b/perl/lib/Wallet/Object/Keytab.pm @@ -1,7 +1,7 @@ # Wallet::Object::Keytab -- Keytab object implementation for the wallet. # # Written by Russ Allbery -# Copyright 2007, 2008, 2009, 2010, 2013 +# Copyright 2007, 2008, 2009, 2010, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Object::Keytab; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Wallet::Config (); diff --git a/perl/lib/Wallet/Object/WAKeyring.pm b/perl/lib/Wallet/Object/WAKeyring.pm index f8bd0f7..3e80300 100644 --- a/perl/lib/Wallet/Object/WAKeyring.pm +++ b/perl/lib/Wallet/Object/WAKeyring.pm @@ -1,7 +1,7 @@ # Wallet::Object::WAKeyring -- WebAuth keyring object implementation. # # Written by Russ Allbery -# Copyright 2012, 2013 +# Copyright 2012, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Object::WAKeyring; require 5.006; use strict; +use warnings; use vars qw(@ISA $VERSION); use Digest::MD5 qw(md5_hex); diff --git a/perl/lib/Wallet/Report.pm b/perl/lib/Wallet/Report.pm index 1085546..bf48308 100644 --- a/perl/lib/Wallet/Report.pm +++ b/perl/lib/Wallet/Report.pm @@ -1,7 +1,7 @@ # Wallet::Report -- Wallet system reporting interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2013 +# Copyright 2008, 2009, 2010, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Report; require 5.006; use strict; +use warnings; use vars qw($VERSION); use Wallet::ACL; diff --git a/perl/lib/Wallet/Server.pm b/perl/lib/Wallet/Server.pm index 3266928..2765d34 100644 --- a/perl/lib/Wallet/Server.pm +++ b/perl/lib/Wallet/Server.pm @@ -1,7 +1,7 @@ # Wallet::Server -- Wallet system server implementation. # # Written by Russ Allbery -# Copyright 2007, 2008, 2010, 2011, 2013 +# Copyright 2007, 2008, 2010, 2011, 2013, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -14,6 +14,7 @@ package Wallet::Server; require 5.006; use strict; +use warnings; use vars qw(%MAPPING $VERSION); use Wallet::ACL; diff --git a/perl/t/data/perl.conf b/perl/t/data/perl.conf new file mode 100644 index 0000000..ca05568 --- /dev/null +++ b/perl/t/data/perl.conf @@ -0,0 +1,7 @@ +# Configuration for Perl tests. -*- perl -*- + +# Default minimum version requirement. +$MINIMUM_VERSION = '5.008'; + +# File must end with this line. +1; diff --git a/perl/t/general/acl.t b/perl/t/general/acl.t index e633f46..01b4801 100755 --- a/perl/t/general/acl.t +++ b/perl/t/general/acl.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the wallet ACL API. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use POSIX qw(strftime); use Test::More tests => 101; diff --git a/perl/t/general/admin.t b/perl/t/general/admin.t index 41bc33a..7c62932 100755 --- a/perl/t/general/admin.t +++ b/perl/t/general/admin.t @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 26; use Wallet::Admin; @@ -44,7 +47,7 @@ is ($admin->register_object ('base', 'Wallet::Object::Base'), 1, 'Registering Wallet::Object::Base works'); is ($admin->register_object ('base', 'Wallet::Object::Base'), undef, ' and cannot be registered twice'); -$server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; +my $server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; is ($@, '', 'Creating a server instance did not die'); is ($server->create ('base', 'service/admin'), 1, ' and creating base:service/admin succeeds'); @@ -83,7 +86,7 @@ SKIP: { is ($retval, 1, ' and performing an upgrade to 0.08 succeeds'); my $sql = "select version from dbix_class_schema_versions order by" . " version DESC"; - $version = $admin->dbh->selectall_arrayref ($sql); + my $version = $admin->dbh->selectall_arrayref ($sql); is (@$version, 2, ' and versions table has correct number of rows'); is (@{ $version->[0] }, 1, ' and correct number of columns'); is ($version->[0][0], '0.08', ' and the schema version is correct'); diff --git a/perl/t/general/config.t b/perl/t/general/config.t index 881f2bd..bc200de 100755 --- a/perl/t/general/config.t +++ b/perl/t/general/config.t @@ -1,13 +1,16 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the wallet server configuration. # # Written by Russ Allbery -# Copyright 2008, 2010 +# Copyright 2008, 2010, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 6; # Silence warnings since we're not using use. diff --git a/perl/t/general/init.t b/perl/t/general/init.t index b8ec3c9..58b9a4c 100755 --- a/perl/t/general/init.t +++ b/perl/t/general/init.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for database initialization. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 18; use Wallet::ACL; diff --git a/perl/t/general/report.t b/perl/t/general/report.t index 9563362..8d348ed 100755 --- a/perl/t/general/report.t +++ b/perl/t/general/report.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the wallet reporting interface. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 197; use Wallet::Admin; @@ -39,7 +42,7 @@ is ($acls[0][0], 1, ' and that is ACL ID 1'); is ($acls[0][1], 'ADMIN', ' with the right name'); # Create an object. -$server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; +my $server = eval { Wallet::Server->new ('admin@EXAMPLE.COM', 'localhost') }; is ($@, '', 'Creating a server instance did not die'); is ($server->create ('base', 'service/admin'), 1, ' and creating base:service/admin succeeds'); diff --git a/perl/t/general/server.t b/perl/t/general/server.t index 9026439..0a527a5 100755 --- a/perl/t/general/server.t +++ b/perl/t/general/server.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the wallet server API. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 382; use POSIX qw(strftime); @@ -33,7 +36,7 @@ is ($@, '', 'Database initialization did not die'); is ($setup->reinitialize ($admin), 1, 'Database initialization succeeded'); # Now test the new method. -$server = eval { Wallet::Server->new (@trace) }; +my $server = eval { Wallet::Server->new (@trace) }; is ($@, '', 'Reopening with new did not die'); ok ($server->isa ('Wallet::Server'), ' and returned the right class'); my $schema = $server->schema; diff --git a/perl/t/lib/Util.pm b/perl/t/lib/Util.pm index 9e5b95e..187e483 100644 --- a/perl/t/lib/Util.pm +++ b/perl/t/lib/Util.pm @@ -1,7 +1,7 @@ # Utility class for wallet tests. # # Written by Russ Allbery -# Copyright 2007, 2008 +# Copyright 2007, 2008, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -10,6 +10,7 @@ package Util; require 5.006; use strict; +use warnings; use vars qw(@ISA @EXPORT $VERSION); use Wallet::Config; diff --git a/perl/t/object/base.t b/perl/t/object/base.t index 0432a23..11f18b7 100755 --- a/perl/t/object/base.t +++ b/perl/t/object/base.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the basic object implementation. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use POSIX qw(strftime); use Test::More tests => 137; diff --git a/perl/t/object/file.t b/perl/t/object/file.t index 0aecd9d..201f46d 100755 --- a/perl/t/object/file.t +++ b/perl/t/object/file.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the file object implementation. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use POSIX qw(strftime); use Test::More tests => 56; @@ -39,7 +42,7 @@ my $history = ''; my $date = strftime ('%Y-%m-%d %H:%M:%S', localtime $trace[2]); # Test error handling in the absence of configuration. -$object = eval { +my $object = eval { Wallet::Object::File->create ('file', 'test', $schema, @trace) }; ok (defined ($object), 'Creating a basic file object succeeds'); diff --git a/perl/t/object/keytab.t b/perl/t/object/keytab.t index 127762a..0f4a8b8 100755 --- a/perl/t/object/keytab.t +++ b/perl/t/object/keytab.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the keytab object implementation. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use POSIX qw(strftime); use Test::More tests => 141; @@ -117,7 +120,7 @@ sub enctypes { next unless /^ *\d+ /; my ($string) = /\((.*)\)\s*$/; next unless $string; - $enctype = $enctype{lc $string} || 'UNKNOWN'; + my $enctype = $enctype{lc $string} || 'UNKNOWN'; push (@enctypes, $enctype); } close KLIST; @@ -174,7 +177,7 @@ SKIP: { # Test that object creation without KEYTAB_TMP fails. undef $Wallet::Config::KEYTAB_TMP; - $object = eval { + my $object = eval { Wallet::Object::Keytab->create ('keytab', 'wallet/one', $schema, @trace) }; @@ -634,7 +637,7 @@ EOO is ("@values", "@enctypes", ' and we get back the right enctype list'); my $eshow = join ("\n" . (' ' x 17), @enctypes); $eshow =~ s/\s+\z/\n/; - $expected = <<"EOO"; + my $expected = <<"EOO"; Type: keytab Name: wallet/one Enctypes: $eshow diff --git a/perl/t/style/minimum-version.t b/perl/t/style/minimum-version.t new file mode 100755 index 0000000..e4eeafd --- /dev/null +++ b/perl/t/style/minimum-version.t @@ -0,0 +1,47 @@ +#!/usr/bin/perl +# +# Check that too-new features of Perl are not being used. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at . +# +# Written by Russ Allbery +# Copyright 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this software and associated documentation files (the "Software"), +# to deal in the Software without restriction, including without limitation +# the rights to use, copy, modify, merge, publish, distribute, sublicense, +# and/or sell copies of the Software, and to permit persons to whom the +# Software is furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. + +use 5.006; +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::RRA qw(skip_unless_automated use_prereq); +use Test::RRA::Config qw($MINIMUM_VERSION); + +# Skip for normal user installs since this doesn't affect functionality. +skip_unless_automated('Minimum version tests'); + +# Load prerequisite modules. +use_prereq('Test::MinimumVersion'); + +# Check all files in the Perl distribution. +all_minimum_version_ok($MINIMUM_VERSION); diff --git a/perl/t/style/strict.t b/perl/t/style/strict.t new file mode 100755 index 0000000..7137b15 --- /dev/null +++ b/perl/t/style/strict.t @@ -0,0 +1,56 @@ +#!/usr/bin/perl +# +# Test Perl code for strict, warnings, and syntax. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at . +# +# Written by Russ Allbery +# Copyright 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this software and associated documentation files (the "Software"), +# to deal in the Software without restriction, including without limitation +# the rights to use, copy, modify, merge, publish, distribute, sublicense, +# and/or sell copies of the Software, and to permit persons to whom the +# Software is furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. + +use 5.006; +use strict; +use warnings; + +use lib 't/lib'; + +use File::Spec; +use Test::RRA qw(skip_unless_automated use_prereq); + +# Skip for normal user installs since this doesn't affect functionality. +skip_unless_automated('Strictness tests'); + +# Load prerequisite modules. +use_prereq('Test::Strict'); + +# Test everything in the distribution directory except the Build and +# Makefile.PL scripts generated by Module::Build. We also want to check use +# warnings. +$Test::Strict::TEST_SKIP = ['Build', 'Makefile.PL']; +$Test::Strict::TEST_WARNINGS = 1; +all_perl_files_ok(File::Spec->curdir); + +# Hack to suppress "used only once" warnings. +END { + $Test::Strict::TEST_SKIP = []; + $Test::Strict::TEST_WARNINGS = 0; +} diff --git a/perl/t/util/kadmin.t b/perl/t/util/kadmin.t index 8eabc6b..2a3d984 100755 --- a/perl/t/util/kadmin.t +++ b/perl/t/util/kadmin.t @@ -1,13 +1,16 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the kadmin object implementation. # # Written by Jon Robertson -# Copyright 2009, 2010, 2012, 2013 +# Copyright 2009, 2010, 2012, 2013, 2014 # 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 => 34; diff --git a/perl/t/verifier/basic.t b/perl/t/verifier/basic.t index 5697ae6..ce44d44 100755 --- a/perl/t/verifier/basic.t +++ b/perl/t/verifier/basic.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the basic wallet ACL verifiers. # @@ -8,6 +8,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 57; use Wallet::ACL::Base; diff --git a/perl/t/verifier/ldap-attr.t b/perl/t/verifier/ldap-attr.t index d8e416b..3c132e2 100755 --- a/perl/t/verifier/ldap-attr.t +++ b/perl/t/verifier/ldap-attr.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the LDAP attribute ACL verifier. # @@ -11,6 +11,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More; use lib 't/lib'; diff --git a/perl/t/verifier/netdb.t b/perl/t/verifier/netdb.t index d8fe561..7048ef9 100755 --- a/perl/t/verifier/netdb.t +++ b/perl/t/verifier/netdb.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Tests for the NetDB wallet ACL verifiers. # @@ -12,6 +12,9 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + use Test::More tests => 5; use Wallet::ACL::NetDB; @@ -35,7 +38,7 @@ SKIP: { $Wallet::Config::NETDB_REMCTL_HOST = $netdb; # Finally, we can test. - $verifier = eval { Wallet::ACL::NetDB->new }; + my $verifier = eval { Wallet::ACL::NetDB->new }; ok (defined $verifier, ' and now creation succeeds'); is ($@, q{}, ' with no errors'); ok ($verifier->isa ('Wallet::ACL::NetDB'), ' and returns the right class'); diff --git a/server/keytab-backend b/server/keytab-backend index cf283bb..bd5a3f9 100755 --- a/server/keytab-backend +++ b/server/keytab-backend @@ -21,6 +21,7 @@ ############################################################################## use strict; +use warnings; use Sys::Syslog qw(openlog syslog); diff --git a/server/wallet-backend b/server/wallet-backend index 0b6a3fa..a97c8ce 100755 --- a/server/wallet-backend +++ b/server/wallet-backend @@ -7,6 +7,7 @@ ############################################################################## use strict; +use warnings; use Getopt::Long qw(GetOptions); use Sys::Syslog qw(openlog syslog); diff --git a/tests/TESTS b/tests/TESTS index 807d944..d947e97 100644 --- a/tests/TESTS +++ b/tests/TESTS @@ -4,6 +4,8 @@ client/prompt client/rekey docs/pod docs/pod-spelling +perl/minimum-version +perl/strict portable/asprintf portable/mkstemp portable/setenv diff --git a/tests/client/full-t.in b/tests/client/full-t.in index 9822b37..4861723 100644 --- a/tests/client/full-t.in +++ b/tests/client/full-t.in @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # End-to-end tests for the wallet client. # @@ -8,12 +8,14 @@ # # See LICENSE for licensing terms. +use strict; +use warnings; + # Point to our server configuration. This must be done before Wallet::Config # is loaded, and it's pulled in as a prerequisite for Wallet::Admin. BEGIN { $ENV{WALLET_CONFIG} = "$ENV{SOURCE}/data/wallet.conf" } -BEGIN { our $total = 59 } -use Test::More tests => $total; +use Test::More tests => 59; use lib "$ENV{SOURCE}/../perl/lib"; use Wallet::Admin; @@ -56,10 +58,10 @@ sub wallet { chdir "$ENV{SOURCE}" or die "Cannot chdir to $ENV{SOURCE}: $!\n"; SKIP: { - skip 'no keytab configuration', $total + skip 'no keytab configuration', 59 unless -f "$ENV{BUILD}/config/keytab"; my $remctld = '@REMCTLD@'; - skip 'remctld not found', $total unless $remctld; + skip 'remctld not found', 59 unless $remctld; # Spawn remctld and get local tickets. Don't destroy the user's Kerberos # ticket cache. diff --git a/tests/client/prompt-t.in b/tests/client/prompt-t.in index 8467411..686cc88 100644 --- a/tests/client/prompt-t.in +++ b/tests/client/prompt-t.in @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Password prompting tests for the wallet client. # @@ -8,8 +8,10 @@ # # See LICENSE for licensing terms. -BEGIN { our $total = 5 } -use Test::More tests => $total; +use strict; +use warnings; + +use Test::More tests => 5; use lib "$ENV{SOURCE}/../perl/lib"; use Wallet::Admin; @@ -21,12 +23,12 @@ use Util; chdir "$ENV{SOURCE}" or die "Cannot chdir to $ENV{SOURCE}: $!\n"; SKIP: { - skip 'no password configuration', $total + skip 'no password configuration', 5 unless -f "$ENV{BUILD}/config/password"; my $remctld = '@REMCTLD@'; - skip 'remctld not found', $total unless $remctld; + skip 'remctld not found', 5 unless $remctld; eval { require Expect }; - skip 'Expect module not found', $total if $@; + skip 'Expect module not found', 5 if $@; # Disable sending of wallet's output to our standard output. Do this # twice to avoid Perl warnings. diff --git a/tests/data/fake-kadmin b/tests/data/fake-kadmin index 57f9c97..ff90f88 100755 --- a/tests/data/fake-kadmin +++ b/tests/data/fake-kadmin @@ -1,13 +1,16 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Fake kadmin.local used to test the keytab backend. # # Written by Russ Allbery -# Copyright 2007 +# Copyright 2007, 2014 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. +use strict; +use warnings; + unless ($ARGV[0] eq '-q' && @ARGV == 2) { die "invalid arguments\n"; } diff --git a/tests/perl/minimum-version-t b/tests/perl/minimum-version-t new file mode 100755 index 0000000..8c49327 --- /dev/null +++ b/tests/perl/minimum-version-t @@ -0,0 +1,69 @@ +#!/usr/bin/perl +# +# Check that too-new features of Perl are not being used. +# +# This version of the check script supports mapping various directories to +# different version numbers. This allows a newer version of Perl to be +# required for internal tools than for public code. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at . +# +# Written by Russ Allbery +# Copyright 2012, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this software and associated documentation files (the "Software"), +# to deal in the Software without restriction, including without limitation +# the rights to use, copy, modify, merge, publish, distribute, sublicense, +# and/or sell copies of the Software, and to permit persons to whom the +# Software is furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. + +use 5.006; +use strict; +use warnings; + +use lib "$ENV{SOURCE}/tap/perl"; + +use Test::More; +use Test::RRA qw(skip_unless_automated use_prereq); +use Test::RRA::Automake qw(automake_setup perl_dirs); +use Test::RRA::Config qw($MINIMUM_VERSION %MINIMUM_VERSION); + +# Skip for normal user installs since this doesn't affect functionality. +skip_unless_automated('Minimum version tests'); + +# Load prerequisite modules. +use_prereq('Test::MinimumVersion'); + +# Set up Automake testing. +automake_setup(); + +# For each exception case in %MINIMUM_VERSION, check the files that should +# have that minium version. Sort for reproducible test order. Also +# accumulate the list of directories we've already tested. +my @tested; +for my $version (sort keys %MINIMUM_VERSION) { + my $paths_ref = $MINIMUM_VERSION{$version}; + all_minimum_version_ok($version, { paths => $paths_ref, no_plan => 1 }); + push(@tested, @{$paths_ref}); +} + +# Now, check anything that's left against the default minimum version. +my @paths = perl_dirs({ skip => [@tested] }); +all_minimum_version_ok($MINIMUM_VERSION, { paths => \@paths, no_plan => 1 }); + +# Tell the TAP harness that we're done. +done_testing(); diff --git a/tests/perl/strict-t b/tests/perl/strict-t new file mode 100755 index 0000000..2df6d58 --- /dev/null +++ b/tests/perl/strict-t @@ -0,0 +1,66 @@ +#!/usr/bin/perl +# +# Check Perl scripts for strict, warnings, and syntax. +# +# Checks all Perl scripts in the tree for problems uncovered by Test::Strict. +# This includes using strict and warnings for every script and ensuring they +# all pass a syntax check. Currently, test suite coverage is not checked. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at . +# +# Written by Russ Allbery +# Copyright 2012, 2013, 2014 +# The Board of Trustees of the Leland Stanford Junior University +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this software and associated documentation files (the "Software"), +# to deal in the Software without restriction, including without limitation +# the rights to use, copy, modify, merge, publish, distribute, sublicense, +# and/or sell copies of the Software, and to permit persons to whom the +# Software is furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. + +use 5.006; +use strict; +use warnings; + +use lib "$ENV{SOURCE}/tap/perl"; + +use Test::More; +use Test::RRA qw(skip_unless_automated use_prereq); +use Test::RRA::Automake qw(automake_setup perl_dirs); +use Test::RRA::Config qw(@STRICT_IGNORE @STRICT_PREREQ); + +# Skip for normal user installs since this doesn't affect functionality. +skip_unless_automated('Strictness tests'); + +# Load prerequisite modules. +use_prereq('Test::Strict'); + +# Check whether all prerequisites are available, and skip the test if any of +# them are not. +for my $module (@STRICT_PREREQ) { + use_prereq($module); +} + +# Set up Automake testing. This must be done after loading Test::Strict, +# since it wants to use FindBin to locate this script. +automake_setup(); + +# Run the actual tests. We also want to check warnings. +$Test::Strict::TEST_WARNINGS = 1; +all_perl_files_ok(perl_dirs({ skip => [@STRICT_IGNORE] })); + +# Suppress "used only once" warnings. +END { $Test::Strict::TEST_WARNINGS = 0 } -- cgit v1.2.3 From 9461eb5b08a58754202ac283d194a4412f1ab5c0 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 16 Jul 2014 11:24:59 -0700 Subject: Add missing directories to PERL_DIRECTORIES Change-Id: I5390ec1ea8ba90394454a75acb54f1f4a25f9c83 Reviewed-on: https://gerrit.stanford.edu/1564 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index 8e65151..122c0cb 100644 --- a/Makefile.am +++ b/Makefile.am @@ -77,8 +77,9 @@ PERL_DIRECTORIES = perl perl/lib perl/lib/Wallet perl/lib/Wallet/ACL \ perl/lib/Wallet/ACL/NetDB perl/lib/Wallet/Kadmin \ perl/lib/Wallet/Object perl/lib/Wallet/Policy \ perl/lib/Wallet/Schema perl/lib/Wallet/Schema/Result perl/sql \ - perl/t perl/t/data perl/t/docs perl/t/general perl/t/lib \ - perl/t/object perl/t/policy perl/t/util perl/t/verifier + perl/t perl/t/data perl/t/data/duo perl/t/docs perl/t/general \ + perl/t/lib perl/t/object perl/t/policy perl/t/style perl/t/util \ + perl/t/verifier ACLOCAL_AMFLAGS = -I m4 EXTRA_DIST = .gitignore LICENSE autogen client/wallet.pod \ -- cgit v1.2.3 From 4d767409039d268cfbdaff32ee8fce7b748278f4 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 16 Jul 2014 11:57:22 -0700 Subject: Add perl/t/data/perl.conf to PERL_FILES Change-Id: I0d56ea7b64cdcc43bf59f803077d076414b1a1ce Reviewed-on: https://gerrit.stanford.edu/1566 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 100 ++++++++++++++++++++++++++++++------------------------------ 1 file changed, 50 insertions(+), 50 deletions(-) (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index 122c0cb..da452af 100644 --- a/Makefile.am +++ b/Makefile.am @@ -18,56 +18,56 @@ WALLET_PERL_FLAGS ?= # and are not generated or touched by configure. They're listed here to be # added to EXTRA_DIST and so that they can be copied over properly for # builddir != srcdir builds. -PERL_FILES = perl/Build.PL perl/MANIFEST perl/MANIFEST.SKIP \ - perl/lib/Wallet/ACL.pm perl/lib/Wallet/ACL/Base.pm \ - perl/lib/Wallet/ACL/Krb5.pm perl/lib/Wallet/ACL/Krb5/Regex.pm \ - perl/lib/Wallet/ACL/LDAP/Attribute.pm perl/lib/Wallet/ACL/NetDB.pm \ - perl/lib/Wallet/ACL/NetDB/Root.pm perl/lib/Wallet/Admin.pm \ - perl/lib/Wallet/Config.pm perl/lib/Wallet/Database.pm \ - perl/lib/Wallet/Kadmin.pm perl/lib/Wallet/Kadmin/Heimdal.pm \ - perl/lib/Wallet/Kadmin/MIT.pm perl/lib/Wallet/Object/Base.pm \ - perl/lib/Wallet/Object/Duo.pm perl/lib/Wallet/Object/File.pm \ - perl/lib/Wallet/Object/Keytab.pm \ - perl/lib/Wallet/Object/WAKeyring.pm \ - perl/lib/Wallet/Policy/Stanford.pm perl/lib/Wallet/Report.pm \ - perl/lib/Wallet/Schema.pm perl/lib/Wallet/Server.pm \ - perl/lib/Wallet/Schema/Result/Acl.pm \ - perl/lib/Wallet/Schema/Result/AclEntry.pm \ - perl/lib/Wallet/Schema/Result/AclHistory.pm \ - perl/lib/Wallet/Schema/Result/AclScheme.pm \ - perl/lib/Wallet/Schema/Result/Duo.pm \ - perl/lib/Wallet/Schema/Result/Enctype.pm \ - perl/lib/Wallet/Schema/Result/Flag.pm \ - perl/lib/Wallet/Schema/Result/KeytabEnctype.pm \ - perl/lib/Wallet/Schema/Result/KeytabSync.pm \ - perl/lib/Wallet/Schema/Result/Object.pm \ - perl/lib/Wallet/Schema/Result/ObjectHistory.pm \ - perl/lib/Wallet/Schema/Result/SyncTarget.pm \ - perl/lib/Wallet/Schema/Result/Type.pm \ - perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql \ - perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql \ - perl/sql/Wallet-Schema-0.07-MySQL.sql \ - perl/sql/Wallet-Schema-0.07-SQLite.sql \ - perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql \ - perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql \ - perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql \ - perl/sql/Wallet-Schema-0.08-MySQL.sql \ - perl/sql/Wallet-Schema-0.08-PostgreSQL.sql \ - perl/sql/Wallet-Schema-0.08-SQLite.sql \ - perl/sql/Wallet-Schema-0.09-MySQL.sql \ - perl/sql/Wallet-Schema-0.09-PostgreSQL.sql \ - perl/sql/Wallet-Schema-0.09-SQLite.sql perl/t/data/README \ - perl/t/data/duo/integration.json perl/t/data/duo/keys.json \ - perl/t/data/keytab-fake perl/t/data/keytab.conf \ - perl/t/data/netdb.conf perl/t/data/netdb-fake \ - perl/t/docs/pod-spelling.t perl/t/docs/pod.t perl/t/general/acl.t \ - perl/t/general/admin.t perl/t/general/config.t \ - perl/t/general/init.t perl/t/general/report.t \ - perl/t/general/server.t perl/t/lib/Util.pm perl/t/object/base.t \ - perl/t/object/duo.t perl/t/object/file.t perl/t/object/keytab.t \ - perl/t/object/wa-keyring.t perl/t/policy/stanford.t \ - perl/t/style/minimum-version.t perl/t/style/strict.t \ - perl/t/util/kadmin.t perl/t/verifier/basic.t \ +PERL_FILES = perl/Build.PL perl/MANIFEST perl/MANIFEST.SKIP \ + perl/lib/Wallet/ACL.pm perl/lib/Wallet/ACL/Base.pm \ + perl/lib/Wallet/ACL/Krb5.pm perl/lib/Wallet/ACL/Krb5/Regex.pm \ + perl/lib/Wallet/ACL/LDAP/Attribute.pm perl/lib/Wallet/ACL/NetDB.pm \ + perl/lib/Wallet/ACL/NetDB/Root.pm perl/lib/Wallet/Admin.pm \ + perl/lib/Wallet/Config.pm perl/lib/Wallet/Database.pm \ + perl/lib/Wallet/Kadmin.pm perl/lib/Wallet/Kadmin/Heimdal.pm \ + perl/lib/Wallet/Kadmin/MIT.pm perl/lib/Wallet/Object/Base.pm \ + perl/lib/Wallet/Object/Duo.pm perl/lib/Wallet/Object/File.pm \ + perl/lib/Wallet/Object/Keytab.pm \ + perl/lib/Wallet/Object/WAKeyring.pm \ + perl/lib/Wallet/Policy/Stanford.pm perl/lib/Wallet/Report.pm \ + perl/lib/Wallet/Schema.pm perl/lib/Wallet/Server.pm \ + perl/lib/Wallet/Schema/Result/Acl.pm \ + perl/lib/Wallet/Schema/Result/AclEntry.pm \ + perl/lib/Wallet/Schema/Result/AclHistory.pm \ + perl/lib/Wallet/Schema/Result/AclScheme.pm \ + perl/lib/Wallet/Schema/Result/Duo.pm \ + perl/lib/Wallet/Schema/Result/Enctype.pm \ + perl/lib/Wallet/Schema/Result/Flag.pm \ + perl/lib/Wallet/Schema/Result/KeytabEnctype.pm \ + perl/lib/Wallet/Schema/Result/KeytabSync.pm \ + perl/lib/Wallet/Schema/Result/Object.pm \ + perl/lib/Wallet/Schema/Result/ObjectHistory.pm \ + perl/lib/Wallet/Schema/Result/SyncTarget.pm \ + perl/lib/Wallet/Schema/Result/Type.pm \ + perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql \ + perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql \ + perl/sql/Wallet-Schema-0.07-MySQL.sql \ + perl/sql/Wallet-Schema-0.07-SQLite.sql \ + perl/sql/Wallet-Schema-0.08-0.09-MySQL.sql \ + perl/sql/Wallet-Schema-0.08-0.09-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.08-0.09-SQLite.sql \ + perl/sql/Wallet-Schema-0.08-MySQL.sql \ + perl/sql/Wallet-Schema-0.08-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.08-SQLite.sql \ + perl/sql/Wallet-Schema-0.09-MySQL.sql \ + perl/sql/Wallet-Schema-0.09-PostgreSQL.sql \ + perl/sql/Wallet-Schema-0.09-SQLite.sql perl/t/data/README \ + perl/t/data/duo/integration.json perl/t/data/duo/keys.json \ + perl/t/data/keytab-fake perl/t/data/keytab.conf \ + perl/t/data/netdb-fake perl/t/data/netdb.conf perl/t/data/perl.conf \ + perl/t/docs/pod-spelling.t perl/t/docs/pod.t perl/t/general/acl.t \ + perl/t/general/admin.t perl/t/general/config.t \ + perl/t/general/init.t perl/t/general/report.t \ + perl/t/general/server.t perl/t/lib/Util.pm perl/t/object/base.t \ + perl/t/object/duo.t perl/t/object/file.t perl/t/object/keytab.t \ + perl/t/object/wa-keyring.t perl/t/policy/stanford.t \ + perl/t/style/minimum-version.t perl/t/style/strict.t \ + perl/t/util/kadmin.t perl/t/verifier/basic.t \ perl/t/verifier/ldap-attr.t perl/t/verifier/netdb.t # Directories that have to be created in builddir != srcdir builds before -- cgit v1.2.3 From 38323e67f70cab4dce0aef0db3775cbd62e865de Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 16 Jul 2014 12:08:58 -0700 Subject: Change the Perl install rule to reflect Module::Build Change-Id: I36565462a248cef0ff1560b5a1d89a20353d566f Reviewed-on: https://gerrit.stanford.edu/1567 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index da452af..16c0289 100644 --- a/Makefile.am +++ b/Makefile.am @@ -210,11 +210,7 @@ perl/blib/lib/Wallet/Config.pm: $(srcdir)/perl/lib/Wallet/Config.pm cd perl && ./Build install-data-local: - if [ x"$(DESTDIR)" != x ] ; then \ - cd perl && $(MAKE) install DESTDIR=$(DESTDIR)/ ; \ - else \ - cd perl && $(MAKE) install ; \ - fi + cd perl && ./Build install --destdir '$(DESTDIR)' # ExtUtils::MakeMaker really likes moving the Makefile aside. clean-local: -- cgit v1.2.3 From 74924cb23845f60b81f26b87516baafe0e1fae5b Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 16 Jul 2014 12:39:06 -0700 Subject: Work around Automake distcheck process Automake insists on not using DESTDIR for distcheck and instead relying on prefix, but we don't want Perl module installation to follow prefix since that may result in a module install directory that isn't in Perl's search path. So, if and only if we're running under distcheck, we pass the prefix in as --install_base. When copying the Test::RRA Perl modules into the perl/t/lib tree, use separate mkdir and $(INSTALL_DATA) instead of cp -R. The latter copies the read-only permissions, and then distclean cannot remove the files. Change-Id: Ic1879defad993c76384f7c207cd04cb67889a7ac Reviewed-on: https://gerrit.stanford.edu/1568 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index 16c0289..4461fcb 100644 --- a/Makefile.am +++ b/Makefile.am @@ -205,12 +205,28 @@ perl/blib/lib/Wallet/Config.pm: $(srcdir)/perl/lib/Wallet/Config.pm cp "$(srcdir)/$$f" "$(builddir)/$$f" ; \ done ; \ fi - cp -R $(srcdir)/tests/tap/perl/* perl/t/lib/ + mkdir perl/t/lib/Test + $(INSTALL_DATA) $(srcdir)/tests/tap/perl/Test/RRA.pm perl/t/lib/Test/ + mkdir perl/t/lib/Test/RRA + $(INSTALL_DATA) $(srcdir)/tests/tap/perl/Test/RRA/Config.pm \ + perl/t/lib/Test/RRA/ cd perl && perl Build.PL $(WALLET_PERL_FLAGS) cd perl && ./Build +# This is a really ugly hack to only honor prefix when running make install +# under Automake's distcheck. +# +# Automake insists on not using DESTDIR for distcheck and instead relying on +# prefix, but we don't want Perl module installation to follow prefix since +# that may result in a module install directory that isn't in Perl's search +# path. So, if and only if we're running under distcheck, we pass the +# prefix in as --install_base. install-data-local: - cd perl && ./Build install --destdir '$(DESTDIR)' + set -e; flags= ; \ + case "$(prefix)" in \ + */_inst) flags="--install_base $(prefix)" ;; \ + esac ; \ + cd perl && ./Build install $$flags --destdir '$(DESTDIR)' # ExtUtils::MakeMaker really likes moving the Makefile aside. clean-local: -- cgit v1.2.3 From 117bd50d3ef4ed2d8f19dd685ad915134dcd8898 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 16 Jul 2014 13:09:47 -0700 Subject: Include wallet-rekey-periodic in the distribution Change-Id: I3dd9ae38d638cddf2307f5e07cb4a2e01422e172 Reviewed-on: https://gerrit.stanford.edu/1569 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 1 + 1 file changed, 1 insertion(+) (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index 4461fcb..6c06df3 100644 --- a/Makefile.am +++ b/Makefile.am @@ -87,6 +87,7 @@ EXTRA_DIST = .gitignore LICENSE autogen client/wallet.pod \ config/keytab.acl config/wallet config/wallet-report.acl \ docs/design contrib/README contrib/convert-srvtab-db \ contrib/used-principals contrib/wallet-contacts \ + contrib/wallet-rekey-periodic contrib/wallet-rekey-periodic.8 \ contrib/wallet-summary contrib/wallet-summary.8 \ contrib/wallet-unknown-hosts contrib/wallet-unknown-hosts.8 \ docs/design-acl docs/design-api docs/netdb-role-api docs/notes \ -- cgit v1.2.3 From f8963ceb19cd2b503b981f43a3f8c0f45649989f Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 16 Jul 2014 13:31:45 -0700 Subject: Move perl/create-ddl into PERL_FILES to copy it during build Otherwise, there are warnings from Build.PL due to the file missing from the manifest. Change-Id: I32db0199bfda25ab8235ab965bfbbca8bee180b8 Reviewed-on: https://gerrit.stanford.edu/1572 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- Makefile.am | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) (limited to 'Makefile.am') diff --git a/Makefile.am b/Makefile.am index 6c06df3..d6409ea 100644 --- a/Makefile.am +++ b/Makefile.am @@ -18,7 +18,7 @@ WALLET_PERL_FLAGS ?= # and are not generated or touched by configure. They're listed here to be # added to EXTRA_DIST and so that they can be copied over properly for # builddir != srcdir builds. -PERL_FILES = perl/Build.PL perl/MANIFEST perl/MANIFEST.SKIP \ +PERL_FILES = perl/Build.PL perl/MANIFEST perl/MANIFEST.SKIP perl/create-ddl \ perl/lib/Wallet/ACL.pm perl/lib/Wallet/ACL/Base.pm \ perl/lib/Wallet/ACL/Krb5.pm perl/lib/Wallet/ACL/Krb5/Regex.pm \ perl/lib/Wallet/ACL/LDAP/Attribute.pm perl/lib/Wallet/ACL/NetDB.pm \ @@ -92,13 +92,12 @@ EXTRA_DIST = .gitignore LICENSE autogen client/wallet.pod \ contrib/wallet-unknown-hosts contrib/wallet-unknown-hosts.8 \ docs/design-acl docs/design-api docs/netdb-role-api docs/notes \ docs/objects-and-schemes docs/setup docs/stanford-naming \ - examples/stanford.conf perl/create-ddl tests/HOWTO tests/TESTS \ - tests/config/README tests/data/allow-extract tests/data/basic.conf \ - tests/data/cmd-fake tests/data/cmd-wrapper tests/data/fake-data \ - tests/data/fake-kadmin tests/data/fake-keytab \ - tests/data/fake-keytab-2 tests/data/fake-keytab-foreign \ - tests/data/fake-keytab-merge tests/data/fake-keytab-old \ - tests/data/fake-keytab-partial \ + examples/stanford.conf tests/HOWTO tests/TESTS tests/config/README \ + tests/data/allow-extract tests/data/basic.conf tests/data/cmd-fake \ + tests/data/cmd-wrapper tests/data/fake-data tests/data/fake-kadmin \ + tests/data/fake-keytab tests/data/fake-keytab-2 \ + tests/data/fake-keytab-foreign tests/data/fake-keytab-merge \ + tests/data/fake-keytab-old tests/data/fake-keytab-partial \ tests/data/fake-keytab-partial-result tests/data/fake-keytab-rekey \ tests/data/fake-keytab-unknown tests/data/fake-srvtab \ tests/data/full.conf tests/data/perl.conf tests/data/wallet.conf \ -- cgit v1.2.3