From 574a9c0456c182831b3d01a4d7ee0c737b91b107 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 9 Jun 2009 14:39:39 -0700 Subject: Remove Subversion Id strings --- perl/t/admin.t | 1 - 1 file changed, 1 deletion(-) (limited to 'perl/t/admin.t') diff --git a/perl/t/admin.t b/perl/t/admin.t index 4b8302d..7a8b8ae 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -1,5 +1,4 @@ #!/usr/bin/perl -w -# $Id$ # # t/admin.t -- Tests for wallet administrative interface. # -- cgit v1.2.3 From c2cde5918af1882ee63324fd9e09f07c8e6e5cc9 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 9 Jun 2009 16:39:08 -0700 Subject: Add owners report Add a new report owners command to wallet-admin and corresponding report_owners() method to Wallet::Admin, which returns all ACL lines on owner ACLs for matching objects. --- NEWS | 4 ++++ perl/Wallet/Admin.pm | 47 ++++++++++++++++++++++++++++++++++++++++-- perl/t/admin.t | 55 +++++++++++++++++++++++++++++++++++++++++++++++-- server/wallet-admin | 39 ++++++++++++++++++++++++++++++++++- tests/server/admin-t.in | 45 +++++++++++++++++++++++++++++++--------- 5 files changed, 175 insertions(+), 15 deletions(-) (limited to 'perl/t/admin.t') diff --git a/NEWS b/NEWS index e16c630..ab0828b 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,10 @@ wallet 0.10 (unreleased) Fix logging in wallet-backend and the remctl configuration to not log the data passed to store. + Add a new report owners command to wallet-admin and corresponding + report_owners() method to Wallet::Admin, which returns all ACL lines + on owner ACLs for matching objects. + wallet 0.9 (2008-04-24) The wallet command-line client now reads the data for store from a diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index 3a2f687..c11c3d4 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -1,7 +1,7 @@ # Wallet::Admin -- Wallet system administrative interface. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -22,7 +22,7 @@ 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.02'; +$VERSION = '0.03'; ############################################################################## # Constructor, destructor, and accessors @@ -171,6 +171,38 @@ sub list_acls { } } +# Returns a report of all ACL lines 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 report_owners { + my ($self, $type, $name) = @_; + undef $self->{error}; + my @lines; + eval { + my $sql = 'select distinct ae_scheme, ae_identifier from acl_entries, + acls, objects where ae_id = ac_id and ac_id = ob_owner and + ob_type like ? and ob_name like ? order by ae_scheme, + ae_identifier'; + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute ($type, $name); + my $object; + while (defined ($object = $sth->fetchrow_arrayref)) { + push (@lines, [ @$object ]); + } + $self->{dbh}->commit; + }; + if ($@) { + $self->error ("cannot report on owners: $@"); + $self->{dbh}->rollback; + return; + } else { + return @lines; + } +} + ############################################################################## # Object registration ############################################################################## @@ -335,6 +367,17 @@ 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 report_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 diff --git a/perl/t/admin.t b/perl/t/admin.t index 7a8b8ae..8804f34 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -3,11 +3,11 @@ # t/admin.t -- Tests for wallet administrative interface. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. -use Test::More tests => 29; +use Test::More tests => 57; use Wallet::Admin; use Wallet::Schema; @@ -73,6 +73,57 @@ 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 = $admin->report_owners ('%', '%'); +is (scalar (@lines), 0, 'Owner report is currently empty'); +is ($admin->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 = $admin->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 = $admin->report_owners ('keytab', '%'); +is (scalar (@lines), 0, 'Owners of keytabs is empty'); +is ($admin->error, undef, ' with no error'); +@lines = $admin->report_owners ('base', 'foo/%'); +is (scalar (@lines), 0, 'Owners of base foo/* objects is empty'); +is ($admin->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 = $admin->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'); + +# 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 = $admin->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 = $admin->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'); + # Clean up. is ($admin->destroy, 1, 'Destruction succeeds'); unlink 'wallet-db'; diff --git a/server/wallet-admin b/server/wallet-admin index 0daa986..b5674c5 100755 --- a/server/wallet-admin +++ b/server/wallet-admin @@ -3,7 +3,7 @@ # wallet-admin -- Wallet server administrative commands. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -64,6 +64,22 @@ sub command { } else { die "only objects or acls are supported for list\n"; } + } elsif ($command eq 'report') { + die "too few arguments to report\n" if @args < 1; + my $report = shift @args; + if ($report eq 'owners') { + die "too many arguments to report owners\n" if @args > 2; + die "too few arguments to report owners\n" if @args < 2; + my @lines = $admin->report_owners (@args); + if (!@lines and $admin->error) { + die $admin->error, "\n"; + } + for my $line (@lines) { + print join (' ', @$line), "\n"; + } + } else { + die "unknown report type $report\n"; + } } elsif ($command eq 'register') { die "too many arguments to register\n" if @args > 3; die "too few arguments to register\n" if @args < 3; @@ -168,6 +184,27 @@ default as part of database initialization, so this command is used primarily to register local implementations of additional object types or ACL schemes. +=item report [ ... ] + +Runs a wallet report. The currently supported report types are: + +=over 4 + +=item report owners + +Returns a list of all ACL lines in owner ACLs for all objects matching +both and . These can be the type or name of +objects or they can be patterns using C<%> as the wildcard character +following the normal rules of SQL patterns. + +The output will be one line per ACL line in the form: + + + +with duplicates suppressed. + +=back + =back =head1 SEE ALSO diff --git a/tests/server/admin-t.in b/tests/server/admin-t.in index 44ea1fe..3e84022 100644 --- a/tests/server/admin-t.in +++ b/tests/server/admin-t.in @@ -3,12 +3,12 @@ # Tests for the wallet-admin dispatch code. # # Written by Russ Allbery -# Copyright 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. use strict; -use Test::More tests => 54; +use Test::More tests => 64; # Create a dummy class for Wallet::Admin that prints what method was called # with its arguments and returns data for testing. @@ -71,6 +71,13 @@ sub register_verifier { return 1; } +sub report_owners { + shift; + print "report_owners @_\n"; + return if ($error or $empty); + return ([ krb5 => 'admin@EXAMPLE.COM' ]); +} + # Back to the main package and the actual test suite. Lie about whether the # Wallet::Admin package has already been loaded. package main; @@ -98,10 +105,11 @@ is ($err, "unknown command foo\n", 'Unknown command'); is ($out, "new\n", ' and nothing ran'); # Check too few and too many arguments for every command. -my %commands = (destroy => [0, 0], - initialize => [1, 1], - list => [1, 1], - register => [3, 3]); +my %commands = (destroy => [0, 0], + initialize => [1, 1], + list => [1, 1], + register => [3, 3], + report => [1, -1]); for my $command (sort keys %commands) { my ($min, $max) = @{ $commands{$command} }; if ($min > 0) { @@ -110,10 +118,12 @@ for my $command (sort keys %commands) { "Too few arguments for $command"); is ($out, "new\n", ' and nothing ran'); } - ($out, $err) = run_admin ($command, ('foo') x ($max + 1)); - is ($err, "too many arguments to $command\n", - "Too many arguments for $command"); - is ($out, "new\n", ' and nothing ran'); + if ($max >= 0) { + ($out, $err) = run_admin ($command, ('foo') x ($max + 1)); + is ($err, "too many arguments to $command\n", + "Too many arguments for $command"); + is ($out, "new\n", ' and nothing ran'); + } } # Test destroy. @@ -179,6 +189,15 @@ is ($err, '', 'Register succeeds for verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and returns the right outout'); +# Test report. +($out, $err) = run_admin ('report', 'foo'); +is ($err, "unknown report type foo\n", 'Report requires a known report'); +is ($out, "new\n", ' and nothing was run'); +($out, $err) = run_admin ('report', 'owners', '%', '%'); +is ($err, '', 'Report succeeds for owners'); +is ($out, "new\nreport_owners % %\nkrb5 admin\@EXAMPLE.COM\n", + ' and returns the right output'); + # Test error handling. $Wallet::Admin::error = 1; ($out, $err) = run_admin ('destroy'); @@ -204,6 +223,9 @@ is ($out, "new\nregister_object foo Foo::Object\n", is ($err, "some error\n", 'Error handling succeeds for register verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and calls the right methods'); +($out, $err) = run_admin ('report', 'owners', 'foo', 'bar'); +is ($err, "some error\n", 'Error handling succeeds for report owners'); +is ($out, "new\nreport_owners foo bar\n", ' and calls the right methods'); # Test empty lists. $Wallet::Admin::error = 0; @@ -214,3 +236,6 @@ is ($out, "new\nlist_objects\n", ' and calls the right methods'); ($out, $err) = run_admin ('list', 'acls'); is ($err, '', 'list acls runs with an empty list and no errors'); is ($out, "new\nlist_acls\n", ' and calls the right methods'); +($out, $err) = run_admin ('report', 'owners', 'foo', 'bar'); +is ($err, '', 'report owners runs with an empty list and no errors'); +is ($out, "new\nreport_owners foo bar\n", ' and calls the right methods'); -- cgit v1.2.3 From 2c5bd71125d411639b4a61116957879eebae21ad Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 3 Dec 2009 08:52:19 -0800 Subject: Improved wallet-admin list command with searches wallet-admin's list command now has additional searches added for objects and acls that match certain specifiers. For objects these include searching for objects owned by a specific ACL, objects owned by no one, objects of a specific type, objects with a specific flag, and objects for which a specific ACL has any privileges at all. For acls, this includes the ability to search for any ACL with an entry with given type and identifier. --- perl/Wallet/Admin.pm | 167 ++++++++++++++++++++++++++++++++++++++++++++++++--- perl/t/admin.t | 55 ++++++++++++++--- server/wallet-admin | 8 +-- 3 files changed, 206 insertions(+), 24 deletions(-) (limited to 'perl/t/admin.t') diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index c11c3d4..91f1bfb 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -22,7 +22,7 @@ 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.03'; +$VERSION = '0.04'; ############################################################################## # Constructor, destructor, and accessors @@ -114,20 +114,132 @@ sub destroy { # Reporting ############################################################################## +# Given an ACL name, translate it to the ID for that ACL and return it. +# Often this is unneeded and could be done with a join, but by doing it in a +# separate step, we can give an error for the specific case of someone +# searching for a non-existant ACL. +sub acl_name_to_id { + my ($self, $acl) = @_; + my ($id); + eval { + my $sql = 'select ac_id from acls where ac_name=?'; + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute ($acl); + while (defined (my $row = $sth->fetchrow_hashref)) { + $id = $row->{'ac_id'}; + } + $self->{dbh}->commit; + }; + + if (!defined $id || $id !~ /^\d+$/) { + $self->error ("could not find the acl $acl"); + return ''; + } + return $id; +} + +# Return the SQL statement to find every object in the database. +sub list_objects_all { + my ($self) = @_; + my $sql = 'select ob_type, ob_name from objects order by ob_type, + ob_name'; + return $sql; +} + +# Return the SQL statement and the search field required to find all objects +# matching a specific type. +sub list_objects_type { + my ($self, $type) = @_; + my $sql = 'select ob_type, ob_name from objects where ob_type=? order + by ob_type, ob_name'; + return ($sql, $type); +} + +# Return the SQL statement and search field required to find all objects +# owned by a given ACL. If the requested owner is 'null', then 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 the empty string. +sub list_objects_owner { + my ($self, $owner) = @_; + my ($sth); + if ($owner =~ /^null$/i) { + my $sql = 'select ob_type, ob_name from objects where ob_owner is null + order by objects.ob_type, objects.ob_name'; + return ($sql); + } else { + my $id = $self->acl_name_to_id ($owner); + return '' unless $id; + my $sql = 'select ob_type, ob_name from objects where ob_owner=? + order by objects.ob_type, objects.ob_name'; + return ($sql, $id); + } +} + +# Return the SQL statement and search field required to find all objects +# that have a specific flag set. +sub list_objects_flag { + my ($self, $flag) = @_; + my $sql = 'select ob_type, ob_name from objects left join flags on + (objects.ob_type=flags.fl_type AND objects.ob_name=flags.fl_name) + where flags.fl_flag=? order by objects.ob_type, objects.ob_name'; + return ($sql, $flag); +} + +# Return the SQL statement and search field required to find all objects +# that a given ACL has any permissions on. This expands from +# list_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 list_objects_acl { + my ($self, $acl) = @_; + + my $id = $self->acl_name_to_id ($acl); + return '' unless $id; + + my $sql = 'select ob_type, ob_name from objects where + ob_owner=? or ob_acl_get=? or ob_acl_store=? or ob_acl_show=? or + ob_acl_destroy=? or ob_acl_flags=? + order by objects.ob_type, objects.ob_name'; + return ($sql, $id, $id, $id, $id, $id, $id); +} + # 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. +# 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 list_objects { - my ($self) = @_; + my ($self, $type, @args) = @_; undef $self->{error}; + + # Find the SQL statement and the arguments to use. + my $sql = ''; + my @search = (); + if (!defined $type || $type eq '') { + ($sql) = $self->list_objects_all (); + } else { + if (@args != 1) { + $self->error ("object searches require an argument to search"); + } elsif ($type eq 'type') { + ($sql, @search) = $self->list_objects_type (@args); + } elsif ($type eq 'owner') { + ($sql, @search) = $self->list_objects_owner (@args); + } elsif ($type eq 'flag') { + ($sql, @search) = $self->list_objects_flag (@args); + } elsif ($type eq 'acl') { + ($sql, @search) = $self->list_objects_acl (@args); + } else { + $self->error ("do not know search type: $type"); + } + return unless $sql; + } + my @objects; eval { - my $sql = 'select ob_type, ob_name from objects order by ob_type, - ob_name'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute; my $object; + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute (@search); while (defined ($object = $sth->fetchrow_arrayref)) { push (@objects, [ @$object ]); } @@ -142,6 +254,25 @@ sub list_objects { } } +# Returns the SQL statement required to find and return all ACLs in the db. +sub list_acls_all { + my ($self) = @_; + my $sql = 'select ac_id, ac_name from acls order by ac_id'; + return ($sql); +} + +# Returns the SQL statement and the field required to search the ACLs and +# return only those entries which contain a entries with identifiers +# matching a particular given string. +sub list_acls_entry { + my ($self, $type, $identifier) = @_; + my $sql = 'select distinct ac_id, ac_name from acl_entries + left join acls on (ae_id=ac_id) where ae_scheme=? and + ae_identifier like ? order by ac_id'; + $identifier = '%'.$identifier.'%'; + return ($sql, $type, $identifier); +} + # Returns a list of all ACLs stored in the wallet database as a list of pairs # of ACL IDs and ACL names. On error and for an empty database, the empty # list will be returned; however, this is unlikely since any valid database @@ -149,13 +280,29 @@ sub list_objects { # list and an error, call error(), which will return undef if there was no # error. sub list_acls { - my ($self) = @_; + my ($self, $type, @args) = @_; undef $self->{error}; + + # Find the SQL statement and the arguments to use. + my $sql = ''; + my @search = (); + if (!defined $type || $type eq '') { + ($sql) = $self->list_acls_all (); + } else { + if (@args == 0) { + $self->error ("acl searches require an argument to search"); + } elsif ($type eq 'entry') { + ($sql, @search) = $self->list_acls_entry (@args); + } else { + $self->error ("do not know search type: $type"); + } + return unless $sql; + } + my @acls; eval { - my $sql = 'select ac_id, ac_name from acls order by ac_id'; my $sth = $self->{dbh}->prepare ($sql); - $sth->execute; + $sth->execute (@search); my $object; while (defined ($object = $sth->fetchrow_arrayref)) { push (@acls, [ @$object ]); diff --git a/perl/t/admin.t b/perl/t/admin.t index 8804f34..77c786d 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -7,7 +7,7 @@ # # See LICENSE for licensing terms. -use Test::More tests => 57; +use Test::More tests => 77; use Wallet::Admin; use Wallet::Schema; @@ -54,15 +54,6 @@ is ($objects[0][1], 'service/admin', ' and the right name'); is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), 1, 'Registering Wallet::ACL::Base works'); -# Create another ACL. -is ($server->acl_create ('first'), 1, 'ACL creation succeeds'); -@acls = $admin->list_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'); @@ -124,6 +115,50 @@ 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 = $admin->list_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 = $admin->list_objects ('owner', 'null'); +is (scalar (@lines), 1, 'Searching for objects with no set ownerfinds one'); +is ($lines[0][0], 'base', ' and it has the right type'); +is ($lines[0][1], 'service/null', ' and the right name'); +@lines = $admin->list_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 = $admin->list_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 = $admin->list_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 = $admin->list_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'); + # Clean up. is ($admin->destroy, 1, 'Destruction succeeds'); unlink 'wallet-db'; diff --git a/server/wallet-admin b/server/wallet-admin index b5674c5..01fea5c 100755 --- a/server/wallet-admin +++ b/server/wallet-admin @@ -42,11 +42,11 @@ sub command { unless $args[0] =~ /^[^\@\s]+\@\S+$/; $admin->initialize (@args) or die $admin->error, "\n"; } elsif ($command eq 'list') { - die "too many arguments to list\n" if @args > 1; + die "too many arguments to list\n" if @args > 4; die "too few arguments to list\n" if @args < 1; - my ($type) = @args; + my ($type, $subtype, @search) = @args; if ($type eq 'objects') { - my @objects = $admin->list_objects; + my @objects = $admin->list_objects ($subtype, @search); if (!@objects and $admin->error) { die $admin->error, "\n"; } @@ -54,7 +54,7 @@ sub command { print join (' ', @$object), "\n"; } } elsif ($type eq 'acls') { - my @acls = $admin->list_acls; + my @acls = $admin->list_acls ($subtype, @search); if (!@acls and $admin->error) { die $admin->error, "\n"; } -- cgit v1.2.3 From d684049761db4eb88cd936c530196ea89a524c07 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 19 Jan 2010 22:48:01 -0800 Subject: Coding style fixes for Perl wallet code Strip trailing whitespace, convert tabs to spaces, add newlines to exceptions, and remove a few stray blank lines and a few other minor coding style oddities. Make the SQL style consistent. --- perl/Wallet/Admin.pm | 105 +++++++++++++++---------------- perl/Wallet/Kadmin.pm | 10 +-- perl/Wallet/Kadmin/Heimdal.pm | 102 ++++++++++++++---------------- perl/Wallet/Kadmin/MIT.pm | 32 +++++----- perl/Wallet/Object/Base.pm | 12 ++-- perl/Wallet/Object/Keytab.pm | 13 ++-- perl/t/admin.t | 4 +- perl/t/keytab.t | 140 ++++++++++++++++++++---------------------- 8 files changed, 198 insertions(+), 220 deletions(-) (limited to 'perl/t/admin.t') diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index 0e437ec..701c813 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -114,23 +114,22 @@ sub destroy { # Reporting ############################################################################## -# Given an ACL name, translate it to the ID for that ACL and return it. +# Given an ACL name, translate it to the ID for that ACL and return it. # Often this is unneeded and could be done with a join, but by doing it in a -# separate step, we can give an error for the specific case of someone +# separate step, we can give an error for the specific case of someone # searching for a non-existant ACL. sub acl_name_to_id { my ($self, $acl) = @_; my ($id); eval { - my $sql = 'select ac_id from acls where ac_name=?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($acl); - while (defined (my $row = $sth->fetchrow_hashref)) { - $id = $row->{'ac_id'}; - } - $self->{dbh}->commit; + my $sql = 'select ac_id from acls where ac_name = ?'; + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute ($acl); + while (defined (my $row = $sth->fetchrow_hashref)) { + $id = $row->{ac_id}; + } + $self->{dbh}->commit; }; - if (!defined $id || $id !~ /^\d+$/) { $self->error ("could not find the acl $acl"); return ''; @@ -155,7 +154,7 @@ sub list_objects_type { return ($sql, $type); } -# Return the SQL statement and search field required to find all objects +# Return the SQL statement and search field required to find all objects # owned by a given ACL. If the requested owner is 'null', then 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 the empty string. @@ -163,15 +162,15 @@ sub list_objects_owner { my ($self, $owner) = @_; my ($sth); if ($owner =~ /^null$/i) { - my $sql = 'select ob_type, ob_name from objects where ob_owner is null + my $sql = 'select ob_type, ob_name from objects where ob_owner is null order by objects.ob_type, objects.ob_name'; - return ($sql); + return ($sql); } else { - my $id = $self->acl_name_to_id ($owner); - return '' unless $id; - my $sql = 'select ob_type, ob_name from objects where ob_owner=? + my $id = $self->acl_name_to_id ($owner); + return '' unless $id; + my $sql = 'select ob_type, ob_name from objects where ob_owner = ? order by objects.ob_type, objects.ob_name'; - return ($sql, $id); + return ($sql, $id); } } @@ -180,26 +179,24 @@ sub list_objects_owner { sub list_objects_flag { my ($self, $flag) = @_; my $sql = 'select ob_type, ob_name from objects left join flags on - (objects.ob_type=flags.fl_type AND objects.ob_name=flags.fl_name) - where flags.fl_flag=? order by objects.ob_type, objects.ob_name'; + (objects.ob_type = flags.fl_type and objects.ob_name = flags.fl_name) + where flags.fl_flag = ? order by objects.ob_type, objects.ob_name'; return ($sql, $flag); } -# Return the SQL statement and search field required to find all objects +# Return the SQL statement and search field required to find all objects # that a given ACL has any permissions on. This expands from # list_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 list_objects_acl { my ($self, $acl) = @_; - my $id = $self->acl_name_to_id ($acl); return '' unless $id; - - my $sql = 'select ob_type, ob_name from objects where - ob_owner=? or ob_acl_get=? or ob_acl_store=? or ob_acl_show=? or - ob_acl_destroy=? or ob_acl_flags=? - order by objects.ob_type, objects.ob_name'; + my $sql = 'select ob_type, ob_name from objects where ob_owner = ? or + ob_acl_get = ? or ob_acl_store = ? or ob_acl_show = ? or + ob_acl_destroy = ? or ob_acl_flags = ? order by objects.ob_type, + objects.ob_name'; return ($sql, $id, $id, $id, $id, $id, $id); } @@ -217,29 +214,29 @@ sub list_objects { my $sql = ''; my @search = (); if (!defined $type || $type eq '') { - ($sql) = $self->list_objects_all (); + ($sql) = $self->list_objects_all (); } else { - if (@args != 1) { - $self->error ("object searches require an argument to search"); - } elsif ($type eq 'type') { - ($sql, @search) = $self->list_objects_type (@args); - } elsif ($type eq 'owner') { - ($sql, @search) = $self->list_objects_owner (@args); - } elsif ($type eq 'flag') { - ($sql, @search) = $self->list_objects_flag (@args); - } elsif ($type eq 'acl') { - ($sql, @search) = $self->list_objects_acl (@args); - } else { - $self->error ("do not know search type: $type"); - } - return unless $sql; + if (@args != 1) { + $self->error ("object searches require an argument to search"); + } elsif ($type eq 'type') { + ($sql, @search) = $self->list_objects_type (@args); + } elsif ($type eq 'owner') { + ($sql, @search) = $self->list_objects_owner (@args); + } elsif ($type eq 'flag') { + ($sql, @search) = $self->list_objects_flag (@args); + } elsif ($type eq 'acl') { + ($sql, @search) = $self->list_objects_acl (@args); + } else { + $self->error ("do not know search type: $type"); + } + return unless $sql; } my @objects; eval { my $object; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (@search); + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute (@search); while (defined ($object = $sth->fetchrow_arrayref)) { push (@objects, [ @$object ]); } @@ -265,19 +262,19 @@ sub list_acls_all { # the db. sub list_acls_empty { my ($self) = @_; - my $sql = 'select ac_id, ac_name from acls left join acl_entries ' - .'on (acls.ac_id=acl_entries.ae_id) where ae_id is null;'; + my $sql = 'select ac_id, ac_name from acls left join acl_entries + on (acls.ac_id = acl_entries.ae_id) where ae_id is null'; return ($sql); } # Returns the SQL statement and the field required to search the ACLs and -# return only those entries which contain a entries with identifiers +# return only those entries which contain a entries with identifiers # matching a particular given string. sub list_acls_entry { my ($self, $type, $identifier) = @_; - my $sql = 'select distinct ac_id, ac_name from acl_entries - left join acls on (ae_id=ac_id) where ae_scheme=? and - ae_identifier like ? order by ac_id'; + my $sql = 'select distinct ac_id, ac_name from acl_entries left join acls + on (ae_id = ac_id) where ae_scheme = ? and ae_identifier like ? order + by ac_id'; $identifier = '%'.$identifier.'%'; return ($sql, $type, $identifier); } @@ -299,11 +296,11 @@ sub list_acls { ($sql) = $self->list_acls_all (); } else { if ($type eq 'entry') { - if (@args == 0) { - $self->error ("acl searches require an argument to search"); - } else { - ($sql, @search) = $self->list_acls_entry (@args); - } + if (@args == 0) { + $self->error ("acl searches require an argument to search"); + } else { + ($sql, @search) = $self->list_acls_entry (@args); + } } elsif ($type eq 'empty') { ($sql) = $self->list_acls_empty (); } else { diff --git a/perl/Wallet/Kadmin.pm b/perl/Wallet/Kadmin.pm index 33c84a1..200136c 100644 --- a/perl/Wallet/Kadmin.pm +++ b/perl/Wallet/Kadmin.pm @@ -27,8 +27,8 @@ $VERSION = '0.02'; ############################################################################## # Validate a principal with a submodule's validator. We can also do this via -# creating an object with new and then running valid_principal from that, -# but there are times we might wish to run it without going through the +# creating an object with new and then running valid_principal from that, +# but there are times we might wish to run it without going through the # object creation. sub valid_principal { my ($class, $principal) = @_; @@ -48,10 +48,10 @@ sub new { my ($class) = @_; my ($kadmin); if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - require Wallet::Kadmin::MIT; + require Wallet::Kadmin::MIT; $kadmin = Wallet::Kadmin::MIT->new (); } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - require Wallet::Kadmin::Heimdal; + require Wallet::Kadmin::Heimdal; $kadmin = Wallet::Kadmin::Heimdal->new (); } else { die "keytab krb server type not set to a valid value\n"; @@ -82,7 +82,7 @@ Wallet::Kadmin - Kadmin module wrapper for wallet keytabs =head1 DESCRIPTION Wallet::Kadmin is a wrapper to modules that provide an interface for keytab -integration with the wallet. Each module is meant to interface with a +integration with the wallet. Each module is meant to interface with a specific type of Kerberos implementation, such as MIT Kerberos or Heimdal Kerberos, and provide a standndard set of API calls used to interact with that implementation's kadmind. diff --git a/perl/Wallet/Kadmin/Heimdal.pm b/perl/Wallet/Kadmin/Heimdal.pm index e4d175b..a8859bf 100644 --- a/perl/Wallet/Kadmin/Heimdal.pm +++ b/perl/Wallet/Kadmin/Heimdal.pm @@ -15,8 +15,7 @@ require 5.006; use strict; use vars qw($VERSION); -use Heimdal::Kadm5 qw (KRB5_KDB_DISALLOW_ALL_TIX); - +use Heimdal::Kadm5 qw(KRB5_KDB_DISALLOW_ALL_TIX); use Wallet::Config (); # This version should be increased on any code change to this module. Always @@ -37,7 +36,7 @@ sub valid_principal { return scalar ($principal =~ m,^[\w-]+(/[\w_.-]+)?\z,); } -# Create a Heimdal::Kadm5 client object and return it. It should load +# Create a Heimdal::Kadm5 client object and return it. It should load # configuration from Wallet::Config. sub kadmin_client { unless (defined ($Wallet::Config::KEYTAB_PRINCIPAL) @@ -45,15 +44,13 @@ sub kadmin_client { and defined ($Wallet::Config::KEYTAB_REALM)) { die "keytab object implementation not configured\n"; } - my $server = $Wallet::Config::KEYTAB_HOST || 'localhost'; - my $client = Heimdal::Kadm5::Client->new( - RaiseErrors => 1, - Server => $server, - Principal => $Wallet::Config::KEYTAB_PRINCIPAL, - Realm => $Wallet::Config::KEYTAB_REALM, - Keytab => $Wallet::Config::KEYTAB_FILE, - ); + my @options = (RaiseErrors => 1, + Server => $server, + Principal => $Wallet::Config::KEYTAB_PRINCIPAL, + Realm => $Wallet::Config::KEYTAB_REALM, + Keytab => $Wallet::Config::KEYTAB_FILE); + my $client = Heimdal::Kadm5::Client->new (@options); return $client; } @@ -70,16 +67,8 @@ sub exists { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; } my $kadmin = $self->{client}; - my $princdata = eval { $kadmin->getPrincipal ($principal) }; - - if ($@) { - die $@; - return 0; - } elsif ($princdata) { - return 1; - } else { - return 0; - } + my $princdata = $kadmin->getPrincipal ($principal); + return $princdata ? 1 : 0; } # Create a principal in Kerberos. Since this is only called by create, it @@ -95,7 +84,7 @@ sub addprinc { if ($Wallet::Config::KEYTAB_REALM) { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; } - die "error adding principal $principal: $@" if $@; + die "error adding principal $principal: $@\n" if $@; return 1 if $exists; # The way Heimdal::Kadm5 works, we create a principal object, create the @@ -106,20 +95,19 @@ sub addprinc { my $kadmin = $self->{client}; my $princdata = $kadmin->makePrincipal ($principal); - # Disable the principal before creating, until we've randomized the + # Disable the principal before creating, until we've randomized the # password. my $attrs = $princdata->getAttributes; $attrs |= KRB5_KDB_DISALLOW_ALL_TIX; $princdata->setAttributes ($attrs); my $password = 'inactive'; - my $retval = eval { $kadmin->createPrincipal ($princdata, $password, 0) }; - die "error adding principal $principal: $@" if $@; - $retval = eval { $kadmin->randKeyPrincipal ($principal) }; - die "error adding principal $principal: $@" if $@; - $retval = eval { $kadmin->enablePrincipal ($principal) }; + eval { + $kadmin->createPrincipal ($princdata, $password, 0); + $kadmin->randKeyPrincipal ($principal); + $kadmin->enablePrincipal ($principal); + }; die "error adding principal $principal: $@" if $@; - return 1; } @@ -130,7 +118,7 @@ sub addprinc { sub ktadd { my ($self, $principal, $file, @enctypes) = @_; unless ($self->valid_principal ($principal)) { - die ("invalid principal name: $principal"); + die "invalid principal name: $principal\n"; } if ($Wallet::Config::KEYTAB_REALM) { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; @@ -138,35 +126,35 @@ sub ktadd { # 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 + # 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) }; - die "error creating keytab for $principal: could not reinit enctypes: $@" + die "error creating keytab for $principal: could not reinit enctypes: $@\n" if $@; my $princdata = eval { $kadmin->getPrincipal ($principal) }; if ($@) { - die "error creating keytab for $principal: $@"; + die "error creating keytab for $principal: $@\n"; } elsif (!$princdata) { - die "error creating keytab for $principal: principal does not exist"; + die "error creating keytab for $principal: principal does not exist\n"; } # Now actually remove any non-requested enctypes, if we requested any. if (@enctypes) { - my (%wanted); - my $alltypes = $princdata->getKeytypes (); - foreach (@enctypes) { $wanted{$_} = 1 } - foreach my $key (@{$alltypes}) { - my $keytype = ${$key}[0]; - next if exists $wanted{$keytype}; - eval { $princdata->delKeytypes ($keytype) }; - die "error removing keytype $keytype from the keytab: $@" if $@; - } - eval { $kadmin->modifyPrincipal ($princdata) }; + my (%wanted); + my $alltypes = $princdata->getKeytypes (); + foreach (@enctypes) { $wanted{$_} = 1 } + foreach my $key (@{$alltypes}) { + my $keytype = ${$key}[0]; + next if exists $wanted{$keytype}; + eval { $princdata->delKeytypes ($keytype) }; + die "error removing keytype $keytype from the keytab: $@\n" if $@; + } + eval { $kadmin->modifyPrincipal ($princdata) }; } eval { $kadmin->extractKeytab ($princdata, $file) }; - die "error creating keytab for principal: $@" if $@; + die "error creating keytab for principal: $@\n" if $@; return 1; } @@ -177,7 +165,7 @@ sub ktadd { sub delprinc { my ($self, $principal) = @_; unless ($self->valid_principal ($principal)) { - die ("invalid principal name: $principal"); + die "invalid principal name: $principal\n"; } my $exists = eval { $self->exists ($principal) }; die $@ if $@; @@ -190,7 +178,7 @@ sub delprinc { my $kadmin = $self->{client}; my $retval = eval { $kadmin->deletePrincipal ($principal) }; - die "error deleting $principal: $@" if $@; + die "error deleting $principal: $@\n" if $@; return 1; } @@ -199,12 +187,12 @@ sub delprinc { ############################################################################## # 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 +# will probably fill out if we go to using a module rather than calling # kadmin directly. sub new { my ($class) = @_; my $self = { - client => kadmin_client (), + client => kadmin_client (), }; bless ($self, $class); return $self; @@ -235,7 +223,7 @@ Wallet::Kadmin::MIT is an interface for keytab integration with the wallet, specifically for using kadmin to create, delete, and add enctypes to keytabs. It implments the wallet kadmin API and provides the necessary glue to MIT Kerberos installs for each of these functions, while allowing the wallet -to keep the details of what type of Kerberos installation is being used +to keep the details of what type of Kerberos installation is being used abstracted. A keytab is an on-disk store for the key or keys for a Kerberos principal. @@ -254,15 +242,15 @@ information about how to set wallet configuration. =item addprinc(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 +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, or throws an error if there was a failure in adding the principal. -If the principal already exists, return true as we are bringing our +If the principal already exists, return true as we are bringing our expectations in line with reality. =item addprinc(PRINCIPAL) -Removes a principal with the given name. Returns true on success, or throws +Removes a principal with the given name. Returns true on success, or throws an error if there was a failure in removing the principal. If the principal does not exist, return true as we are bringing our expectations in line with reality. @@ -270,8 +258,8 @@ reality. =item ktadd(PRINCIPAL, FILE, ENCTYPES) Creates a new keytab for the given principal, as the given file, limited to -the enctypes supplied. The enctype values must be enctype strings recognized -by Kerberos (strings like C or C). An error is +the enctypes supplied. The enctype values must be enctype strings recognized +by Kerberos (strings like C or C). An error is thrown on failure or if the creation fails, otherwise true is returned. =back @@ -279,7 +267,7 @@ thrown on failure or if the creation fails, otherwise true is returned. =head1 LIMITATIONS Currently, this implementation calls an external B program rather - than using a native Perl module and therefore requires B be + 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. diff --git a/perl/Wallet/Kadmin/MIT.pm b/perl/Wallet/Kadmin/MIT.pm index b7d4913..7bbb248 100644 --- a/perl/Wallet/Kadmin/MIT.pm +++ b/perl/Wallet/Kadmin/MIT.pm @@ -130,7 +130,7 @@ sub addprinc { sub ktadd { my ($self, $principal, $file, @enctypes) = @_; unless ($self->valid_principal ($principal)) { - die ("invalid principal name: $principal"); + die "invalid principal name: $principal\n"; } if ($Wallet::Config::KEYTAB_REALM) { $principal .= '@' . $Wallet::Config::KEYTAB_REALM; @@ -143,7 +143,7 @@ sub ktadd { my $output = eval { $self->kadmin ("$command $principal") }; die ($@) if ($@); if ($output =~ /^(?:kadmin|ktadd): (.*)/m) { - die ("error creating keytab for $principal: $1"); + die "error creating keytab for $principal: $1\n"; } return 1; } @@ -154,7 +154,7 @@ sub ktadd { sub delprinc { my ($self, $principal) = @_; unless ($self->valid_principal ($principal)) { - die ("invalid principal name: $principal"); + die "invalid principal name: $principal\n"; } my $exists = eval { $self->exists ($principal) }; die $@ if $@; @@ -167,7 +167,7 @@ sub delprinc { my $output = eval { $self->kadmin ("delprinc -force $principal") }; die $@ if $@; if ($output =~ /^delete_principal: (.*)/m) { - die ("error deleting $principal: $1"); + die "error deleting $principal: $1\n"; } return 1; } @@ -177,12 +177,11 @@ sub delprinc { ############################################################################## # 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 +# will probably fill out if we go to using a module rather than calling # kadmin directly. sub new { my ($class) = @_; - my $self = { - }; + my $self = {}; bless ($self, $class); return $self; } @@ -212,7 +211,7 @@ Wallet::Kadmin::MIT is an interface for keytab integration with the wallet, specifically for using kadmin to create, delete, and add enctypes to keytabs. It implments the wallet kadmin API and provides the necessary glue to MIT Kerberos installs for each of these functions, while allowing the wallet -to keep the details of what type of Kerberos installation is being used +to keep the details of what type of Kerberos installation is being used abstracted. A keytab is an on-disk store for the key or keys for a Kerberos principal. @@ -231,15 +230,15 @@ information about how to set wallet configuration. =item addprinc(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 +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, or throws an error if there was a failure in adding the principal. -If the principal already exists, return true as we are bringing our +If the principal already exists, return true as we are bringing our expectations in line with reality. =item addprinc(PRINCIPAL) -Removes a principal with the given name. Returns true on success, or throws +Removes a principal with the given name. Returns true on success, or throws an error if there was a failure in removing the principal. If the principal does not exist, return true as we are bringing our expectations in line with reality. @@ -247,8 +246,8 @@ reality. =item ktadd(PRINCIPAL, FILE, ENCTYPES) Creates a new keytab for the given principal, as the given file, limited to -the enctypes supplied. The enctype values must be enctype strings recognized -by Kerberos (strings like C or C). An error is +the enctypes supplied. The enctype values must be enctype strings recognized +by Kerberos (strings like C or C). An error is thrown on failure or if the creation fails, otherwise true is returned. =back @@ -256,7 +255,7 @@ thrown on failure or if the creation fails, otherwise true is returned. =head1 LIMITATIONS Currently, this implementation calls an external B program rather - than using a native Perl module and therefore requires B be +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. @@ -269,7 +268,6 @@ from L. =head1 AUTHORS -Russ Allbery -Jon Robertson +Russ Allbery and Jon Robertson . =cut diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm index f2568eb..fea0320 100644 --- a/perl/Wallet/Object/Base.pm +++ b/perl/Wallet/Object/Base.pm @@ -445,7 +445,7 @@ sub flag_set { # History ############################################################################## -# Expand a given ACL id to add its name, for readability. Returns the +# 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) = @_; @@ -455,7 +455,7 @@ sub format_acl_id { my $sth = $self->{dbh}->prepare ($sql); $sth->execute ($id); if (my @ref = $sth->fetchrow_array) { - $name = $ref[0] . " ($id)"; + $name = $ref[0] . " ($id)"; } return $name; @@ -492,11 +492,11 @@ sub history { } elsif (defined ($new)) { $output .= "add $new to attribute $attr"; } - } elsif ($data[0] eq 'set' - and ($data[1] eq 'owner' or $data[1] =~ /^acl_/)) { + } elsif ($data[0] eq 'set' + and ($data[1] eq 'owner' or $data[1] =~ /^acl_/)) { my $field = $data[1]; - $old = $self->format_acl_id ($old) if defined ($old); - $new = $self->format_acl_id ($new) if defined ($new); + $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)) { diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index b1c9d6d..a361599 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -1,7 +1,7 @@ # Wallet::Object::Keytab -- Keytab object implementation for the wallet. # # Written by Russ Allbery -# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University +# Copyright 2007, 2008, 2009 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -477,15 +477,14 @@ sub new { # caller. sub create { my ($class, $type, $name, $dbh, $creator, $host, $time) = @_; - my $self = { - dbh => $dbh, - kadmin => undef, + my $self = { + dbh => $dbh, + kadmin => undef, }; bless $self, $class; my $kadmin = Wallet::Kadmin->new (); $self->{kadmin} = $kadmin; $kadmin->addprinc ($name); - $self = $class->SUPER::create ($type, $name, $dbh, $creator, $host, $time); $self->{kadmin} = $kadmin; return $self; @@ -556,8 +555,8 @@ sub get { my $kadmin = $self->{kadmin}; my $retval = eval { $kadmin->ktadd ($self->{name}, $file, @enctypes) }; if ($@) { - $self->error ($@); - return; + $self->error ($@); + return; } return unless $retval; local *KEYTAB; diff --git a/perl/t/admin.t b/perl/t/admin.t index 77c786d..e963857 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -120,7 +120,7 @@ is ($lines[2][1], 'admin@EXAMPLE.COM', ' and the right identifier'); # 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, +is ($server->acl ('base', 'service/foo', 'get', 'ADMIN'), 1, 'Changing the get ACL for the search also does'); @lines = $admin->list_objects ('owner', 'ADMIN'); is (scalar (@lines), 1, 'Searching for objects owned by ADMIN finds one'); @@ -150,7 +150,7 @@ is ($lines[2][1], 'service/null', ' and the right name'); 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, +is ($server->flag_set ('base', 'service/admin', 'unchanging'), 1, 'Setting a flag works'); @lines = $admin->list_objects ('flag', 'unchanging'); is (scalar (@lines), 1, 'Searching for all objects with that flag finds one'); diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 5c9ee68..3cd77d8 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -8,7 +8,7 @@ # See LICENSE for licensing terms. use POSIX qw(strftime); -use Test::More tests => 221; +use Test::More tests => 219; use Wallet::Admin; use Wallet::Config; @@ -57,15 +57,15 @@ sub system_quiet { sub create { my ($principal) = @_; if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', - '-t', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - '-q', "addprinc -clearpolicy -randkey $principal"); + my @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', + '-t', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + '-q', "addprinc -clearpolicy -randkey $principal"); } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, - '-K', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - 'add', $principal); + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, + '-K', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + 'add', $principal); } system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args); } @@ -76,15 +76,15 @@ sub destroy { my ($principal) = @_; my (@args); if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', - '-t', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - '-q', "delprinc -force $principal"); + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, '-k', + '-t', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + '-q', "delprinc -force $principal"); } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, - '-K', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - 'delete', $principal); + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, + '-K', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + 'delete', $principal); } system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args); } @@ -95,15 +95,15 @@ sub created { my ($principal) = @_; $principal .= '@' . $Wallet::Config::KEYTAB_REALM; if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - local $ENV{KRB5CCNAME} = 'krb5cc_temp'; - getcreds ('t/data/test.keytab', $Wallet::Config::KEYTAB_PRINCIPAL); - return (system_quiet ('kvno', $principal) == 0); + local $ENV{KRB5CCNAME} = 'krb5cc_temp'; + getcreds ('t/data/test.keytab', $Wallet::Config::KEYTAB_PRINCIPAL); + return (system_quiet ('kvno', $principal) == 0); } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, - '-K', $Wallet::Config::KEYTAB_FILE, - '-r', $Wallet::Config::KEYTAB_REALM, - 'get', $principal); - return (system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args) == 0); + @args = ('-p', $Wallet::Config::KEYTAB_PRINCIPAL, + '-K', $Wallet::Config::KEYTAB_FILE, + '-r', $Wallet::Config::KEYTAB_REALM, + 'get', $principal); + return (system_quiet ($Wallet::Config::KEYTAB_KADMIN, @args) == 0); } } @@ -135,28 +135,28 @@ sub enctypes { my @enctypes; if ($Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { - open (KLIST, '-|', '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; + open (KLIST, '-|', '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; } elsif ($Wallet::Config::KEYTAB_KRBTYPE eq 'Heimdal') { - 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; + 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; @@ -298,16 +298,15 @@ EOO is ($object->error, 'KEYTAB_TMP configuration variable not set', ' with the right error'); $Wallet::Config::KEYTAB_TMP = '.'; - 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'; + 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); @@ -323,19 +322,16 @@ EOO }; 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'; + 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", @@ -713,8 +709,10 @@ EOO # Tests for enctype restriction. SKIP: { - skip 'no keytab configuration', 36 unless (-f 't/data/test.keytab' - && $Wallet::Config::KEYTAB_KRBTYPE eq 'MIT'); + unless (-f 't/data/test.keytab' + && $Wallet::Config::KEYTAB_KRBTYPE eq 'MIT') { + skip 'no keytab configuration', 36; + } # Set up our configuration. $Wallet::Config::KEYTAB_FILE = 't/data/test.keytab'; @@ -810,7 +808,6 @@ EOO ok (defined ($keytab), ' and retrieving the keytab still works'); @values = enctypes ($keytab); is ("@values", $enctypes[0], ' and it has the right enctype'); - ok (defined ($one), ' and recreating it succeeds'); is ($one->attr ('enctypes', [ $enctypes[1] ], @trace), 1, 'Setting a different single enctype works'); @values = $one->attr ('enctypes'); @@ -819,7 +816,6 @@ EOO ok (defined ($keytab), ' and retrieving the keytab still works'); @values = enctypes ($keytab); is ("@values", $enctypes[1], ' and it has the right enctype'); - ok (defined ($one), ' and recreating it succeeds'); is ($one->attr ('enctypes', [ @enctypes[0..1] ], @trace), 1, 'Setting two enctypes works'); @values = $one->attr ('enctypes'); -- cgit v1.2.3 From aca12f7b67b987c4392d85b4aa9d2dc1861b7556 Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 21 Jan 2010 19:06:54 -0800 Subject: Replaced perl/t/admin.t tests removed earlier Several tests were removed in an earlier edit that should not have been. As far as I can tell, they were removed completely by accident. These missing tests were causing the test suite to fail. --- perl/t/admin.t | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'perl/t/admin.t') diff --git a/perl/t/admin.t b/perl/t/admin.t index e963857..f94b39b 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -7,7 +7,7 @@ # # See LICENSE for licensing terms. -use Test::More tests => 77; +use Test::More tests => 83; use Wallet::Admin; use Wallet::Schema; @@ -54,6 +54,15 @@ is ($objects[0][1], 'service/admin', ' and the right name'); is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), 1, 'Registering Wallet::ACL::Base works'); +# Create another ACL. +is ($server->acl_create ('first'), 1, 'ACL creation succeeds'); +@acls = $admin->list_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'); -- cgit v1.2.3 From 345333f027be0b34318584b3f1b5e3e12adcaa98 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Fri, 19 Feb 2010 01:21:48 -0800 Subject: Refactor reporting into a separate module and script Move all reporting from Wallet::Admin to Wallet::Report and simplify the method names since they're now part of a dedicated reporting class. Similarly, create a new wallet-report script to wrap Wallet::Report, moving all reporting commands to it from wallet-admin, and simplify the commands since they're for a dedicated reporting script. Remove the contrib script wallet-report to wallet-summary so that it doesn't conflict with the new reporting backend script. --- Makefile.am | 24 +-- NEWS | 27 +-- TODO | 2 - autogen | 6 +- contrib/wallet-report | 240 -------------------------- contrib/wallet-summary | 240 ++++++++++++++++++++++++++ perl/Wallet/Admin.pm | 311 +-------------------------------- perl/Wallet/Report.pm | 425 ++++++++++++++++++++++++++++++++++++++++++++++ perl/t/admin.t | 143 ++-------------- perl/t/report.t | 171 +++++++++++++++++++ server/wallet-report | 203 ++++++++++++++++++++++ tests/docs/pod-spelling-t | 2 +- tests/docs/pod-t | 2 +- tests/server/admin-t | 76 +-------- tests/server/report-t | 151 ++++++++++++++++ 15 files changed, 1246 insertions(+), 777 deletions(-) delete mode 100755 contrib/wallet-report create mode 100755 contrib/wallet-summary create mode 100644 perl/Wallet/Report.pm create mode 100755 perl/t/report.t create mode 100755 server/wallet-report create mode 100755 tests/server/report-t (limited to 'perl/t/admin.t') diff --git a/Makefile.am b/Makefile.am index db6738a..05ffe53 100644 --- a/Makefile.am +++ b/Makefile.am @@ -16,9 +16,10 @@ PERL_FILES = perl/Wallet/ACL.pm perl/Wallet/ACL/Base.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/Schema.pm \ - perl/Wallet/Server.pm 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/Wallet/Object/Keytab.pm perl/Wallet/Report.pm \ + perl/Wallet/Schema.pm perl/Wallet/Server.pm 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/init.t \ perl/t/keytab.t perl/t/lib/Util.pm perl/t/object.t perl/t/pod.t \ perl/t/schema.t perl/t/server.t perl/t/verifier-netdb.t \ @@ -28,14 +29,17 @@ AUTOMAKE_OPTIONS = foreign subdir-objects ACLOCAL_AMFLAGS = -I m4 EXTRA_DIST = LICENSE autogen client/wallet.pod config/allow-extract \ config/keytab config/keytab.acl config/wallet docs/design \ - contrib/README contrib/wallet-report contrib/wallet-report.8 \ + contrib/README contrib/wallet-summary contrib/wallet-summary.8 \ docs/design-acl docs/design-api docs/netdb-role-api docs/notes \ docs/setup examples/stanford.conf tests/TESTS tests/data/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-merge tests/data/fake-keytab-old \ - tests/data/fake-srvtab tests/data/wallet.conf $(PERL_FILES) + tests/data/fake-srvtab 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 \ + $(PERL_FILES) noinst_LIBRARIES = portable/libportable.a util/libutil.a portable_libportable_a_SOURCES = portable/dummy.c portable/krb5-extra.c \ @@ -74,11 +78,11 @@ warnings: # Remove some additional files. DISTCLEANFILES = perl/Makefile tests/data/.placeholder -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 \ - contrib/wallet-report.8 server/keytab-backend.8 \ - server/wallet-backend.8 +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 \ + contrib/wallet-report.8 server/keytab-backend.8 \ + server/wallet-admin.8 server/wallet-backend.8 server/wallet-report.8 # Take appropriate actions in the Perl directory as well. We don't want to # always build the Perl directory in all-local, since otherwise Automake does diff --git a/NEWS b/NEWS index 96962f8..a87ae2f 100644 --- a/NEWS +++ b/NEWS @@ -32,15 +32,22 @@ wallet 0.10 (unreleased) Fix logging in wallet-backend and the remctl configuration to not log the data passed to store. - Add additional reports for wallet-admin list: objects owned by a - specific ACL, objects owned by no one, objects of a specific type, - objects with a specific flag, objects for which a specific ACL has - privileges, ACLs with an entry with a given type and identifier, and - ACLs with no members. - - Add a new report owners command to wallet-admin and corresponding - report_owners() method to Wallet::Admin, which returns all ACL lines - on owner ACLs for matching objects. + Move all reporting from Wallet::Admin to Wallet::Report and simplify + the method names since they're now part of a dedicated reporting + class. Similarly, create a new wallet-report script to wrap + Wallet::Report, moving all reporting commands to it from wallet-admin, + and simplify the commands since they're for a dedicated reporting + script. + + Add additional reports for wallet-report: objects owned by a specific + ACL, objects owned by no one, objects of a specific type, objects with + a specific flag, objects for which a specific ACL has privileges, ACLs + with an entry with a given type and identifier, and ACLs with no + members. + + Add a new owners command to wallet-report and corresponding owners() + method to Wallet::Report, which returns all ACL lines on owner ACLs + for matching objects. Report ACL names as well as numbers in object history. @@ -50,7 +57,7 @@ wallet 0.10 (unreleased) implementation than the wallet client. This primarily helps with testing. - Update to rra-c-util 3.0: + Update to rra-c-util 2.3: * Use Kerberos portability layer to support Heimdal. * Avoid Kerberos API calls deprecated on Heimdal. diff --git a/TODO b/TODO index 662ea47..cca8780 100644 --- a/TODO +++ b/TODO @@ -2,8 +2,6 @@ Release 0.10: -* Move reporting code from Wallet::Admin to Wallet::Report. - * Check whether we can just drop the realm restriction on keytabs and allow the name to contain the realm if the Kerberos type is Heimdal. diff --git a/autogen b/autogen index aeb4339..f7c8055 100755 --- a/autogen +++ b/autogen @@ -11,11 +11,13 @@ rm -rf autom4te.cache version=`grep '^wallet' NEWS | head -1 | cut -d' ' -f2` pod2man --release="$version" --center=wallet client/wallet.pod \ > client/wallet.1 -pod2man --release="$version" --center=wallet -s 8 contrib/wallet-report \ - > contrib/wallet-report.8 +pod2man --release="$version" --center=wallet -s 8 contrib/wallet-summary \ + > contrib/wallet-summary.8 pod2man --release="$version" --center=wallet -s 8 server/keytab-backend \ > server/keytab-backend.8 pod2man --release="$version" --center=wallet -s 8 server/wallet-admin \ > server/wallet-admin.8 pod2man --release="$version" --center=wallet -s 8 server/wallet-backend \ > server/wallet-backend.8 +pod2man --release="$version" --center=wallet -s 8 server/wallet-report \ + > server/wallet-report.8 diff --git a/contrib/wallet-report b/contrib/wallet-report deleted file mode 100755 index 1abe1f8..0000000 --- a/contrib/wallet-report +++ /dev/null @@ -1,240 +0,0 @@ -#!/usr/bin/perl -w -# -# wallet-report -- Report on keytabs in the wallet database. -# -# Written by Russ Allbery -# Copyright 2003, 2008 Board of Trustees, Leland Stanford Jr. University -# -# See LICENSE for licensing terms. - -############################################################################## -# Site configuration -############################################################################## - -# Path to the infrastructure reports directory. -$REPORTS = '/afs/ir/dept/itss/infrastructure/reports'; - -# Address to which to mail the report. -$ADDRESS = 'nobody@example.com'; - -# The various classification patterns for srvtabs. -@PATTERNS - = ([qr(/cgi\z), '*/cgi', 'CGI users'], - [qr(^(?i)http/), 'HTTP/*', 'HTTP Negotiate-Auth'], - [qr(^cifs/), 'cifs/*', 'CIFS'], - [qr(^host/), 'host/*', 'Host login'], - [qr(^ident/), 'ident/*', 'S/Ident'], - [qr(^imap/), 'imap/*', 'IMAP'], - [qr(^ldap/), 'ldap/*', 'LDAP'], - [qr(^nfs/), 'nfs/*', 'NFS'], - [qr(^pop/), 'pop/*', 'Kerberized POP'], - [qr(^sieve/), 'sieve/*', 'Sieve mail sorting'], - [qr(^smtp/), 'smtp/*', 'SMTP'], - [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::Admin (); - -############################################################################## -# Database queries -############################################################################## - -# Return a list of keytab objects in the wallet database. Currently, we only -# report on keytab objects; reports for other objects will be added later. -sub list_keytabs { - my $admin = Wallet::Admin->new; - my @objects = $admin->list_objects; - if (!@objects and $admin->error) { - die $admin->error; - } - return map { $$_[1] } grep { $$_[0] eq 'keytab' } @objects; -} - -############################################################################## -# Reporting -############################################################################## - -# Used to make heredocs look pretty. -sub unquote { my ($string) = @_; $string =~ s/^:( {0,7}|\t)//gm; $string } - -# Given an array of principal names, classify them into various interesting -# groups and then report on the total number of principals, broken down by the -# individual groups. -sub report_principals { - my @principals = @_; - my (%count, $found); - - # Count the principals in each category. - for (@principals) { - $found = 0; - for my $mapping (@PATTERNS) { - if (/$$mapping[0]/) { - $count{$$mapping[1]}++; - $found = 1; - last; - } - } - $count{OTHER}++ unless $found; - } - my $total = scalar @principals; - - # Find the longest label for any principal type. - my ($taglen, $desclen) = (0, 0); - for (@PATTERNS) { - next unless $count{$$_[1]}; - $taglen = length ($$_[1]) if length ($$_[1]) > $taglen; - $desclen = length ($$_[2]) if length ($$_[2]) > $desclen; - } - $taglen = 6 if $taglen < 6; - - # Print the report. - print unquote (<<"EOM"); -: This is a summary of the current keytab entries in the wallet database, -: which contain entries for every principal that is managed by our -: Kerberos keytab management system. Not all of these principals may -: necessarily be in active use. Principals corresponding to hosts which -: are no longer registered in NetDB are purged periodically. -: -EOM - printf ("%-${taglen}s Count %-${desclen}s\n", 'Type', 'Description'); - print '-' x $taglen, ' ----- ', '-' x $desclen, "\n"; - for (@PATTERNS) { - next unless $count{$$_[1]}; - printf ("%-${taglen}s %5d %s\n", $$_[1], $count{$$_[1]}, $$_[2]); - } - if ($count{OTHER}) { - print "\n"; - printf ("%-${taglen}s %5d %s\n", '', $count{OTHER}, 'Other'); - } - print ' ' x $taglen, ' ', '=====', "\n"; - printf ("%${taglen}s %5d\n", 'Total:', $total); -} - -############################################################################## -# Main routine -############################################################################## - -# Read in command-line options. -my ($help, $mail); -Getopt::Long::config ('no_ignore_case', 'bundling'); -GetOptions ('help|h' => \$help, - 'mail|m' => \$mail) or exit 1; -if ($help) { - print "Feeding myself to perldoc, please wait....\n"; - exec ('perldoc', '-t', $0); -} - -# Clean up $0 for error reporting. -$0 =~ s%.*/%%; - -# If -m was given, save the report into the infrastructure area. -if ($mail) { - my $date = strftime ('%Y/%m', localtime); - mkpath ("$REPORTS/$date/kerberos"); - open (REPORT, "+> $REPORTS/$date/kerberos/wallet") - or die "$0: cannot create $REPORTS/$date/kerberos/wallet: $!\n"; - select REPORT; -} - -# Run the report. -my @principals = read_dump; -report_principals (@principals); - -# If -m was given, take the saved report and mail it as well. -if ($mail) { - seek (REPORT, 0, 0) - or die "$0: cannot rewind generated report: $!\n"; - my $date = strftime ('%Y-%m-%d', localtime); - open (MAIL, '| /usr/lib/sendmail -t -oi -oem') - or die "$0: cannot fork sendmail: $!\n"; - print MAIL "From: root\n"; - print MAIL "To: $ADDRESS\n"; - print MAIL "Subject: wallet keytab report ($date)\n\n"; - print MAIL ; - close MAIL; - if ($? != 0) { - warn "$0: sendmail exited with status ", ($? >> 8), "\n"; - } -} -close REPORT; - -############################################################################## -# Documentation -############################################################################## - -=head1 NAME - -wallet-report - Report on keytabs in the wallet database - -=head1 SYNOPSIS - -wallet-report [B<-hm>] - -=head1 DESCRIPTION - -Obtains a list of keytab objects in the wallet database and produces a -report of the types of principals contained therein and the total number -of principals registered. This report is sent to standard output by -default, but see B<-m> below. - -The classifications of srvtabs are determined by a set of patterns at the -beginning of this script. Modify it to add new classifications. - -=head1 OPTIONS - -=over 4 - -=item B<-h>, B<--help> - -Print out this documentation (which is done simply by feeding the script to -C). - -=item B<-m>, B<--mail> - -Rather than printing the report to standard output, send the report via -e-mail to the address set at the beginning of this script and also archive -a copy under F. - -=back - -=head1 FILES - -=over 4 - -=item F - -The root directory for archived reports. Archived reports will be saved -under this directory in a subdirectory for the year, the month, and -C, under the name C. In other words, for a report run -in March of 2003, the report will be saved in the file: - - /afs/ir/dept/itss/infrastructure/reports/2003/03/kerberos/srvtabs - -=back - -=head1 NOTES - -Considerably more information could potentially be reported than is -currently here. In particular, keytabs that have never been downloaded -are not distinguished from those that have, the number of keytabs -downloaded is not separately reported, and there aren't any statistics on -how recently the keytabs were downloaded. These could be useful areas of -future development. - -=head1 AUTHOR - -Russ Allbery - -=cut diff --git a/contrib/wallet-summary b/contrib/wallet-summary new file mode 100755 index 0000000..7a51f9e --- /dev/null +++ b/contrib/wallet-summary @@ -0,0 +1,240 @@ +#!/usr/bin/perl -w +# +# wallet-summarize -- Summarize keytabs in the wallet database. +# +# Written by Russ Allbery +# Copyright 2003, 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +############################################################################## +# Site configuration +############################################################################## + +# Path to the infrastructure reports directory. +$REPORTS = '/afs/ir/dept/itss/infrastructure/reports'; + +# Address to which to mail the report. +$ADDRESS = 'nobody@example.com'; + +# The various classification patterns for srvtabs. +@PATTERNS + = ([qr(/cgi\z), '*/cgi', 'CGI users'], + [qr(^(?i)http/), 'HTTP/*', 'HTTP Negotiate-Auth'], + [qr(^cifs/), 'cifs/*', 'CIFS'], + [qr(^host/), 'host/*', 'Host login'], + [qr(^ident/), 'ident/*', 'S/Ident'], + [qr(^imap/), 'imap/*', 'IMAP'], + [qr(^ldap/), 'ldap/*', 'LDAP'], + [qr(^nfs/), 'nfs/*', 'NFS'], + [qr(^pop/), 'pop/*', 'Kerberized POP'], + [qr(^sieve/), 'sieve/*', 'Sieve mail sorting'], + [qr(^smtp/), 'smtp/*', 'SMTP'], + [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::Admin (); + +############################################################################## +# Database queries +############################################################################## + +# Return a list of keytab objects in the wallet database. Currently, we only +# report on keytab objects; reports for other objects will be added later. +sub list_keytabs { + my $report = Wallet::Report->new; + my @objects = $report->objects; + if (!@objects and $report->error) { + die $report->error; + } + return map { $$_[1] } grep { $$_[0] eq 'keytab' } @objects; +} + +############################################################################## +# Reporting +############################################################################## + +# Used to make heredocs look pretty. +sub unquote { my ($string) = @_; $string =~ s/^:( {0,7}|\t)//gm; $string } + +# Given an array of principal names, classify them into various interesting +# groups and then report on the total number of principals, broken down by the +# individual groups. +sub report_principals { + my @principals = @_; + my (%count, $found); + + # Count the principals in each category. + for (@principals) { + $found = 0; + for my $mapping (@PATTERNS) { + if (/$$mapping[0]/) { + $count{$$mapping[1]}++; + $found = 1; + last; + } + } + $count{OTHER}++ unless $found; + } + my $total = scalar @principals; + + # Find the longest label for any principal type. + my ($taglen, $desclen) = (0, 0); + for (@PATTERNS) { + next unless $count{$$_[1]}; + $taglen = length ($$_[1]) if length ($$_[1]) > $taglen; + $desclen = length ($$_[2]) if length ($$_[2]) > $desclen; + } + $taglen = 6 if $taglen < 6; + + # Print the report. + print unquote (<<"EOM"); +: This is a summary of the current keytab entries in the wallet database, +: which contain entries for every principal that is managed by our +: Kerberos keytab management system. Not all of these principals may +: necessarily be in active use. Principals corresponding to hosts which +: are no longer registered in NetDB are purged periodically. +: +EOM + printf ("%-${taglen}s Count %-${desclen}s\n", 'Type', 'Description'); + print '-' x $taglen, ' ----- ', '-' x $desclen, "\n"; + for (@PATTERNS) { + next unless $count{$$_[1]}; + printf ("%-${taglen}s %5d %s\n", $$_[1], $count{$$_[1]}, $$_[2]); + } + if ($count{OTHER}) { + print "\n"; + printf ("%-${taglen}s %5d %s\n", '', $count{OTHER}, 'Other'); + } + print ' ' x $taglen, ' ', '=====', "\n"; + printf ("%${taglen}s %5d\n", 'Total:', $total); +} + +############################################################################## +# Main routine +############################################################################## + +# Read in command-line options. +my ($help, $mail); +Getopt::Long::config ('no_ignore_case', 'bundling'); +GetOptions ('help|h' => \$help, + 'mail|m' => \$mail) or exit 1; +if ($help) { + print "Feeding myself to perldoc, please wait....\n"; + exec ('perldoc', '-t', $0); +} + +# Clean up $0 for error reporting. +$0 =~ s%.*/%%; + +# If -m was given, save the report into the infrastructure area. +if ($mail) { + my $date = strftime ('%Y/%m', localtime); + mkpath ("$REPORTS/$date/kerberos"); + open (REPORT, "+> $REPORTS/$date/kerberos/wallet") + or die "$0: cannot create $REPORTS/$date/kerberos/wallet: $!\n"; + select REPORT; +} + +# Run the report. +my @principals = read_dump; +report_principals (@principals); + +# If -m was given, take the saved report and mail it as well. +if ($mail) { + seek (REPORT, 0, 0) + or die "$0: cannot rewind generated report: $!\n"; + my $date = strftime ('%Y-%m-%d', localtime); + open (MAIL, '| /usr/lib/sendmail -t -oi -oem') + or die "$0: cannot fork sendmail: $!\n"; + print MAIL "From: root\n"; + print MAIL "To: $ADDRESS\n"; + print MAIL "Subject: wallet keytab report ($date)\n\n"; + print MAIL ; + close MAIL; + if ($? != 0) { + warn "$0: sendmail exited with status ", ($? >> 8), "\n"; + } +} +close REPORT; + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +wallet-summary - Report on keytabs in the wallet database + +=head1 SYNOPSIS + +B [B<-hm>] + +=head1 DESCRIPTION + +Obtains a list of keytab objects in the wallet database and produces a +report of the types of principals contained therein and the total number +of principals registered. This report is sent to standard output by +default, but see B<-m> below. + +The classifications of principals are determined by a set of patterns at +the beginning of this script. Modify it to add new classifications. + +=head1 OPTIONS + +=over 4 + +=item B<-h>, B<--help> + +Print out this documentation (which is done simply by feeding the script to +C). + +=item B<-m>, B<--mail> + +Rather than printing the report to standard output, send the report via +e-mail to the address set at the beginning of this script and also archive +a copy under F. + +=back + +=head1 FILES + +=over 4 + +=item F + +The root directory for archived reports. Archived reports will be saved +under this directory in a subdirectory for the year, the month, and +C, under the name C. In other words, for a report run +in March of 2003, the report will be saved in the file: + + /afs/ir/dept/itss/infrastructure/reports/2003/03/kerberos/srvtabs + +=back + +=head1 NOTES + +Considerably more information could potentially be reported than is +currently here. In particular, keytabs that have never been downloaded +are not distinguished from those that have, the number of keytabs +downloaded is not separately reported, and there aren't any statistics on +how recently the keytabs were downloaded. These could be useful areas of +future development. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index b4b3d86..e835713 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -22,7 +22,7 @@ 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'; +$VERSION = '0.05'; ############################################################################## # Constructor, destructor, and accessors @@ -110,256 +110,6 @@ sub destroy { return 1; } -############################################################################## -# Reporting -############################################################################## - -# Given an ACL name, translate it to the ID for that ACL and return it. -# Often this is unneeded and could be done with a join, but by doing it in a -# separate step, we can give an error for the specific case of someone -# searching for a non-existant ACL. -sub acl_name_to_id { - my ($self, $acl) = @_; - my ($id); - eval { - my $sql = 'select ac_id from acls where ac_name = ?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($acl); - while (defined (my $row = $sth->fetchrow_hashref)) { - $id = $row->{ac_id}; - } - $self->{dbh}->commit; - }; - if (!defined $id || $id !~ /^\d+$/) { - $self->error ("could not find the acl $acl"); - return ''; - } - return $id; -} - -# Return the SQL statement to find every object in the database. -sub list_objects_all { - my ($self) = @_; - my $sql = 'select ob_type, ob_name from objects order by ob_type, - ob_name'; - return $sql; -} - -# Return the SQL statement and the search field required to find all objects -# matching a specific type. -sub list_objects_type { - my ($self, $type) = @_; - my $sql = 'select ob_type, ob_name from objects where ob_type=? order - by ob_type, ob_name'; - return ($sql, $type); -} - -# Return the SQL statement and search field required to find all objects -# owned by a given ACL. If the requested owner is 'null', then 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 the empty string. -sub list_objects_owner { - my ($self, $owner) = @_; - my ($sth); - if ($owner =~ /^null$/i) { - my $sql = 'select ob_type, ob_name from objects where ob_owner is null - order by objects.ob_type, objects.ob_name'; - return ($sql); - } else { - my $id = $self->acl_name_to_id ($owner); - return '' unless $id; - my $sql = 'select ob_type, ob_name from objects where ob_owner = ? - order by objects.ob_type, objects.ob_name'; - return ($sql, $id); - } -} - -# Return the SQL statement and search field required to find all objects -# that have a specific flag set. -sub list_objects_flag { - my ($self, $flag) = @_; - my $sql = 'select ob_type, ob_name from objects left join flags on - (objects.ob_type = flags.fl_type and objects.ob_name = flags.fl_name) - where flags.fl_flag = ? order by objects.ob_type, objects.ob_name'; - return ($sql, $flag); -} - -# Return the SQL statement and search field required to find all objects -# that a given ACL has any permissions on. This expands from -# list_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 list_objects_acl { - my ($self, $acl) = @_; - my $id = $self->acl_name_to_id ($acl); - return '' unless $id; - my $sql = 'select ob_type, ob_name from objects where ob_owner = ? or - ob_acl_get = ? or ob_acl_store = ? or ob_acl_show = ? or - ob_acl_destroy = ? or ob_acl_flags = ? order by objects.ob_type, - objects.ob_name'; - return ($sql, $id, $id, $id, $id, $id, $id); -} - -# 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 list_objects { - my ($self, $type, @args) = @_; - undef $self->{error}; - - # Find the SQL statement and the arguments to use. - my $sql = ''; - my @search = (); - if (!defined $type || $type eq '') { - ($sql) = $self->list_objects_all (); - } else { - if (@args != 1) { - $self->error ("object searches require an argument to search"); - } elsif ($type eq 'type') { - ($sql, @search) = $self->list_objects_type (@args); - } elsif ($type eq 'owner') { - ($sql, @search) = $self->list_objects_owner (@args); - } elsif ($type eq 'flag') { - ($sql, @search) = $self->list_objects_flag (@args); - } elsif ($type eq 'acl') { - ($sql, @search) = $self->list_objects_acl (@args); - } else { - $self->error ("do not know search type: $type"); - } - return unless $sql; - } - - my @objects; - eval { - my $object; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (@search); - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@objects, [ @$object ]); - } - $self->{dbh}->commit; - }; - if ($@) { - $self->error ("cannot list objects: $@"); - $self->{dbh}->rollback; - return; - } else { - return @objects; - } -} - -# Returns the SQL statement required to find and return all ACLs in the db. -sub list_acls_all { - my ($self) = @_; - my $sql = 'select ac_id, ac_name from acls order by ac_id'; - return ($sql); -} - -# Returns the SQL statement required to find and returned all empty ACLs in -# the db. -sub list_acls_empty { - my ($self) = @_; - my $sql = 'select ac_id, ac_name from acls left join acl_entries - on (acls.ac_id = acl_entries.ae_id) where ae_id is null'; - return ($sql); -} - -# Returns the SQL statement and the field required to search the ACLs and -# return only those entries which contain a entries with identifiers -# matching a particular given string. -sub list_acls_entry { - my ($self, $type, $identifier) = @_; - my $sql = 'select distinct ac_id, ac_name from acl_entries left join acls - on (ae_id = ac_id) where ae_scheme = ? and ae_identifier like ? order - by ac_id'; - $identifier = '%'.$identifier.'%'; - return ($sql, $type, $identifier); -} - -# Returns a list of all ACLs stored in the wallet database as a list of pairs -# of ACL IDs and ACL names. On error and for an empty database, the empty -# list will be returned; however, this is unlikely since any valid database -# will have at least an ADMIN ACL. Still, to distinguish between an empty -# list and an error, call error(), which will return undef if there was no -# error. -sub list_acls { - my ($self, $type, @args) = @_; - undef $self->{error}; - - # Find the SQL statement and the arguments to use. - my $sql = ''; - my @search = (); - if (!defined $type || $type eq '') { - ($sql) = $self->list_acls_all (); - } else { - if ($type eq 'entry') { - if (@args == 0) { - $self->error ("acl searches require an argument to search"); - } else { - ($sql, @search) = $self->list_acls_entry (@args); - } - } elsif ($type eq 'empty') { - ($sql) = $self->list_acls_empty (); - } else { - $self->error ("do not know search type: $type"); - } - return unless $sql; - } - - my @acls; - eval { - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (@search); - my $object; - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@acls, [ @$object ]); - } - $self->{dbh}->commit; - }; - if ($@) { - $self->error ("cannot list ACLs: $@"); - $self->{dbh}->rollback; - return; - } else { - return @acls; - } -} - -# Returns a report of all ACL lines 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 report_owners { - my ($self, $type, $name) = @_; - undef $self->{error}; - my @lines; - eval { - my $sql = 'select distinct ae_scheme, ae_identifier from acl_entries, - acls, objects where ae_id = ac_id and ac_id = ob_owner and - ob_type like ? and ob_name like ? order by ae_scheme, - ae_identifier'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($type, $name); - my $object; - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@lines, [ @$object ]); - } - $self->{dbh}->commit; - }; - if ($@) { - $self->error ("cannot report on owners: $@"); - $self->{dbh}->rollback; - return; - } else { - return @lines; - } -} - ############################################################################## # Object registration ############################################################################## @@ -414,7 +164,7 @@ __DATA__ Wallet::Admin - Wallet system administrative interface =for stopwords -ACL hostname ACLs SQL wildcard Allbery +ACL hostname Allbery =head1 SYNOPSIS @@ -478,52 +228,6 @@ 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 list_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. The return value -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 "ADMIN" and ID 1 and one -with name "group/admins" and ID 3, list_acls() with no arguments would -return: - - ([ 1, 'ADMIN' ], [ 3, 'group/admins' ]) - -Returns the empty list on failure. Any valid wallet database should have -at least one ACL, but an error can be distinguished from the odd case of a -database with no ACLs by calling error(). error() is guaranteed to return -the error message if there was an error and undef if there was no error. - -There are currently two search types. C takes no arguments and -will return only those ACLs that have no entries within them. C -takes two arguments, an entry scheme and an entry identifier, and will -return any ACLs with an entry that matches the given scheme and contains -the given identifier. - -=item list_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. 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, list_objects() -with no arguments would return: - - ([ 'keytab', 'host/example.com' ], [ 'keytab', 'foo' ]) - -Returns the empty list on failure. To distinguish between this and a -database containing no objects, 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. - -There are four 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. 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 on any of -the possible ACL settings, not just owner. - =item register_object (TYPE, CLASS) Register in the database a mapping from the object type TYPE to the class @@ -545,17 +249,6 @@ 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 report_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 diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm new file mode 100644 index 0000000..7cd8653 --- /dev/null +++ b/perl/Wallet/Report.pm @@ -0,0 +1,425 @@ +# Wallet::Report -- Wallet system reporting interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +############################################################################## +# Modules and declarations +############################################################################## + +package Wallet::Report; +require 5.006; + +use strict; +use vars qw($VERSION); + +use Wallet::Database; + +# 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'; + +############################################################################## +# 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 $dbh = Wallet::Database->connect; + my $self = { dbh => $dbh }; + bless ($self, $class); + return $self; +} + +# Returns the database handle (used mostly for testing). +sub dbh { + my ($self) = @_; + return $self->{dbh}; +} + +# 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->{dbh}->disconnect unless $self->{dbh}->{InactiveDestroy}; +} + +############################################################################## +# Object reports +############################################################################## + +# Return the SQL statement to find every object in the database. +sub objects_all { + my ($self) = @_; + my $sql = 'select ob_type, ob_name from objects order by ob_type, + ob_name'; + return $sql; +} + +# Return the SQL statement and the search field required to find all objects +# matching a specific type. +sub objects_type { + my ($self, $type) = @_; + my $sql = 'select ob_type, ob_name from objects where ob_type=? order + by ob_type, ob_name'; + return ($sql, $type); +} + +# 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 ($sth); + if (lc ($owner) eq 'null') { + my $sql = 'select ob_type, ob_name from objects where ob_owner is null + order by objects.ob_type, objects.ob_name'; + return ($sql); + } else { + my $acl = eval { Wallet::ACL->new ($owner, $self->{dbh}) }; + return unless $acl; + my $sql = 'select ob_type, ob_name from objects where ob_owner = ? + order by objects.ob_type, objects.ob_name'; + return ($sql, $acl->id); + } +} + +# 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 $sql = 'select ob_type, ob_name from objects left join flags on + (objects.ob_type = flags.fl_type and objects.ob_name = flags.fl_name) + where flags.fl_flag = ? order by objects.ob_type, objects.ob_name'; + return ($sql, $flag); +} + +# 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 $acl = eval { Wallet::ACL->new ($search, $self->{dbh}) }; + return unless $acl; + my $sql = 'select ob_type, ob_name from objects where ob_owner = ? or + ob_acl_get = ? or ob_acl_store = ? or ob_acl_show = ? or + ob_acl_destroy = ? or ob_acl_flags = ? order by objects.ob_type, + objects.ob_name'; + return ($sql, ($acl->id) x 6); +} + +# 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}; + + # Find the SQL statement and the arguments to use. + my $sql = ''; + my @search = (); + if (!defined $type || $type eq '') { + ($sql) = $self->objects_all; + } else { + if (@args != 1) { + $self->error ("object searches require one argument to search"); + } elsif ($type eq 'type') { + ($sql, @search) = $self->objects_type (@args); + } elsif ($type eq 'owner') { + ($sql, @search) = $self->objects_owner (@args); + } elsif ($type eq 'flag') { + ($sql, @search) = $self->objects_flag (@args); + } elsif ($type eq 'acl') { + ($sql, @search) = $self->objects_acl (@args); + } else { + $self->error ("do not know search type: $type"); + } + return unless $sql; + } + + # Do the search. + my @objects; + eval { + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute (@search); + my $object; + while (defined ($object = $sth->fetchrow_arrayref)) { + push (@objects, [ @$object ]); + } + $self->{dbh}->commit; + }; + if ($@) { + $self->error ("cannot list objects: $@"); + $self->{dbh}->rollback; + 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 $sql = 'select ac_id, ac_name from acls order by ac_id'; + return ($sql); +} + +# Returns the SQL statement required to find all empty ACLs in the database. +sub acls_empty { + my ($self) = @_; + my $sql = 'select ac_id, ac_name from acls left join acl_entries + on (acls.ac_id = acl_entries.ae_id) where ae_id is null'; + return ($sql); +} + +# 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 $sql = 'select distinct ac_id, ac_name from acl_entries left join acls + on (ae_id = ac_id) where ae_scheme = ? and ae_identifier like ? order + by ac_id'; + return ($sql, $type, '%' . $identifier . '%'); +} + +# 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 SQL statement and the arguments to use. + my $sql; + my @search = (); + if (!defined $type || $type eq '') { + ($sql) = $self->acls_all; + } else { + if ($type eq 'entry') { + if (@args == 0) { + $self->error ('ACL searches require an argument to search'); + return; + } else { + ($sql, @search) = $self->acls_entry (@args); + } + } elsif ($type eq 'empty') { + ($sql) = $self->acls_empty; + } else { + $self->error ("do not know search type: $type"); + return; + } + } + + # Do the search. + my @acls; + eval { + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute (@search); + my $object; + while (defined ($object = $sth->fetchrow_arrayref)) { + push (@acls, [ @$object ]); + } + $self->{dbh}->commit; + }; + if ($@) { + $self->error ("cannot list ACLs: $@"); + $self->{dbh}->rollback; + 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 @lines; + eval { + my $sql = 'select distinct ae_scheme, ae_identifier from acl_entries, + acls, objects where ae_id = ac_id and ac_id = ob_owner and + ob_type like ? and ob_name like ? order by ae_scheme, + ae_identifier'; + my $sth = $self->{dbh}->prepare ($sql); + $sth->execute ($type, $name); + my $object; + while (defined ($object = $sth->fetchrow_arrayref)) { + push (@lines, [ @$object ]); + } + $self->{dbh}->commit; + }; + if ($@) { + $self->error ("cannot report on owners: $@"); + $self->{dbh}->rollback; + return; + } + return @lines; +} + +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"; + } + +=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 Wallet::Config(3). For more information on the normal +user interface to the wallet server, see Wallet::Server(3). + +=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 two search types. 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. + +The return value 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' ]) + +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 four 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. + +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/t/admin.t b/perl/t/admin.t index f94b39b..e22088e 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -3,13 +3,14 @@ # t/admin.t -- Tests for wallet administrative interface. # # Written by Russ Allbery -# Copyright 2008, 2009 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. -use Test::More tests => 83; +use Test::More tests => 16; use Wallet::Admin; +use Wallet::Report; use Wallet::Schema; use Wallet::Server; @@ -25,10 +26,11 @@ is ($admin->initialize ('admin@EXAMPLE.COM'), 1, ' and initialization succeeds'); # We have an empty database, so we should see no objects and one ACL. -my @objects = $admin->list_objects; +my $report = Wallet::Report->new; +my @objects = $report->objects; is (scalar (@objects), 0, 'No objects in the database'); -is ($admin->error, undef, ' and no error'); -my @acls = $admin->list_acls; +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'); @@ -36,137 +38,20 @@ 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'); - -# Create an object. +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'); -# Now, we should see one object. -@objects = $admin->list_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'); - -# Test registering a new ACL type. We don't have a good way of really using -# this right now. +# Test registering a new ACL type. is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), 1, 'Registering Wallet::ACL::Base works'); - -# Create another ACL. -is ($server->acl_create ('first'), 1, 'ACL creation succeeds'); -@acls = $admin->list_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 = $admin->list_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 = $admin->report_owners ('%', '%'); -is (scalar (@lines), 0, 'Owner report is currently empty'); -is ($admin->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 = $admin->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 = $admin->report_owners ('keytab', '%'); -is (scalar (@lines), 0, 'Owners of keytabs is empty'); -is ($admin->error, undef, ' with no error'); -@lines = $admin->report_owners ('base', 'foo/%'); -is (scalar (@lines), 0, 'Owners of base foo/* objects is empty'); -is ($admin->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 = $admin->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'); - -# 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 = $admin->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 = $admin->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 = $admin->list_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 = $admin->list_objects ('owner', 'null'); -is (scalar (@lines), 1, 'Searching for objects with no set ownerfinds one'); -is ($lines[0][0], 'base', ' and it has the right type'); -is ($lines[0][1], 'service/null', ' and the right name'); -@lines = $admin->list_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 = $admin->list_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 = $admin->list_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 = $admin->list_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'); +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'); # Clean up. is ($admin->destroy, 1, 'Destruction succeeds'); diff --git a/perl/t/report.t b/perl/t/report.t new file mode 100755 index 0000000..a18b995 --- /dev/null +++ b/perl/t/report.t @@ -0,0 +1,171 @@ +#!/usr/bin/perl -w +# +# t/report.t -- Tests for the wallet reporting interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +use Test::More tests => 83; + +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'); + +# 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'); + +# 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 ownerfinds 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'); + +# Clean up. +$admin->destroy; +unlink 'wallet-db'; diff --git a/server/wallet-report b/server/wallet-report new file mode 100755 index 0000000..a6b3b8d --- /dev/null +++ b/server/wallet-report @@ -0,0 +1,203 @@ +#!/usr/bin/perl -w +# +# wallet-report -- Wallet server reporting interface. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +############################################################################## +# Declarations and site configuration +############################################################################## + +use strict; +use Wallet::Report; + +############################################################################## +# Implementation +############################################################################## + +# Parse and execute a command. We wrap this in a subroutine call for easier +# testing. +sub command { + die "Usage: wallet-report [ ...]\n" unless @_; + my $report = Wallet::Report->new; + + # Parse command-line options and dispatch to the appropriate calls. + my ($command, @args) = @_; + if ($command eq 'acls') { + die "too many arguments to acls\n" if @args > 3; + my @acls = $report->acls (@args); + if (!@acls and $report->error) { + die $report->error, "\n"; + } + for my $acl (sort { $$a[1] cmp $$b[1] } @acls) { + print "$$acl[1] (ACL ID: $$acl[0])\n"; + } + } elsif ($command eq 'objects') { + die "too many arguments to objects\n" if @args > 2; + my @objects = $report->objects (@args); + if (!@objects and $report->error) { + die $report->error, "\n"; + } + for my $object (@objects) { + print join (' ', @$object), "\n"; + } + } elsif ($command eq 'owners') { + die "too many arguments to owners\n" if @args > 2; + die "too few arguments to owners\n" if @args < 2; + my @entries = $report->owners (@args); + if (!@entries and $report->error) { + die $report->error, "\n"; + } + for my $entry (@entries) { + print join (' ', @$entry), "\n"; + } + } else { + die "unknown command $command\n"; + } +} +command (@ARGV); +__END__ + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +wallet-report - Wallet server reporting interface + +=for stopwords +metadata ACL hostname backend acl acls wildcard SQL Allbery remctl + +=head1 SYNOPSIS + +B I [I ...] + +=head1 DESCRIPTION + +B provides a command-line interface for running reports on +the wallet database. It is intended to be run on the wallet server as a +user with access to the wallet database and configuration, but can also be +made available via remctl to users who should have reporting privileges. + +This program is a fairly thin wrapper around Wallet::Report that +translates command strings into method calls and returns the results. + +=head1 OPTIONS + +B takes no traditional options. + +=head1 COMMANDS + +=over 4 + +=item acls + +=item acls empty + +=item acls entry + +Returns a list of ACLs in the database. ACLs will be listed in the form: + + (ACL ID: ) + +where is the human-readable name and is the numeric ID. The +numeric ID is what's used internally by the wallet system. There will be +one line per ACL. + +If no search type is given, all the ACLs in the database will be returned. +If a search type (and possible search arguments) are given, then the ACLs +will be limited to those that match the search. + +The currently supported ACL search types are: + +=over 4 + +=item acls empty + +Returns all ACLs which have no entries, generally so that abandoned ACLs +can be destroyed. + +=item acls entry + +Returns all ACLs containing an entry with given scheme and identifier. +The scheme must be an exact match, but the string will match +any identifier containing that string. + +=back + +=item objects + +=item objects acl + +=item objects flag + +=item objects owner + +=item objects type + +Returns a list of objects in the database. Objects will be listed in the +form: + + + +There will be one line per object. + +If no search type is given, all objects in the database will be returned. +If a search type (and possible search arguments) are given, the objects +will be limited to those that match the search. + +The currently supported object search types are: + +=over 4 + +=item list objects acl + +Returns all objects for which the given ACL name or ID has any +permissions. This includes those objects owned by the ACL as well as +those where that ACL has any other, more limited permissions. + +=item list objects flag + +Returns all objects which have the given flag set. + +=item list objects owner + +Returns all objects owned by the given ACL name or ID. + +=item list objects type + +Returns all objects of the given type. + +=back + +=item owners + +Returns a list of all ACL entries in owner ACLs for all objects matching +both and . These can be the type or name of +objects or they can be patterns using C<%> as the wildcard character +following the normal rules of SQL patterns. + +The output will be one line per ACL line in the form: + + + +with duplicates suppressed. + +=back + +=head1 SEE ALSO + +Wallet::Config(3), Wallet::Report(3), wallet-backend(8) + +This program is part of the wallet system. The current version is +available from L. + +=head1 AUTHOR + +Russ Allbery + +=cut diff --git a/tests/docs/pod-spelling-t b/tests/docs/pod-spelling-t index 433d841..6993e4c 100755 --- a/tests/docs/pod-spelling-t +++ b/tests/docs/pod-spelling-t @@ -48,7 +48,7 @@ my @pod = map { $pod =~ s,[^/.][^/]*/../,,g; $pod; } qw(client/wallet.pod server/keytab-backend server/wallet-admin - server/wallet-backend); + server/wallet-backend server/wallet-report); plan tests => scalar @pod; # Finally, do the checks. diff --git a/tests/docs/pod-t b/tests/docs/pod-t index 9b6c5d1..f92ba2c 100755 --- a/tests/docs/pod-t +++ b/tests/docs/pod-t @@ -13,7 +13,7 @@ eval 'use Test::Pod 1.00'; plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; my @files = qw(client/wallet.pod server/keytab-backend server/wallet-admin - server/wallet-backend); + server/wallet-backend server/wallet-report); my $total = scalar (@files); plan tests => $total; for my $file (@files) { diff --git a/tests/server/admin-t b/tests/server/admin-t index 570dc52..5bde104 100755 --- a/tests/server/admin-t +++ b/tests/server/admin-t @@ -8,15 +8,14 @@ # See LICENSE for licensing terms. use strict; -use Test::More tests => 64; +use Test::More tests => 36; # Create a dummy class for Wallet::Admin that prints what method was called # with its arguments and returns data for testing. package Wallet::Admin; -use vars qw($empty $error); +use vars qw($error); $error = 0; -$empty = 0; sub error { if ($error) { @@ -44,19 +43,6 @@ sub initialize { return 1; } -sub list_objects { - print "list_objects\n"; - return if ($error or $empty); - return ([ keytab => 'host/windlord.stanford.edu' ], - [ file => 'unix-wallet-password' ]); -} - -sub list_acls { - print "list_acls\n"; - return if ($error or $empty); - return ([ 1, 'ADMIN' ], [ 2, 'group/admins' ], [ 4, 'group/users' ]); -} - sub register_object { shift; print "register_object @_\n"; @@ -71,13 +57,6 @@ sub register_verifier { return 1; } -sub report_owners { - shift; - print "report_owners @_\n"; - return if ($error or $empty); - return ([ krb5 => 'admin@EXAMPLE.COM' ]); -} - # Back to the main package and the actual test suite. Lie about whether the # Wallet::Admin package has already been loaded. package main; @@ -107,9 +86,7 @@ is ($out, "new\n", ' and nothing ran'); # Check too few and too many arguments for every command. my %commands = (destroy => [0, 0], initialize => [1, 1], - list => [1, 4], - register => [3, 3], - report => [1, -1]); + register => [3, 3]); for my $command (sort keys %commands) { my ($min, $max) = @{ $commands{$command} }; if ($min > 0) { @@ -159,22 +136,6 @@ is ($out, "new\n", ' and nothing was run'); is ($err, '', 'Initialize succeeds with a principal'); is ($out, "new\ninitialize rra\@stanford.edu\n", ' and runs the right code'); -# Test list. -($out, $err) = run_admin ('list', 'foo'); -is ($err, "only objects or acls are supported for list\n", - 'List requires a known object'); -is ($out, "new\n", ' and nothing was run'); -($out, $err) = run_admin ('list', 'objects'); -is ($err, '', 'List succeeds for objects'); -is ($out, "new\nlist_objects\n" - . "keytab host/windlord.stanford.edu\nfile unix-wallet-password\n", - ' and returns the right output'); -($out, $err) = run_admin ('list', 'acls'); -is ($err, '', 'List succeeds for ACLs'); -is ($out, "new\nlist_acls\n" - . "ADMIN (ACL ID: 1)\ngroup/admins (ACL ID: 2)\ngroup/users (ACL ID: 4)\n", - ' and returns the right output'); - # Test register. ($out, $err) = run_admin ('register', 'foo', 'foo', 'Foo::Bar'); is ($err, "only object or verifier is supported for register\n", @@ -189,15 +150,6 @@ is ($err, '', 'Register succeeds for verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and returns the right outout'); -# Test report. -($out, $err) = run_admin ('report', 'foo'); -is ($err, "unknown report type foo\n", 'Report requires a known report'); -is ($out, "new\n", ' and nothing was run'); -($out, $err) = run_admin ('report', 'owners', '%', '%'); -is ($err, '', 'Report succeeds for owners'); -is ($out, "new\nreport_owners % %\nkrb5 admin\@EXAMPLE.COM\n", - ' and returns the right output'); - # Test error handling. $Wallet::Admin::error = 1; ($out, $err) = run_admin ('destroy'); @@ -209,12 +161,6 @@ is ($out, "new\n" is ($err, "some error\n", 'Error handling succeeds for initialize'); is ($out, "new\ninitialize rra\@stanford.edu\n", ' and calls the right methods'); -($out, $err) = run_admin ('list', 'objects'); -is ($err, "some error\n", 'Error handling succeeds for list objects'); -is ($out, "new\nlist_objects\n", ' and calls the right methods'); -($out, $err) = run_admin ('list', 'acls'); -is ($err, "some error\n", 'Error handling succeeds for list acls'); -is ($out, "new\nlist_acls\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'); is ($out, "new\nregister_object foo Foo::Object\n", @@ -223,19 +169,3 @@ is ($out, "new\nregister_object foo Foo::Object\n", is ($err, "some error\n", 'Error handling succeeds for register verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and calls the right methods'); -($out, $err) = run_admin ('report', 'owners', 'foo', 'bar'); -is ($err, "some error\n", 'Error handling succeeds for report owners'); -is ($out, "new\nreport_owners foo bar\n", ' and calls the right methods'); - -# Test empty lists. -$Wallet::Admin::error = 0; -$Wallet::Admin::empty = 1; -($out, $err) = run_admin ('list', 'objects'); -is ($err, '', 'list objects runs with an empty list with no errors'); -is ($out, "new\nlist_objects\n", ' and calls the right methods'); -($out, $err) = run_admin ('list', 'acls'); -is ($err, '', 'list acls runs with an empty list and no errors'); -is ($out, "new\nlist_acls\n", ' and calls the right methods'); -($out, $err) = run_admin ('report', 'owners', 'foo', 'bar'); -is ($err, '', 'report owners runs with an empty list and no errors'); -is ($out, "new\nreport_owners foo bar\n", ' and calls the right methods'); diff --git a/tests/server/report-t b/tests/server/report-t new file mode 100755 index 0000000..285ee5a --- /dev/null +++ b/tests/server/report-t @@ -0,0 +1,151 @@ +#!/usr/bin/perl -w +# +# Tests for the wallet-report dispatch code. +# +# Written by Russ Allbery +# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# +# See LICENSE for licensing terms. + +use strict; +use Test::More tests => 32; + +# Create a dummy class for Wallet::Report that prints what method was called +# with its arguments and returns data for testing. +package Wallet::Report; + +use vars qw($empty $error); +$error = 0; +$empty = 0; + +sub error { + if ($error) { + return "some error"; + } else { + return; + } +} + +sub new { + print "new\n"; + return bless ({}, 'Wallet::Report'); +} + +sub acls { + shift; + print "acls @_\n"; + return if ($error or $empty); + return ([ 1, 'ADMIN' ], [ 2, 'group/admins' ], [ 4, 'group/users' ]); +} + +sub objects { + shift; + print "objects @_\n"; + return if ($error or $empty); + return ([ keytab => 'host/windlord.stanford.edu' ], + [ file => 'unix-wallet-password' ]); +} + +sub owners { + shift; + print "owners @_\n"; + return if ($error or $empty); + return ([ krb5 => 'admin@EXAMPLE.COM' ]); +} + +# Back to the main package and the actual test suite. Lie about whether the +# Wallet::Report package has already been loaded. +package main; +$INC{'Wallet/Report.pm'} = 'FAKE'; +eval { do "$ENV{SOURCE}/../server/wallet-report" }; + +# Run the wallet report client. This fun hack takes advantage of the fact +# that the wallet report client is written in Perl so that we can substitute +# our own Wallet::Report class. +sub run_report { + my (@args) = @_; + my $result = ''; + open (OUTPUT, '>', \$result) or die "cannot create output string: $!\n"; + select OUTPUT; + local $| = 1; + eval { command (@args) }; + my $error = $@; + select STDOUT; + return ($result, $error); +} + +# Now for the actual tests. First check for unknown commands. +my ($out, $err) = run_report ('foo'); +is ($err, "unknown command foo\n", 'Unknown command'); +is ($out, "new\n", ' and nothing ran'); + +# Check too few and too many arguments for every command. +my %commands = (acls => [0, 3], + objects => [0, 2], + owners => [2, 2]); +for my $command (sort keys %commands) { + my ($min, $max) = @{ $commands{$command} }; + if ($min > 0) { + ($out, $err) = run_report ($command, ('foo') x ($min - 1)); + is ($err, "too few arguments to $command\n", + "Too few arguments for $command"); + is ($out, "new\n", ' and nothing ran'); + } + if ($max >= 0) { + ($out, $err) = run_report ($command, ('foo') x ($max + 1)); + is ($err, "too many arguments to $command\n", + "Too many arguments for $command"); + is ($out, "new\n", ' and nothing ran'); + } +} + +# Test the report methods. +($out, $err) = run_report ('acls'); +is ($err, '', 'List succeeds for ACLs'); +is ($out, "new\nacls \n" + . "ADMIN (ACL ID: 1)\ngroup/admins (ACL ID: 2)\ngroup/users (ACL ID: 4)\n", + ' and returns the right output'); +($out, $err) = run_report ('acls', 'entry', 'foo', 'foo'); +is ($err, '', 'List succeeds for ACLs'); +is ($out, "new\nacls entry foo foo\n" + . "ADMIN (ACL ID: 1)\ngroup/admins (ACL ID: 2)\ngroup/users (ACL ID: 4)\n", + ' and returns the right output'); +($out, $err) = run_report ('objects'); +is ($err, '', 'List succeeds for objects'); +is ($out, "new\nobjects \n" + . "keytab host/windlord.stanford.edu\nfile unix-wallet-password\n", + ' and returns the right output'); +($out, $err) = run_report ('objects', 'type', 'foo'); +is ($err, '', 'List succeeds for objects type foo'); +is ($out, "new\nobjects type foo\n" + . "keytab host/windlord.stanford.edu\nfile unix-wallet-password\n", + ' and returns the right output'); +($out, $err) = run_report ('owners', '%', '%'); +is ($err, '', 'Report succeeds for owners'); +is ($out, "new\nowners % %\nkrb5 admin\@EXAMPLE.COM\n", + ' and returns the right output'); + +# Test error handling. +$Wallet::Report::error = 1; +($out, $err) = run_report ('acls'); +is ($err, "some error\n", 'Error handling succeeds for list acls'); +is ($out, "new\nacls \n", ' and calls the right methods'); +($out, $err) = run_report ('objects'); +is ($err, "some error\n", 'Error handling succeeds for list objects'); +is ($out, "new\nobjects \n", ' and calls the right methods'); +($out, $err) = run_report ('owners', 'foo', 'bar'); +is ($err, "some error\n", 'Error handling succeeds for report owners'); +is ($out, "new\nowners foo bar\n", ' and calls the right methods'); + +# Test empty lists. +$Wallet::Report::error = 0; +$Wallet::Report::empty = 1; +($out, $err) = run_report ('acls'); +is ($err, '', 'list acls runs with an empty list and no errors'); +is ($out, "new\nacls \n", ' and calls the right methods'); +($out, $err) = run_report ('objects'); +is ($err, '', 'list objects runs with an empty list with no errors'); +is ($out, "new\nobjects \n", ' and calls the right methods'); +($out, $err) = run_report ('owners', 'foo', 'bar'); +is ($err, '', 'report owners runs with an empty list and no errors'); +is ($out, "new\nowners foo bar\n", ' and calls the right methods'); -- cgit v1.2.3 From 69289862465a3bfb3488c1b3a674b6b06c9911ee Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 3 Mar 2010 19:49:46 -0800 Subject: Remove file names from test file headers Coding style update. Don't prefix the file short description with the file name; it's not needed. --- perl/t/acl.t | 2 +- perl/t/admin.t | 2 +- perl/t/config.t | 2 +- perl/t/data/keytab-fake | 2 +- perl/t/data/netdb-fake | 2 +- perl/t/file.t | 2 +- perl/t/init.t | 2 +- perl/t/kadmin.t | 2 +- perl/t/keytab.t | 2 +- perl/t/lib/Util.pm | 4 ++-- perl/t/object.t | 2 +- perl/t/pod-spelling.t | 3 +-- perl/t/report.t | 2 +- perl/t/schema.t | 2 +- perl/t/server.t | 2 +- perl/t/verifier-netdb.t | 10 +++++----- perl/t/verifier.t | 6 +++--- tests/data/fake-kadmin | 3 ++- tests/data/wallet.conf | 2 +- 19 files changed, 27 insertions(+), 27 deletions(-) (limited to 'perl/t/admin.t') diff --git a/perl/t/acl.t b/perl/t/acl.t index 95aa763..f169eb5 100755 --- a/perl/t/acl.t +++ b/perl/t/acl.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/api.t -- Tests for the wallet ACL API. +# Tests for the wallet ACL API. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/admin.t b/perl/t/admin.t index e22088e..074dbc6 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/admin.t -- Tests for wallet administrative interface. +# Tests for wallet administrative interface. # # Written by Russ Allbery # Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/config.t b/perl/t/config.t index 1377cb8..6b9f226 100755 --- a/perl/t/config.t +++ b/perl/t/config.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/config.t -- Tests for the wallet server configuration. +# Tests for the wallet server configuration. # # Written by Russ Allbery # Copyright 2008, 2010 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/data/keytab-fake b/perl/t/data/keytab-fake index 0ecf264..f4f0fb3 100755 --- a/perl/t/data/keytab-fake +++ b/perl/t/data/keytab-fake @@ -1,6 +1,6 @@ #!/bin/sh # -# keytab-fake -- Fake keytab-backend implementation. +# Fake keytab-backend implementation. # # This keytab-fake script is meant to be run by remctld during testing of # the keytab object implementation. It returns a fixed string for diff --git a/perl/t/data/netdb-fake b/perl/t/data/netdb-fake index ae5be18..9624102 100755 --- a/perl/t/data/netdb-fake +++ b/perl/t/data/netdb-fake @@ -1,6 +1,6 @@ #!/bin/sh # -# netdb-fake -- Fake NetDB remctl interface. +# Fake NetDB remctl interface. # # This netdb-fake script is meant to be run by remctld during testing of # the NetDB ACL verifier. It returns known roles or errors for different diff --git a/perl/t/file.t b/perl/t/file.t index 7ab5d75..a821c4f 100755 --- a/perl/t/file.t +++ b/perl/t/file.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/file.t -- Tests for the file object implementation. +# Tests for the file object implementation. # # Written by Russ Allbery # Copyright 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/init.t b/perl/t/init.t index d0fae9f..213aedf 100755 --- a/perl/t/init.t +++ b/perl/t/init.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/init.t -- Tests for database initialization. +# Tests for database initialization. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/kadmin.t b/perl/t/kadmin.t index 6365ce5..0b52528 100755 --- a/perl/t/kadmin.t +++ b/perl/t/kadmin.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/kadmin.t -- Tests for the kadmin object implementation. +# Tests for the kadmin object implementation. # # Written by Jon Robertson # Copyright 2009, 2010 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/keytab.t b/perl/t/keytab.t index 046da9c..b16cea5 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/keytab.t -- Tests for the keytab object implementation. +# Tests for the keytab object implementation. # # Written by Russ Allbery # Copyright 2007, 2008, 2009, 2010 diff --git a/perl/t/lib/Util.pm b/perl/t/lib/Util.pm index ab88b39..44a4d21 100644 --- a/perl/t/lib/Util.pm +++ b/perl/t/lib/Util.pm @@ -1,4 +1,4 @@ -# Util -- Utility class for wallet tests. +# Utility class for wallet tests. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University @@ -16,7 +16,7 @@ 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.02'; +$VERSION = '0.03'; use Exporter (); @ISA = qw(Exporter); diff --git a/perl/t/object.t b/perl/t/object.t index 46e67e5..3949786 100755 --- a/perl/t/object.t +++ b/perl/t/object.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/object.t -- Tests for the basic object implementation. +# Tests for the basic object implementation. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/pod-spelling.t b/perl/t/pod-spelling.t index d3ab858..6d9f7b0 100755 --- a/perl/t/pod-spelling.t +++ b/perl/t/pod-spelling.t @@ -9,8 +9,7 @@ # # Copyright 2008, 2009 Russ Allbery # -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. +# See LICENSE for licensing terms. use strict; use Test::More; diff --git a/perl/t/report.t b/perl/t/report.t index a18b995..a37681a 100755 --- a/perl/t/report.t +++ b/perl/t/report.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/report.t -- Tests for the wallet reporting interface. +# Tests for the wallet reporting interface. # # Written by Russ Allbery # Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/schema.t b/perl/t/schema.t index 559ece4..7f0aea4 100755 --- a/perl/t/schema.t +++ b/perl/t/schema.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/schema.t -- Tests for the wallet schema class. +# Tests for the wallet schema class. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/server.t b/perl/t/server.t index 090387b..7b30053 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/server.t -- Tests for the wallet server API. +# Tests for the wallet server API. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University diff --git a/perl/t/verifier-netdb.t b/perl/t/verifier-netdb.t index dcbbdd8..6bd4e73 100755 --- a/perl/t/verifier-netdb.t +++ b/perl/t/verifier-netdb.t @@ -1,15 +1,15 @@ #!/usr/bin/perl -w # -# t/verifier-netdb.t -- Tests for the NetDB wallet ACL verifiers. +# 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 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. -# -# 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. use Test::More tests => 4; diff --git a/perl/t/verifier.t b/perl/t/verifier.t index 3243d9c..74d7ba8 100755 --- a/perl/t/verifier.t +++ b/perl/t/verifier.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# t/verifier.t -- Tests for the basic wallet ACL verifiers. +# Tests for the basic wallet ACL verifiers. # # Written by Russ Allbery # Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University @@ -39,8 +39,8 @@ is ($verifier->error, 'no principal specified', ' and right error'); is ($verifier->check ('rra@stanford.edu', ''), undef, 'Empty ACL'); is ($verifier->error, 'malformed krb5 ACL', ' and right error'); -# Tests for unchanging support. Skip these if we don't have a keytab or if we -# can't find remctld. +# 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'); diff --git a/tests/data/fake-kadmin b/tests/data/fake-kadmin index 61906a4..4c0ceac 100755 --- a/tests/data/fake-kadmin +++ b/tests/data/fake-kadmin @@ -1,9 +1,10 @@ #!/usr/bin/perl -w # -# fake-kadmin -- Fake kadmin.local used to test the keytab backend. +# Fake kadmin.local used to test the keytab backend. # # Written by Russ Allbery # Copyright 2007 Board of Trustees, Leland Stanford Jr. University +# # See LICENSE for licensing terms. unless ($ARGV[0] eq '-q' && @ARGV == 2) { diff --git a/tests/data/wallet.conf b/tests/data/wallet.conf index 0a232dd..877a16f 100644 --- a/tests/data/wallet.conf +++ b/tests/data/wallet.conf @@ -1,4 +1,4 @@ -# wallet.conf -- Test wallet server configuration. -*- perl -*- +# Test wallet server configuration. -*- perl -*- # Always test with SQLite. $DB_DRIVER = 'SQLite'; -- cgit v1.2.3 From 4ee50d93cf99f55a503d0ca788e6c1a468eeacf6 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Tue, 17 May 2011 16:11:06 -0700 Subject: Add wallet-admin upgrade command to upgrade the database Hook the new upgrade method of Wallet::Schema into Wallet::Admin and the wallet-admin wrapper script. --- NEWS | 6 ++++++ README | 4 ++++ perl/Wallet/Admin.pm | 29 ++++++++++++++++++++++++----- perl/Wallet/Schema.pm | 2 +- perl/t/admin.t | 7 +++++-- server/wallet-admin | 11 ++++++++++- tests/server/admin-t | 22 +++++++++++++++++++--- 7 files changed, 69 insertions(+), 12 deletions(-) (limited to 'perl/t/admin.t') diff --git a/NEWS b/NEWS index c11bff9..9e2fa3b 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,11 @@ User-Visible wallet Changes +wallet 1.0 (unreleased) + + wallet-admin has a new sub-command, upgrade, which upgrades the wallet + database to the latest schema version. This command should be run + when deploying any new version of the wallet server. + wallet 0.12 (2010-08-25) New client program wallet-rekey that, given a list of keytabs on the diff --git a/README b/README index 5eae7fd..c981272 100644 --- a/README +++ b/README @@ -131,6 +131,10 @@ BUILD AND INSTALLATION make make install + If you are upgrading the wallet server from an earlier installed + version, run wallet-admin upgrade after installation to upgrade the + database schema. See the wallet-admin manual page for more information. + Pass --enable-silent-rules to configure for a quieter build (similar to the Linux kernel). Use make warnings instead of make to build with full GCC compiler warnings (requires a relatively current version of GCC). diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index f208e13..8fb49af 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -1,7 +1,8 @@ # Wallet::Admin -- Wallet system administrative interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -22,7 +23,7 @@ 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.05'; +$VERSION = '0.06'; ############################################################################## # Constructor, destructor, and accessors @@ -110,6 +111,19 @@ sub destroy { return 1; } +# Upgrade the database to the latest schema version. Returns true on success +# and false on failure. +sub upgrade { + my ($self) = @_; + my $schema = Wallet::Schema->new; + eval { $schema->upgrade ($self->{dbh}) }; + if ($@) { + $self->error ($@); + return; + } + return 1; +} + ############################################################################## # Object registration ############################################################################## @@ -204,12 +218,12 @@ failure to get the error message. =over 4 -=item destroy() +=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() +=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 @@ -240,7 +254,7 @@ 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) +=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 @@ -249,6 +263,11 @@ 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 diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index 911d7a9..0f6c53f 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -126,7 +126,7 @@ sub _schema_version { eval { my $sql = 'select md_version from metadata'; my $result = $dbh->selectrow_arrayref ($sql); - $version = $result->[0][0]; + $version = $result->[0]; }; if ($@) { $version = 0; diff --git a/perl/t/admin.t b/perl/t/admin.t index 074dbc6..6250f8e 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -3,11 +3,12 @@ # Tests for wallet administrative interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. -use Test::More tests => 16; +use Test::More tests => 18; use Wallet::Admin; use Wallet::Report; @@ -24,6 +25,8 @@ 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; diff --git a/server/wallet-admin b/server/wallet-admin index f81c195..fbab72b 100755 --- a/server/wallet-admin +++ b/server/wallet-admin @@ -3,7 +3,8 @@ # wallet-admin -- Wallet server administrative commands. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -56,6 +57,9 @@ sub command { } else { die "only object or verifier is supported for register\n"; } + } elsif ($command eq 'upgrade') { + die "too many arguments to upgrade\n" if @args; + $admin->upgrade or die $admin->error, "\n"; } else { die "unknown command $command\n"; } @@ -133,6 +137,11 @@ default as part of database initialization, so this command is used primarily to register local implementations of additional object types or ACL schemes. +=item upgrade + +Upgrades the database to the latest schema version, preserving data as +much as possible. + =back =head1 SEE ALSO diff --git a/tests/server/admin-t b/tests/server/admin-t index 5bde104..6846609 100755 --- a/tests/server/admin-t +++ b/tests/server/admin-t @@ -3,12 +3,13 @@ # Tests for the wallet-admin dispatch code. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008, 2009, 2010, 2011 +# The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. use strict; -use Test::More tests => 36; +use Test::More tests => 42; # Create a dummy class for Wallet::Admin that prints what method was called # with its arguments and returns data for testing. @@ -57,6 +58,12 @@ sub register_verifier { return 1; } +sub upgrade { + print "upgrade\n"; + return if $error; + return 1; +} + # Back to the main package and the actual test suite. Lie about whether the # Wallet::Admin package has already been loaded. package main; @@ -86,7 +93,8 @@ is ($out, "new\n", ' and nothing ran'); # Check too few and too many arguments for every command. my %commands = (destroy => [0, 0], initialize => [1, 1], - register => [3, 3]); + register => [3, 3], + upgrade => [0, 0]); for my $command (sort keys %commands) { my ($min, $max) = @{ $commands{$command} }; if ($min > 0) { @@ -150,6 +158,11 @@ is ($err, '', 'Register succeeds for verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and returns the right outout'); +# Test upgrade. +($out, $err) = run_admin ('upgrade'); +is ($err, '', 'Upgrade succeeds'); +is ($out, "new\nupgrade\n", ' and runs the right code'); + # Test error handling. $Wallet::Admin::error = 1; ($out, $err) = run_admin ('destroy'); @@ -169,3 +182,6 @@ is ($out, "new\nregister_object foo Foo::Object\n", is ($err, "some error\n", 'Error handling succeeds for register verifier'); is ($out, "new\nregister_verifier foo Foo::Verifier\n", ' and calls the right methods'); +($out, $err) = run_admin ('upgrade'); +is ($err, "some error\n", 'Error handling succeeds for initialize'); +is ($out, "new\nupgrade\n", ' and calls the right methods'); -- cgit v1.2.3 From 593e9b1e100ace54d1d9da7eb16e60f4e37c34ff Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Sun, 2 Dec 2012 22:07:16 -0800 Subject: Moved the Perl wallet modules and tests to DBIx::Class Moved all the Perl code to use DBIx::Class for the database interface. This includes updating all database calls, how the schema is generated and maintained, and the tests in places where some output has changed. We also remove the schema.t test, as the tests for it are more covered in the admin.t tests now. Change-Id: Ie5083432d09a0d9fe364a61c31378b77aa7b3cb7 Reviewed-on: https://gerrit.stanford.edu/598 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/ACL.pm | 196 +++++++++-------- perl/Wallet/Admin.pm | 102 +++++++-- perl/Wallet/Config.pm | 10 + perl/Wallet/Database.pm | 27 +-- perl/Wallet/Object/Base.pm | 318 ++++++++++++++++------------ perl/Wallet/Object/Keytab.pm | 116 +++++----- perl/Wallet/Report.pm | 298 +++++++++++++++++--------- perl/Wallet/Schema.pm | 282 ++++++------------------ perl/Wallet/Schema/Result/Acl.pm | 99 +++++++++ perl/Wallet/Schema/Result/AclEntry.pm | 63 ++++++ perl/Wallet/Schema/Result/AclHistory.pm | 101 +++++++++ perl/Wallet/Schema/Result/AclScheme.pm | 73 +++++++ perl/Wallet/Schema/Result/Enctype.pm | 34 +++ perl/Wallet/Schema/Result/Flag.pm | 54 +++++ perl/Wallet/Schema/Result/KeytabEnctype.pm | 42 ++++ perl/Wallet/Schema/Result/KeytabSync.pm | 42 ++++ perl/Wallet/Schema/Result/Object.pm | 258 ++++++++++++++++++++++ perl/Wallet/Schema/Result/ObjectHistory.pm | 127 +++++++++++ perl/Wallet/Schema/Result/SyncTarget.pm | 40 ++++ perl/Wallet/Schema/Result/Type.pm | 64 ++++++ perl/Wallet/Server.pm | 19 +- perl/create-ddl | 93 ++++++++ perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql | 7 + perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql | 6 + perl/sql/Wallet-Schema-0.07-MySQL.sql | 211 ++++++++++++++++++ perl/sql/Wallet-Schema-0.07-SQLite.sql | 219 +++++++++++++++++++ perl/sql/Wallet-Schema-0.08-MySQL.sql | 193 +++++++++++++++++ perl/sql/Wallet-Schema-0.08-PostgreSQL.sql | 201 ++++++++++++++++++ perl/sql/Wallet-Schema-0.08-SQLite.sql | 201 ++++++++++++++++++ perl/t/admin.t | 21 +- perl/t/lib/Util.pm | 5 + perl/t/report.t | 2 +- perl/t/schema.t | 111 ---------- perl/t/server.t | 2 +- server/wallet-admin | 23 ++ 35 files changed, 2886 insertions(+), 774 deletions(-) create mode 100644 perl/Wallet/Schema/Result/Acl.pm create mode 100644 perl/Wallet/Schema/Result/AclEntry.pm create mode 100644 perl/Wallet/Schema/Result/AclHistory.pm create mode 100644 perl/Wallet/Schema/Result/AclScheme.pm create mode 100644 perl/Wallet/Schema/Result/Enctype.pm create mode 100644 perl/Wallet/Schema/Result/Flag.pm create mode 100644 perl/Wallet/Schema/Result/KeytabEnctype.pm create mode 100644 perl/Wallet/Schema/Result/KeytabSync.pm create mode 100644 perl/Wallet/Schema/Result/Object.pm create mode 100644 perl/Wallet/Schema/Result/ObjectHistory.pm create mode 100644 perl/Wallet/Schema/Result/SyncTarget.pm create mode 100644 perl/Wallet/Schema/Result/Type.pm create mode 100755 perl/create-ddl create mode 100644 perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql create mode 100644 perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql create mode 100644 perl/sql/Wallet-Schema-0.07-MySQL.sql create mode 100644 perl/sql/Wallet-Schema-0.07-SQLite.sql create mode 100644 perl/sql/Wallet-Schema-0.08-MySQL.sql create mode 100644 perl/sql/Wallet-Schema-0.08-PostgreSQL.sql create mode 100644 perl/sql/Wallet-Schema-0.08-SQLite.sql delete mode 100755 perl/t/schema.t (limited to 'perl/t/admin.t') diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm index 2a06442..4f51c70 100644 --- a/perl/Wallet/ACL.pm +++ b/perl/Wallet/ACL.pm @@ -33,26 +33,24 @@ $VERSION = '0.07'; # doesn't exist, throws an exception. sub new { my ($class, $id, $dbh) = @_; - my ($sql, $data, $name); + my (%search, $data, $name); if ($id =~ /^\d+\z/) { - $sql = 'select ac_id, ac_name from acls where ac_id = ?'; + $search{ac_id} = $id; } else { - $sql = 'select ac_id, ac_name from acls where ac_name = ?'; + $search{ac_name} = $id; } eval { - ($data, $name) = $dbh->selectrow_array ($sql, undef, $id); - $dbh->commit; + $data = $dbh->resultset('Acl')->find (\%search); }; if ($@) { - $dbh->rollback; die "cannot search for ACL $id: $@\n"; } elsif (not defined $data) { die "ACL $id not found\n"; } my $self = { dbh => $dbh, - id => $data, - name => $name, + id => $data->ac_id, + name => $data->ac_name, }; bless ($self, $class); return $self; @@ -69,18 +67,27 @@ sub create { $time ||= time; my $id; eval { - my $sql = 'insert into acls (ac_name) values (?)'; - $dbh->do ($sql, undef, $name); - $id = $dbh->last_insert_id (undef, undef, 'acls', 'ac_id'); + my $guard = $dbh->txn_scope_guard; + + # Create the new record. + my %record = (ac_name => $name); + my $acl = $dbh->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); - $sql = "insert into acl_history (ah_acl, ah_action, ah_by, ah_from, - ah_on) values (?, 'create', ?, ?, ?)"; - $dbh->do ($sql, undef, $id, $user, $host, $date); - $dbh->commit; + %record = (ah_acl => $id, + ah_action => 'create', + ah_by => $user, + ah_from => $host, + ah_on => $date); + my $history = $dbh->resultset('AclHistory')->create (\%record); + die "unable to create new history entry" unless defined $history; + + $guard->commit; }; if ($@) { - $dbh->rollback; die "cannot create ACL $name: $@\n"; } my $self = { @@ -126,13 +133,13 @@ sub scheme_mapping { my ($self, $scheme) = @_; my $class; eval { - my $sql = 'select as_class from acl_schemes where as_name = ?'; - ($class) = $self->{dbh}->selectrow_array ($sql, undef, $scheme); - $self->{dbh}->commit; + my %search = (as_name => $scheme); + my $scheme_rec = $self->{dbh}->resultset('AclScheme') + ->find (\%search); + $class = $scheme_rec->as_class; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } if (defined $class) { @@ -155,11 +162,14 @@ sub log_acl { unless ($action =~ /^(add|remove)\z/) { die "invalid history action $action"; } - my $date = strftime ('%Y-%m-%d %T', localtime $time); - my $sql = 'insert into acl_history (ah_acl, ah_action, ah_scheme, - ah_identifier, ah_by, ah_from, ah_on) values (?, ?, ?, ?, ?, ?, ?)'; - $self->{dbh}->do ($sql, undef, $self->{id}, $action, $scheme, $identifier, - $user, $host, $date); + 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->{dbh}->resultset('AclHistory')->create (\%record); } ############################################################################## @@ -176,13 +186,15 @@ sub rename { return; } eval { - my $sql = 'update acls set ac_name = ? where ac_id = ?'; - $self->{dbh}->do ($sql, undef, $name, $self->{id}); - $self->{dbh}->commit; + my $guard = $self->{dbh}->txn_scope_guard; + my %search = (ac_id => $self->{id}); + my $acls = $self->{dbh}->resultset('Acl')->find (\%search); + $acls->ac_name ($name); + $acls->update; + $guard->commit; }; if ($@) { $self->error ("cannot rename ACL $self->{id} to $name: $@"); - $self->{dbh}->rollback; return; } $self->{name} = $name; @@ -200,27 +212,44 @@ sub destroy { my ($self, $user, $host, $time) = @_; $time ||= time; eval { - my $sql = 'select ob_type, ob_name from objects where ob_owner = ? - or ob_acl_get = ? or ob_acl_store = ? or ob_acl_show = ? or - ob_acl_destroy = ? or ob_acl_flags = ?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (($self->{id}) x 6); - my $entry = $sth->fetchrow_arrayref; - if (defined $entry) { - die "ACL in use by $entry->[0]:$entry->[1]"; + my $guard = $self->{dbh}->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->{dbh}->resultset('Object')->search (\@search); + if (@entries) { + my ($entry) = @entries; + die "ACL in use by ".$entry->ob_type.":".$entry->ob_name; } - $sql = 'delete from acl_entries where ae_id = ?'; - $self->{dbh}->do ($sql, undef, $self->{id}); - $sql = 'delete from acls where ac_id = ?'; - $self->{dbh}->do ($sql, undef, $self->{id}); - $sql = "insert into acl_history (ah_acl, ah_action, ah_by, ah_from, - ah_on) values (?, 'destroy', ?, ?, ?)"; - $self->{dbh}->do ($sql, undef, $self->{id}, $user, $host, $time); - $self->{dbh}->commit; + + # Delete any entries (there may or may not be any). + my %search = (ae_id => $self->{id}); + @entries = $self->{dbh}->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->{dbh}->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 => $time); + $self->{dbh}->resultset('AclHistory')->create (\%record); + $guard->commit; }; if ($@) { $self->error ("cannot destroy ACL $self->{id}: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -239,15 +268,16 @@ sub add { return; } eval { - my $sql = 'insert into acl_entries (ae_id, ae_scheme, ae_identifier) - values (?, ?, ?)'; - $self->{dbh}->do ($sql, undef, $self->{id}, $scheme, $identifier); + my $guard = $self->{dbh}->txn_scope_guard; + my %record = (ae_id => $self->{id}, + ae_scheme => $scheme, + ae_identifier => $identifier); + my $entry = $self->{dbh}->resultset('AclEntry')->create (\%record); $self->log_acl ('add', $scheme, $identifier, $user, $host, $time); - $self->{dbh}->commit; + $guard->commit; }; if ($@) { $self->error ("cannot add $scheme:$identifier to $self->{id}: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -260,23 +290,21 @@ sub remove { my ($self, $scheme, $identifier, $user, $host, $time) = @_; $time ||= time; eval { - my $sql = 'select * from acl_entries where ae_id = ? and ae_scheme = ? - and ae_identifier = ?'; - my ($data) = $self->{dbh}->selectrow_array ($sql, undef, $self->{id}, - $scheme, $identifier); - unless (defined $data) { + my $guard = $self->{dbh}->txn_scope_guard; + my %search = (ae_id => $self->{id}, + ae_scheme => $scheme, + ae_identifier => $identifier); + my $entry = $self->{dbh}->resultset('AclEntry')->find (\%search); + unless (defined $entry) { die "entry not found in ACL\n"; } - $sql = 'delete from acl_entries where ae_id = ? and ae_scheme = ? - and ae_identifier = ?'; - $self->{dbh}->do ($sql, undef, $self->{id}, $scheme, $identifier); + $entry->delete; $self->log_acl ('remove', $scheme, $identifier, $user, $host, $time); - $self->{dbh}->commit; + $guard->commit; }; if ($@) { my $entry = "$scheme:$identifier"; $self->error ("cannot remove $entry from $self->{id}: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -294,19 +322,17 @@ sub list { undef $self->{error}; my @entries; eval { - my $sql = 'select ae_scheme, ae_identifier from acl_entries where - ae_id = ?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{id}); - my $entry; - while (defined ($entry = $sth->fetchrow_arrayref)) { - push (@entries, [ @$entry ]); + my $guard = $self->{dbh}->txn_scope_guard; + my %search = (ae_id => $self->{id}); + my @entry_recs = $self->{dbh}->resultset('AclEntry') + ->search (\%search); + for my $entry (@entry_recs) { + push (@entries, [ $entry->ae_scheme, $entry->ae_identifier ]); } - $self->{dbh}->commit; + $guard->commit; }; if ($@) { $self->error ("cannot retrieve ACL $self->{id}: $@"); - $self->{dbh}->rollback; return; } else { return @entries; @@ -338,25 +364,27 @@ sub history { my ($self) = @_; my $output = ''; eval { - my $sql = 'select ah_action, ah_scheme, ah_identifier, ah_by, ah_from, - ah_on from acl_history where ah_acl = ? order by ah_on'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{id}); - my @data; - while (@data = $sth->fetchrow_array) { - $output .= "$data[5] "; - if ($data[0] eq 'add' or $data[0] eq 'remove') { - $output .= "$data[0] $data[1] $data[2]"; + my $guard = $self->{dbh}->txn_scope_guard; + my %search = (ah_acl => $self->{id}); + my %options = (order_by => 'ah_on'); + my @data = $self->{dbh}->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[0]; + $output .= $data->ah_action; } - $output .= "\n by $data[3] from $data[4]\n"; + $output .= sprintf ("\n by %s from %s\n", $data->ah_by, + $data->ah_from); } - $self->{dbh}->commit; + $guard->commit; }; if ($@) { $self->error ("cannot read history for $self->{id}: $@"); - $self->{dbh}->rollback; return; } return $output; @@ -487,7 +515,7 @@ references. =item new(ACL, DBH) Instantiate a new ACL object with the given ACL ID or name. Takes the -Wallet::Database object to use for retrieving metadata from the wallet +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. diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index a1aef83..511916d 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -1,7 +1,7 @@ # Wallet::Admin -- Wallet system administrative interface. # # Written by Russ Allbery -# Copyright 2008, 2009, 2010, 2011 +# Copyright 2008, 2009, 2010, 2011, 2012 # The Board of Trustees of the Leland Stanford Junior University # # See LICENSE for licensing terms. @@ -17,13 +17,12 @@ use strict; use vars qw($VERSION); use Wallet::ACL; -use Wallet::Database; 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.06'; +$VERSION = '0.07'; ############################################################################## # Constructor, destructor, and accessors @@ -34,7 +33,7 @@ $VERSION = '0.06'; # Throw an exception if anything goes wrong. sub new { my ($class) = @_; - my $dbh = Wallet::Database->connect; + my $dbh = Wallet::Schema->connect; my $self = { dbh => $dbh }; bless ($self, $class); return $self; @@ -61,7 +60,7 @@ sub error { # Disconnect the database handle on object destruction to avoid warnings. sub DESTROY { my ($self) = @_; - $self->{dbh}->disconnect unless $self->{dbh}->{InactiveDestroy}; + $self->{dbh}->storage->dbh->disconnect; } ############################################################################## @@ -75,17 +74,49 @@ sub DESTROY { # true on success and false on failure, setting the object error. sub initialize { my ($self, $user) = @_; - my $schema = Wallet::Schema->new; - eval { $schema->create ($self->{dbh}) }; + + # Deploy the database schema from DDL files, if they exist. If not then + # we automatically get the database from the Schema modules. + $self->{dbh}->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->{dbh}, $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->{dbh}->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' ]); + ($r1) = $self->{dbh}->resultset('Type')->populate (\@record); + warn "default Type not installed" unless defined $r1; + return 1; } @@ -102,12 +133,31 @@ sub reinitialize { # false on failure. sub destroy { my ($self) = @_; - my $schema = Wallet::Schema->new; - eval { $schema->drop ($self->{dbh}) }; - if ($@) { - $self->error ($@); - return; + + # Get an actual DBI handle and use it to delete all tables. + my $real_dbh = $self->{dbh}->storage->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"; + $real_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->{dbh}->create_ddl_dir (\@dbs, $version, + $Wallet::Config::DB_DDL_DIRECTORY, + $oldversion); + return 1; } @@ -115,12 +165,16 @@ sub destroy { # and false on failure. sub upgrade { my ($self) = @_; - my $schema = Wallet::Schema->new; - eval { $schema->upgrade ($self->{dbh}) }; + + if ($self->{dbh}->get_db_version) { + eval { $self->{dbh}->upgrade; }; + } if ($@) { $self->error ($@); + warn $@; return; } + return 1; } @@ -135,13 +189,14 @@ sub upgrade { sub register_object { my ($self, $type, $class) = @_; eval { - my $sql = 'insert into types (ty_name, ty_class) values (?, ?)'; - $self->{dbh}->do ($sql, undef, $type, $class); - $self->{dbh}->commit; + my $guard = $self->{dbh}->txn_scope_guard; + my %record = (ty_name => $type, + ty_class => $class); + $self->{dbh}->resultset('Type')->create (\%record); + $guard->commit; }; if ($@) { $self->error ("cannot register $class for $type: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -154,13 +209,14 @@ sub register_object { sub register_verifier { my ($self, $scheme, $class) = @_; eval { - my $sql = 'insert into acl_schemes (as_name, as_class) values (?, ?)'; - $self->{dbh}->do ($sql, undef, $scheme, $class); - $self->{dbh}->commit; + my $guard = $self->{dbh}->txn_scope_guard; + my %record = (as_name => $scheme, + as_class => $class); + $self->{dbh}->resultset('AclScheme')->create (\%record); + $guard->commit; }; if ($@) { - $self->error ("cannot registery $class for $scheme: $@"); - $self->{dbh}->rollback; + $self->error ("cannot register $class for $scheme: $@"); return; } return 1; diff --git a/perl/Wallet/Config.pm b/perl/Wallet/Config.pm index 71f6e0f..98dae03 100644 --- a/perl/Wallet/Config.pm +++ b/perl/Wallet/Config.pm @@ -167,6 +167,16 @@ backends, particularly SQLite, do not need this. our $DB_PASSWORD; +=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. + +=cut + +our $DB_DDL_DIRECTORY; + =back =head1 FILE OBJECT CONFIGURATION diff --git a/perl/Wallet/Database.pm b/perl/Wallet/Database.pm index 7daab9f..8df338a 100644 --- a/perl/Wallet/Database.pm +++ b/perl/Wallet/Database.pm @@ -1,12 +1,12 @@ # Wallet::Database -- Wallet system database connection management. # -# This module is a thin wrapper around DBI to handle determination of the -# database driver and configuration settings automatically on connect. The +# 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 DBI objects in the rest of the code. +# like DBIx::Class objects in the rest of the code. # # Written by Russ Allbery -# Copyright 2008, 2010 Board of Trustees, Leland Stanford Jr. University +# Copyright 2008-2012 Board of Trustees, Leland Stanford Jr. University # # See LICENSE for licensing terms. @@ -14,32 +14,21 @@ # Modules and declarations ############################################################################## -# Set up the subclasses. This is required to avoid warnings under DBI 1.40 -# and later, even though we don't actually make use of any overridden -# statement handle or database handle methods. -package Wallet::Database::st; -use vars qw(@ISA); -@ISA = qw(DBI::st); - -package Wallet::Database::db; -use vars qw(@ISA); -@ISA = qw(DBI::db); - package Wallet::Database; require 5.006; use strict; use vars qw(@ISA $VERSION); -use DBI; +use Wallet::Schema; use Wallet::Config; -@ISA = qw(DBI); +@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.03'; +$VERSION = '0.04'; ############################################################################## # Core overrides @@ -65,7 +54,7 @@ sub connect { } my $user = $Wallet::Config::DB_USER; my $pass = $Wallet::Config::DB_PASSWORD; - my %attrs = (PrintError => 0, RaiseError => 1, AutoCommit => 0); + my %attrs = (PrintError => 0, RaiseError => 1); my $dbh = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) }; if ($@) { die "cannot connect to database: $@\n"; diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm index 87506f4..5bd89a7 100644 --- a/perl/Wallet/Object/Base.pm +++ b/perl/Wallet/Object/Base.pm @@ -24,7 +24,7 @@ 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.05'; +$VERSION = '0.06'; ############################################################################## # Constructors @@ -37,10 +37,11 @@ $VERSION = '0.05'; # probably be usable as-is by most object types. sub new { my ($class, $type, $name, $dbh) = @_; - my $sql = 'select ob_name from objects where ob_type = ? and ob_name = ?'; - my $data = $dbh->selectrow_array ($sql, undef, $type, $name); - $dbh->commit; - die "cannot find ${type}:${name}\n" unless ($data and $data eq $name); + my %search = (ob_type => $type, + ob_name => $name); + my $object = $dbh->resultset('Object')->find (\%search); + die "cannot find ${type}:${name}\n" + unless ($object and $object->ob_name eq $name); my $self = { dbh => $dbh, name => $name, @@ -59,18 +60,27 @@ sub create { $time ||= time; die "invalid object type\n" unless $type; die "invalid object name\n" unless $name; + my $guard = $dbh->txn_scope_guard; eval { - my $date = strftime ('%Y-%m-%d %T', localtime $time); - my $sql = 'insert into objects (ob_type, ob_name, ob_created_by, - ob_created_from, ob_created_on) values (?, ?, ?, ?, ?)'; - $dbh->do ($sql, undef, $type, $name, $user, $host, $date); - $sql = "insert into object_history (oh_type, oh_name, oh_action, - oh_by, oh_from, oh_on) values (?, ?, 'create', ?, ?, ?)"; - $dbh->do ($sql, undef, $type, $name, $user, $host, $date); - $dbh->commit; + 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)); + $dbh->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)); + $dbh->resultset('ObjectHistory')->create (\%record); + + $guard->commit; }; if ($@) { - $dbh->rollback; die "cannot create object ${type}:${name}: $@\n"; } my $self = { @@ -126,30 +136,36 @@ sub log_action { # 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->{dbh}->txn_scope_guard; eval { - my $date = strftime ('%Y-%m-%d %T', localtime $time); - my $sql = 'insert into object_history (oh_type, oh_name, oh_action, - oh_by, oh_from, oh_on) values (?, ?, ?, ?, ?, ?)'; - $self->{dbh}->do ($sql, undef, $self->{type}, $self->{name}, $action, - $user, $host, $date); + 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->{dbh}->resultset('ObjectHistory')->create (\%record); + + my %search = (ob_type => $self->{type}, + ob_name => $self->{name}); + my $object = $self->{dbh}->resultset('Object')->find (\%search); if ($action eq 'get') { - $sql = 'update objects set ob_downloaded_by = ?, - ob_downloaded_from = ?, ob_downloaded_on = ? where - ob_type = ? and ob_name = ?'; - $self->{dbh}->do ($sql, undef, $user, $host, $date, $self->{type}, - $self->{name}); + $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') { - $sql = 'update objects set ob_stored_by = ?, ob_stored_from = ?, - ob_stored_on = ? where ob_type = ? and ob_name = ?'; - $self->{dbh}->do ($sql, undef, $user, $host, $date, $self->{type}, - $self->{name}); + $object->ob_stored_by ($user); + $object->ob_stored_from ($host); + $object->ob_stored_on (strftime ('%Y-%m-%d %T', + localtime $time)); } - $self->{dbh}->commit; + $object->update; + $guard->commit; }; if ($@) { my $id = $self->{type} . ':' . $self->{name}; $self->error ("cannot update history for $id: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -175,12 +191,18 @@ sub log_set { unless ($fields{$field}) { die "invalid history field $field"; } - my $date = strftime ('%Y-%m-%d %T', localtime $time); - my $sql = "insert into object_history (oh_type, oh_name, oh_action, - oh_field, oh_type_field, oh_old, oh_new, oh_by, oh_from, oh_on) - values (?, ?, 'set', ?, ?, ?, ?, ?, ?, ?)"; - $self->{dbh}->do ($sql, undef, $self->{type}, $self->{name}, $field, - $type_field, $old, $new, $user, $host, $date); + + 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->{dbh}->resultset('ObjectHistory')->create (\%record); } ############################################################################## @@ -202,20 +224,21 @@ sub _set_internal { $self->error ("cannot modify ${type}:${name}: object is locked"); return; } + + my $guard = $self->{dbh}->txn_scope_guard; eval { - my $sql = "select ob_$attr from objects where ob_type = ? and - ob_name = ?"; - my $old = $self->{dbh}->selectrow_array ($sql, undef, $type, $name); - $sql = "update objects set ob_$attr = ? where ob_type = ? and - ob_name = ?"; - $self->{dbh}->do ($sql, undef, $value, $type, $name); + my %search = (ob_type => $type, + ob_name => $name); + my $object = $self->{dbh}->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); - $self->{dbh}->commit; + $guard->commit; }; if ($@) { my $id = $self->{type} . ':' . $self->{name}; $self->error ("cannot set $attr on $id: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -236,14 +259,13 @@ sub _get_internal { my $type = $self->{type}; my $value; eval { - my $sql = "select $attr from objects where ob_type = ? and - ob_name = ?"; - $value = $self->{dbh}->selectrow_array ($sql, undef, $type, $name); - $self->{dbh}->commit; + my %search = (ob_type => $type, + ob_name => $name); + my $object = $self->{dbh}->resultset('Object')->find (\%search); + $value = $object->get_column ($attr); }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } return $value; @@ -356,14 +378,18 @@ sub flag_check { my $dbh = $self->{dbh}; my $value; eval { - my $sql = 'select fl_flag from flags where fl_type = ? and fl_name = ? - and fl_flag = ?'; - $value = $dbh->selectrow_array ($sql, undef, $type, $name, $flag); - $dbh->commit; + my %search = (fl_type => $type, + fl_name => $name, + fl_flag => $flag); + my $flag = $dbh->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}: $@"); - $dbh->rollback; return; } else { return ($value) ? 1 : 0; @@ -378,22 +404,21 @@ sub flag_clear { my $name = $self->{name}; my $type = $self->{type}; my $dbh = $self->{dbh}; + my $guard = $dbh->txn_scope_guard; eval { - my $sql = 'select * from flags where fl_type = ? and fl_name = ? and - fl_flag = ?'; - my ($data) = $dbh->selectrow_array ($sql, undef, $type, $name, $flag); - unless (defined $data) { + my %search = (fl_type => $type, + fl_name => $name, + fl_flag => $flag); + my $flag = $dbh->resultset('Flag')->find (\%search); + unless (defined $flag) { die "flag not set\n"; } - $sql = 'delete from flags where fl_type = ? and fl_name = ? and - fl_flag = ?'; - $dbh->do ($sql, undef, $type, $name, $flag); - $self->log_set ('flags', $flag, undef, $user, $host, $time); - $dbh->commit; + $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}: $@"); - $dbh->rollback; return; } return 1; @@ -407,20 +432,18 @@ sub flag_list { undef $self->{error}; my @flags; eval { - my $sql = 'select fl_flag from flags where fl_type = ? and - fl_name = ? order by fl_flag'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{type}, $self->{name}); - my $flag; - while (defined ($flag = $sth->fetchrow_array)) { - push (@flags, $flag); + my %search = (fl_type => $self->{type}, + fl_name => $self->{name}); + my %attrs = (order_by => 'fl_flag'); + my @flags_rs = $self->{dbh}->resultset('Flag')->search (\%search, + \%attrs); + for my $flag (@flags_rs) { + push (@flags, $flag->fl_flag); } - $self->{dbh}->commit; }; if ($@) { my $id = $self->{type} . ':' . $self->{name}; $self->error ("cannot retrieve flags for $id: $@"); - $self->{dbh}->rollback; return; } else { return @flags; @@ -435,22 +458,21 @@ sub flag_set { my $name = $self->{name}; my $type = $self->{type}; my $dbh = $self->{dbh}; + my $guard = $dbh->txn_scope_guard; eval { - my $sql = 'select * from flags where fl_type = ? and fl_name = ? and - fl_flag = ?'; - my ($data) = $dbh->selectrow_array ($sql, undef, $type, $name, $flag); - if (defined $data) { + my %search = (fl_type => $type, + fl_name => $name, + fl_flag => $flag); + my $flag = $dbh->resultset('Flag')->find (\%search); + if (defined $flag) { die "flag already set\n"; } - $sql = 'insert into flags (fl_type, fl_name, fl_flag) - values (?, ?, ?)'; - $dbh->do ($sql, undef, $type, $name, $flag); - $self->log_set ('flags', undef, $flag, $user, $host, $time); - $dbh->commit; + $flag = $dbh->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}: $@"); - $dbh->rollback; return; } return 1; @@ -466,11 +488,10 @@ sub format_acl_id { my ($self, $id) = @_; my $name = $id; - my $sql = 'select ac_name from acls where ac_id = ?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($id); - if (my @ref = $sth->fetchrow_array) { - $name = $ref[0] . " ($id)"; + my %search = (ac_id => $id); + my $acl_rs = $self->{dbh}->resultset('Acl')->find (\%search); + if (defined $acl_rs) { + $name = $acl_rs->ac_name . " ($id)"; } return $name; @@ -483,23 +504,29 @@ sub history { my ($self) = @_; my $output = ''; eval { - my $sql = 'select oh_action, oh_field, oh_type_field, oh_old, oh_new, - oh_by, oh_from, oh_on from object_history where oh_type = ? and - oh_name = ? order by oh_on'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{type}, $self->{name}); - my @data; - while (@data = $sth->fetchrow_array) { - $output .= "$data[7] "; - my ($old, $new) = @data[3..4]; - if ($data[0] eq 'set' and $data[1] eq 'flags') { - if (defined ($data[4])) { - $output .= "set flag $data[4]"; - } elsif (defined ($data[3])) { - $output .= "clear flag $data[3]"; + my %search = (oh_type => $self->{type}, + oh_name => $self->{name}); + my %attrs = (order_by => 'oh_on'); + my @history = $self->{dbh}->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 ($data[0] eq 'set' and $data[1] eq 'type_data') { - my $attr = $data[2]; + } 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)) { @@ -507,9 +534,8 @@ sub history { } elsif (defined ($new)) { $output .= "add $new to attribute $attr"; } - } elsif ($data[0] eq 'set' - and ($data[1] eq 'owner' or $data[1] =~ /^acl_/)) { - my $field = $data[1]; + } 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)) { @@ -519,8 +545,7 @@ sub history { } elsif (defined ($old)) { $output .= "unset $field (was $old)"; } - } elsif ($data[0] eq 'set') { - my $field = $data[1]; + } elsif ($action eq 'set') { if (defined ($old) and defined ($new)) { $output .= "set $field to $new (was $old)"; } elsif (defined ($new)) { @@ -529,16 +554,15 @@ sub history { $output .= "unset $field (was $old)"; } } else { - $output .= $data[0]; + $output .= $action; } - $output .= "\n by $data[5] from $data[6]\n"; + $output .= sprintf ("\n by %s from %s\n", $history_rs->oh_by, + $history_rs->oh_from); } - $self->{dbh}->commit; }; if ($@) { my $id = $self->{type} . ':' . $self->{name}; $self->error ("cannot read history for $id: $@"); - $self->{dbh}->rollback; return; } return $output; @@ -592,15 +616,14 @@ sub show { [ ob_downloaded_on => 'Downloaded on' ]); my $fields = join (', ', map { $_->[0] } @attrs); my @data; + my $object_rs; eval { - my $sql = "select $fields from objects where ob_type = ? and - ob_name = ?"; - @data = $self->{dbh}->selectrow_array ($sql, undef, $type, $name); - $self->{dbh}->commit; + my %search = (ob_type => $type, + ob_name => $name); + $object_rs = $self->{dbh}->resultset('Object')->find (\%search); }; if ($@) { $self->error ("cannot retrieve data for ${type}:${name}: $@"); - $self->{dbh}->rollback; return; } my $output = ''; @@ -609,15 +632,18 @@ sub show { # 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 .. $#data) { - next unless defined $data[$i]; - if ($attrs[$i][0] eq 'ob_comment' && length ($data[$i]) > 79 - 17) { + 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; - $data[$i] = wrap (' ' x 17, ' ' x 17, $data[$i]); - $data[$i] =~ s/^ {17}//; + $value = wrap (' ' x 17, ' ' x 17, $value); + $value =~ s/^ {17}//; } - if ($attrs[$i][0] eq 'ob_created_by') { + if ($field eq 'ob_created_by') { my @flags = $self->flag_list; if (not @flags and $self->error) { return; @@ -631,15 +657,14 @@ sub show { } $output .= $attr_output; } - next unless defined $data[$i]; - if ($attrs[$i][0] =~ /^ob_(owner|acl_)/) { - my $acl = eval { Wallet::ACL->new ($data[$i], $self->{dbh}) }; + if ($field =~ /^ob_(owner|acl_)/) { + my $acl = eval { Wallet::ACL->new ($value, $self->{dbh}) }; if ($acl and not $@) { - $data[$i] = $acl->name || $data[$i]; - push (@acls, [ $acl, $data[$i] ]); + $value = $acl->name || $value; + push (@acls, [ $acl, $value ]); } } - $output .= sprintf ("%15s: %s\n", $attrs[$i][1], $data[$i]); + $output .= sprintf ("%15s: %s\n", $fieldtext, $value); } if (@acls) { my %seen; @@ -663,20 +688,31 @@ sub destroy { $self->error ("cannot destroy ${type}:${name}: object is locked"); return; } + my $guard = $self->{dbh}->txn_scope_guard; eval { - my $date = strftime ('%Y-%m-%d %T', localtime $time); - my $sql = 'delete from flags where fl_type = ? and fl_name = ?'; - $self->{dbh}->do ($sql, undef, $type, $name); - $sql = 'delete from objects where ob_type = ? and ob_name = ?'; - $self->{dbh}->do ($sql, undef, $type, $name); - $sql = "insert into object_history (oh_type, oh_name, oh_action, - oh_by, oh_from, oh_on) values (?, ?, 'destroy', ?, ?, ?)"; - $self->{dbh}->do ($sql, undef, $type, $name, $user, $host, $date); - $self->{dbh}->commit; + + # Remove any flags that may exist for the record. + my %search = (fl_type => $type, + fl_name => $name); + $self->{dbh}->resultset('Flag')->search (\%search)->delete; + + # Remove any object records + %search = (ob_type => $type, + ob_name => $name); + $self->{dbh}->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->{dbh}->resultset('ObjectHistory')->create (\%record); + $guard->commit; }; if ($@) { $self->error ("cannot destroy ${type}:${name}: $@"); - $self->{dbh}->rollback; return; } return 1; @@ -733,7 +769,7 @@ 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::Database object, which is stored in the object and used +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]) diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index fd3001f..083dae6 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -40,21 +40,29 @@ sub enctypes_set { my @trace = ($user, $host, $time); my $name = $self->{name}; my %enctypes = map { $_ => 1 } @$enctypes; + my $guard = $self->{dbh}->txn_scope_guard; eval { - my $sql = 'select ke_enctype from keytab_enctypes where ke_name = ?'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($name); - my (@current, $entry); - while (defined ($entry = $sth->fetchrow_arrayref)) { - push (@current, @$entry); + + # Find all enctypes for the given keytab. + my %search = (ke_name => $name); + my @enctypes = $self->{dbh}->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 { - $sql = 'delete from keytab_enctypes where ke_name = ? and - ke_enctype = ?'; - $self->{dbh}->do ($sql, undef, $name, $enctype); + %search = (ke_name => $name, + ke_enctype => $enctype); + $self->{dbh}->resultset('KeytabEnctype')->find (\%search) + ->delete; $self->log_set ('type_data enctypes', $enctype, undef, @trace); } } @@ -64,21 +72,20 @@ sub enctypes_set { # doesn't enforce integrity constraints. We do this in sorted order # to make it easier to test. for my $enctype (sort keys %enctypes) { - $sql = 'select en_name from enctypes where en_name = ?'; - my $status = $self->{dbh}->selectrow_array ($sql, undef, $enctype); - unless ($status) { + my %search = (en_name => $enctype); + my $enctype_rs = $self->{dbh}->('Enctype')->find (\%search); + unless (defined $enctype_rs) { die "unknown encryption type $enctype\n"; } - $sql = 'insert into keytab_enctypes (ke_name, ke_enctype) values - (?, ?)'; - $self->{dbh}->do ($sql, undef, $name, $enctype); + my %record = (ke_name => $name, + ke_enctype => $enctype); + $self->{dbh}->resultset('Enctype')->create (\%record); $self->log_set ('type_data enctypes', undef, $enctype, @trace); } - $self->{dbh}->commit; + $guard->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } return 1; @@ -92,19 +99,16 @@ sub enctypes_list { my ($self) = @_; my @enctypes; eval { - my $sql = 'select ke_enctype from keytab_enctypes where ke_name = ? - order by ke_enctype'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{name}); - my $entry; - while (defined ($entry = $sth->fetchrow_arrayref)) { - push (@enctypes, @$entry); + my %search = (ke_name => $self->{name}); + my %attrs = (order_by => 'ke_enctype'); + my @enctypes_rs = $self->{dbh}->resultset('KeytabEnctype') + ->search (\%search, \%attrs); + for my $enctype_rs (@enctypes_rs) { + push (@enctypes, $enctype_rs->ke_enctype); } - $self->{dbh}->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } return @enctypes; @@ -132,21 +136,21 @@ sub sync_set { $self->error ("unsupported synchronization target $target"); return; } else { + my $guard = $self->{dbh}->txn_scope_guard; eval { - my $sql = 'select ks_target from keytab_sync where ks_name = ?'; - my $dbh = $self->{dbh}; my $name = $self->{name}; - my ($result) = $dbh->selectrow_array ($sql, undef, $name); - if ($result) { - my $sql = 'delete from keytab_sync where ks_name = ?'; - $self->{dbh}->do ($sql, undef, $name); - $self->log_set ('type_data sync', $result, undef, @trace); + my %search = (ks_name => $name); + my $sync_rs = $self->dbh->resultset('KeytabSync') + ->search (\%search); + if (defined $sync_rs) { + my $target = $sync_rs->ks_target; + $sync_rs->delete; + $self->log_set ('type_data sync', $target, undef, @trace); } - $self->{dbh}->commit; + $guard->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } } @@ -161,19 +165,16 @@ sub sync_list { my ($self) = @_; my @targets; eval { - my $sql = 'select ks_target from keytab_sync where ks_name = ? - order by ks_target'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($self->{name}); - my $target; - while (defined ($target = $sth->fetchrow_array)) { - push (@targets, $target); + my %search = (ks_name => $self->{name}); + my %attrs = (order_by => 'ks_target'); + my @syncs = $self->dbh->resultset('KeytabSync')->search (\%search, + \%attrs); + for my $sync_rs (@syncs) { + push (@targets, $sync_rs->ks_target); } - $self->{dbh}->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } return @targets; @@ -247,11 +248,6 @@ sub new { my $kadmin = Wallet::Kadmin->new (); $self->{kadmin} = $kadmin; - # Set a callback for things to do after a fork, specifically for the MIT - # kadmin module which forks to kadmin. - my $callback = sub { $self->{dbh}->{InactiveDestroy} = 1 }; - $kadmin->fork_callback ($callback); - $self = $class->SUPER::new ($type, $name, $dbh); $self->{kadmin} = $kadmin; return $self; @@ -271,11 +267,6 @@ sub create { my $kadmin = Wallet::Kadmin->new (); $self->{kadmin} = $kadmin; - # Set a callback for things to do after a fork, specifically for the MIT - # kadmin module which forks to kadmin. - my $callback = sub { $self->{dbh}->{InactiveDestroy} = 1 }; - $kadmin->fork_callback ($callback); - if (not $kadmin->create ($name)) { die $kadmin->error, "\n"; } @@ -292,16 +283,21 @@ sub destroy { $self->error ("cannot destroy $id: object is locked"); return; } + my $dbh = $self->{dbh}; + my $guard = $dbh->txn_scope_guard; eval { - my $sql = 'delete from keytab_sync where ks_name = ?'; - $self->{dbh}->do ($sql, undef, $self->{name}); - $sql = 'delete from keytab_enctypes where ke_name = ?'; - $self->{dbh}->do ($sql, undef, $self->{name}); - $self->{dbh}->commit; + my %search = (ks_name => $self->{name}); + my $sync_rs = $dbh->resultset('KeytabSync')->search (\%search); + $sync_rs->delete_all if defined $sync_rs; + + %search = (ke_name => $self->{name}); + my $enctype_rs = $dbh->resultset('KeytabEnctype')->search (\%search); + $enctype_rs->delete_all if defined $enctype_rs; + + $guard->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } my $kadmin = $self->{kadmin}; diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index 5a8dc52..ea8cd2f 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -16,12 +16,12 @@ use strict; use vars qw($VERSION); use Wallet::ACL; -use Wallet::Database; +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.03'; +$VERSION = '0.04'; ############################################################################## # Constructor, destructor, and accessors @@ -32,7 +32,7 @@ $VERSION = '0.03'; # exception if anything goes wrong. sub new { my ($class) = @_; - my $dbh = Wallet::Database->connect; + my $dbh = Wallet::Schema->connect; my $self = { dbh => $dbh }; bless ($self, $class); return $self; @@ -59,7 +59,7 @@ sub error { # Disconnect the database handle on object destruction to avoid warnings. sub DESTROY { my ($self) = @_; - $self->{dbh}->disconnect unless $self->{dbh}->{InactiveDestroy}; + $self->{dbh}->storage->dbh->disconnect; } ############################################################################## @@ -69,18 +69,26 @@ sub DESTROY { # Return the SQL statement to find every object in the database. sub objects_all { my ($self) = @_; - my $sql = 'select ob_type, ob_name from objects order by ob_type, - ob_name'; - return $sql; + 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 $sql = 'select ob_type, ob_name from objects where ob_type=? order - by ob_type, ob_name'; - return ($sql, $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 @@ -89,28 +97,36 @@ sub objects_type { # match any ACLs, set an error and return undef. sub objects_owner { my ($self, $owner) = @_; - my ($sth); + my @objects; + + my %search; + my %options = (order_by => [ qw/ob_type ob_name/ ], + select => [ qw/ob_type ob_name/ ]); + if (lc ($owner) eq 'null') { - my $sql = 'select ob_type, ob_name from objects where ob_owner is null - order by objects.ob_type, objects.ob_name'; - return ($sql); + %search = (ob_owner => undef); } else { my $acl = eval { Wallet::ACL->new ($owner, $self->{dbh}) }; return unless $acl; - my $sql = 'select ob_type, ob_name from objects where ob_owner = ? - order by objects.ob_type, objects.ob_name'; - return ($sql, $acl->id); + %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 $sql = 'select ob_type, ob_name from objects left join flags on - (objects.ob_type = flags.fl_type and objects.ob_name = flags.fl_name) - where flags.fl_flag = ? order by objects.ob_type, objects.ob_name'; - return ($sql, $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 @@ -120,22 +136,35 @@ sub objects_flag { # set an error and return the empty string. sub objects_acl { my ($self, $search) = @_; - my $acl = eval { Wallet::ACL->new ($search, $self->{dbh}) }; + my @objects; + + my $dbh = $self->{dbh}; + my $acl = eval { Wallet::ACL->new ($search, $dbh) }; return unless $acl; - my $sql = 'select ob_type, ob_name from objects where ob_owner = ? or - ob_acl_get = ? or ob_acl_store = ? or ob_acl_show = ? or - ob_acl_destroy = ? or ob_acl_flags = ? order by objects.ob_type, - objects.ob_name'; - return ($sql, ($acl->id) x 6); + + 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 $sql = 'select ob_type, ob_name from objects where ob_downloaded_on - is null order by objects.ob_type, objects.ob_name'; - return ($sql); + 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 @@ -148,46 +177,44 @@ sub objects { my ($self, $type, @args) = @_; undef $self->{error}; - # Find the SQL statement and the arguments to use. - my $sql = ''; - my @search = (); + # Get the search and options array refs from specific functions. + my ($search_ref, $options_ref); if (!defined $type || $type eq '') { - ($sql) = $self->objects_all; + ($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') { - ($sql, @search) = $self->objects_type (@args); + ($search_ref, $options_ref) = $self->objects_type (@args); } elsif ($type eq 'owner') { - ($sql, @search) = $self->objects_owner (@args); + ($search_ref, $options_ref) = $self->objects_owner (@args); } elsif ($type eq 'flag') { - ($sql, @search) = $self->objects_flag (@args); + ($search_ref, $options_ref) = $self->objects_flag (@args); } elsif ($type eq 'acl') { - ($sql, @search) = $self->objects_acl (@args); + ($search_ref, $options_ref) = $self->objects_acl (@args); } elsif ($type eq 'unused') { - ($sql) = $self->objects_unused (@args); + ($search_ref, $options_ref) = $self->objects_unused (@args); } else { $self->error ("do not know search type: $type"); } - return unless $sql; + return unless $search_ref; } - # Do the search. + # Perform the search and return on any errors. my @objects; + my $dbh = $self->{dbh}; eval { - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (@search); - my $object; - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@objects, [ @$object ]); + my @objects_rs = $dbh->resultset('Object')->search ($search_ref, + $options_ref); + for my $object_rs (@objects_rs) { + push (@objects, [ $object_rs->ob_type, $object_rs->ob_name ]); } - $self->{dbh}->commit; }; if ($@) { $self->error ("cannot list objects: $@"); - $self->{dbh}->rollback; return; } + return @objects; } @@ -199,17 +226,51 @@ sub objects { # database. sub acls_all { my ($self) = @_; - my $sql = 'select ac_id, ac_name from acls order by ac_id'; - return ($sql); + my @acls; + + my $dbh = $self->{dbh}; + my %search = (); + my %options = (order_by => [ qw/ac_id/ ], + select => [ qw/ac_id ac_name/ ]); + + eval { + my @acls_rs = $dbh->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 $sql = 'select ac_id, ac_name from acls left join acl_entries - on (acls.ac_id = acl_entries.ae_id) where ae_id is null order by - ac_id'; - return ($sql); + my @acls; + + my $dbh = $self->{dbh}; + 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 = $dbh->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 @@ -217,22 +278,69 @@ sub acls_empty { # do a substring search. sub acls_entry { my ($self, $type, $identifier) = @_; - my $sql = 'select distinct ac_id, ac_name from acl_entries left join acls - on (ae_id = ac_id) where ae_scheme = ? and ae_identifier like ? order - by ac_id'; - return ($sql, $type, '%' . $identifier . '%'); + my @acls; + + my $dbh = $self->{dbh}; + 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 = $dbh->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 $sql = 'select ac_id, ac_name from acls where not ac_id in (select - ob_owner from objects where ob_owner = ac_id)'; - for my $acl (qw/get store show destroy flags/) { - $sql .= " and not ac_id in (select ob_acl_$acl from objects where - ob_acl_$acl = ac_id)"; + my @acls; + + my $dbh = $self->{dbh}; + 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 = $dbh->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 ($sql); + return (@acls); } # Obtain a textual representation of the membership of an ACL, returning undef @@ -290,11 +398,10 @@ sub acls { my ($self, $type, @args) = @_; undef $self->{error}; - # Find the SQL statement and the arguments to use. - my $sql; - my @search = (); + # Find the ACLs for any given search. + my @acls; if (!defined $type || $type eq '') { - ($sql) = $self->acls_all; + @acls = $self->acls_all; } else { if ($type eq 'duplicate') { return $self->acls_duplicate; @@ -303,34 +410,17 @@ sub acls { $self->error ('ACL searches require an argument to search'); return; } else { - ($sql, @search) = $self->acls_entry (@args); + @acls = $self->acls_entry (@args); } } elsif ($type eq 'empty') { - ($sql) = $self->acls_empty; + @acls = $self->acls_empty; } elsif ($type eq 'unused') { - ($sql) = $self->acls_unused; + @acls = $self->acls_unused; } else { $self->error ("unknown search type: $type"); return; } } - - # Do the search. - my @acls; - eval { - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute (@search); - my $object; - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@acls, [ @$object ]); - } - $self->{dbh}->commit; - }; - if ($@) { - $self->error ("cannot list ACLs: $@"); - $self->{dbh}->rollback; - return; - } return @acls; } @@ -343,26 +433,32 @@ sub acls { sub owners { my ($self, $type, $name) = @_; undef $self->{error}; - my @lines; + my $dbh = $self->{dbh}; + + my @owners; eval { - my $sql = 'select distinct ae_scheme, ae_identifier from acl_entries, - acls, objects where ae_id = ac_id and ac_id = ob_owner and - ob_type like ? and ob_name like ? order by ae_scheme, - ae_identifier'; - my $sth = $self->{dbh}->prepare ($sql); - $sth->execute ($type, $name); - my $object; - while (defined ($object = $sth->fetchrow_arrayref)) { - push (@lines, [ @$object ]); + 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 = $dbh->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 ]); } - $self->{dbh}->commit; }; if ($@) { $self->error ("cannot report on owners: $@"); - $self->{dbh}->rollback; return; } - return @lines; + return @owners; } ############################################################################## diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index 9a7fe44..d36b7ac 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -1,262 +1,85 @@ -# Wallet::Schema -- Database schema for the wallet system. -# -# 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::Schema; -require 5.006; use strict; -use vars qw(@SQL @TABLES $VERSION); +use warnings; -use DBI; +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. -$VERSION = '0.07'; +our $VERSION = '0.08'; + +__PACKAGE__->load_namespaces; +__PACKAGE__->load_components (qw/Schema::Versioned/); ############################################################################## -# Data manipulation +# Core overrides ############################################################################## -# Create a new Wallet::Schema object, parse the SQL out of the documentation, -# and store it in the object. We have to store the SQL in a static variable, -# since we can't read DATA multiple times. -sub new { +# 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 (@SQL) { - local $_; - my $found; - my $command = ''; - while () { - if (not $found and /^=head1 SCHEMA/) { - $found = 1; - } elsif ($found and /^=head1 /) { - last; - } elsif ($found and /^ /) { - s/^ //; - $command .= $_; - if (/;$/) { - push (@SQL, $command); - $command = ''; - } - } - } - close DATA; + 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 $self = { sql => [ @SQL ] }; - bless ($self, $class); - return $self; -} - -# Returns the SQL as a list of commands. -sub sql { - my ($self) = @_; - return @{ $self->{sql} }; -} - -############################################################################## -# Initialization and cleanup -############################################################################## - -# Run a set of SQL commands, forcing a transaction, rolling back on error, and -# throwing an exception if anything fails. -sub _run_sql { - my ($self, $dbh, @sql) = @_; - eval { - $dbh->begin_work if $dbh->{AutoCommit}; - for my $sql (@sql) { - $dbh->do ($sql, { RaiseError => 1, PrintError => 0 }); - } - $dbh->commit; - }; - if ($@) { - $dbh->rollback; - die "$@\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; } -} - -# Given a database handle, try to create our database by running the SQL. Do -# this in a transaction regardless of the database settings and throw an -# exception if this fails. We have to do a bit of fiddling to get syntax that -# works with both MySQL and SQLite. -sub create { - my ($self, $dbh) = @_; - my $driver = $dbh->{Driver}->{Name}; - my @create = map { - if ($driver eq 'SQLite') { - s/auto_increment primary key/primary key autoincrement/; - } elsif ($driver eq 'mysql' and /^\s*create\s+table\s/) { - s/;$/ engine=InnoDB;/; - } - $_; - } @{ $self->{sql} }; - $self->_run_sql ($dbh, @create); -} - -# Given a database handle, try to remove the wallet database tables by -# reversing the SQL. Do this in a transaction regardless of the database -# settings and throw an exception if this fails. -sub drop { - my ($self, $dbh) = @_; - my @drop = map { - if (/^\s*create\s+table\s+(\S+)/i) { - "drop table if exists $1;"; - } else { - (); - } - } reverse @{ $self->{sql} }; - $self->_run_sql ($dbh, @drop); -} - -# Given an open database handle, determine the current database schema -# version. If we can't read the version number, we currently assume a version -# 0 database. This will change in the future. -sub _schema_version { - my ($self, $dbh) = @_; - my $version; - eval { - my $sql = 'select md_version from metadata'; - my $result = $dbh->selectrow_arrayref ($sql); - $version = $result->[0]; - }; + 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 ($@) { - $version = 0; + die "cannot connect to database: $@\n"; } - return $version; + return $dbh; } -# Given a database handle, try to upgrade the schema of that database to the -# current version while preserving all data. Do this in a transaction -# regardless of the database settings and throw an exception if this fails. -sub upgrade { - my ($self, $dbh) = @_; - my $version = $self->_schema_version ($dbh); - my @sql; - if ($version == 1) { - return; - } elsif ($version == 0) { - @sql = ('create table metadata (md_version integer)', - 'insert into metadata (md_version) values (1)', - 'alter table objects add ob_comment varchar(255) default null' - ); - } else { - die "unknown database version $version\n"; - } - $self->_run_sql ($dbh, @sql); -} +__END__ + +1; ############################################################################## -# Schema +# Documentation ############################################################################## -# The following POD is also parsed by the code to extract SQL blocks. Don't -# add any verbatim blocks to this documentation in the SCHEMA section that -# aren't intended to be SQL. - -1; -__DATA__ - =head1 NAME -Wallet::Schema - Database schema for the wallet system - -=for stopwords -SQL ACL API APIs enums Enums Keytab Backend keytab backend enctypes -enctype Allbery Metadata metadata verifier +Wallet::Schema - Database schema and connector for the wallet system =head1 SYNOPSIS use Wallet::Schema; - my $schema = Wallet::Schema->new; - my @sql = $schema->sql; - $schema->create ($dbh); + my $dbh = 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 Perl -object extracts the schema from the documentation and can either return it -as a list of SQL commands to run or run those commands given a connected -database handle. +documentation you're reading explains and comments the schema. The +class runs using the DBIx::Class module. -This schema attempts to be portable SQL, but it is designed for use with -MySQL and may require some modifications for other databases. - -=head1 METHODS - -=over 4 - -=item new() - -Instantiates a new Wallet::Schema object. This parses the documentation -and extracts the schema, but otherwise doesn't do anything. - -=item create(DBH) - -Given a connected database handle, runs the SQL commands necessary to -create the wallet database in an otherwise empty database. This method -will not drop any existing tables and will therefore fail if a wallet -database has already been created. On any error, this method will throw a -database exception. - -=item drop(DBH) - -Given a connected database handle, drop all of the wallet tables from that -database if any of those tables exist. This method will only remove -tables that are part of the current schema or one of the previous known -schema and won't remove other tables. On any error, this method will -throw a database exception. - -=item sql() - -Returns the schema and the population of the normalization tables as a -list of SQL commands to run to create the wallet database in an otherwise -empty database. - -=item upgrade(DBH) - -Given a connected database handle, runs the SQL commands necessary to -upgrade that database to the current schema version. On any error, this -method will throw a database exception. - -=back +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 Metadata Tables - -This table is used to store metadata about the wallet database, used for -upgrades and in similar situations: - - create table metadata - (md_version integer); - insert into metadata (md_version) values (1); - -This table will normally only have one row. md_version holds the version -number of the schema (which does not necessarily have any relationship to -the version number of wallet itself). - =head2 Normalization Tables -The following are normalization tables used to constrain the values in -other tables. - -Holds the supported flag names: - - create table flag_names - (fn_name varchar(32) primary key); - insert into flag_names (fn_name) values ('locked'); - insert into flag_names (fn_name) values ('unchanging'); - Holds the supported object types and their corresponding Perl classes: create table types @@ -390,8 +213,8 @@ object may have zero or more flags associated with it: not null references objects(ob_type), fl_name varchar(255) not null references objects(ob_name), - fl_flag varchar(32) - not null references flag_names(fn_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); @@ -477,9 +300,22 @@ 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-backend(8), Wallet::Config(3) This module is part of the wallet system. The current version is available from L. diff --git a/perl/Wallet/Schema/Result/Acl.pm b/perl/Wallet/Schema/Result/Acl.pm new file mode 100644 index 0000000..60a357b --- /dev/null +++ b/perl/Wallet/Schema/Result/Acl.pm @@ -0,0 +1,99 @@ +package Wallet::Schema::Result::Acl; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::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 new file mode 100644 index 0000000..99105a0 --- /dev/null +++ b/perl/Wallet/Schema/Result/AclEntry.pm @@ -0,0 +1,63 @@ +package Wallet::Schema::Result::AclEntry; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::AclEntry + +=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 new file mode 100644 index 0000000..2ad56ff --- /dev/null +++ b/perl/Wallet/Schema/Result/AclHistory.pm @@ -0,0 +1,101 @@ +package Wallet::Schema::Result::AclHistory; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +__PACKAGE__->load_components("InflateColumn::DateTime"); + +=head1 NAME + +Wallet::Schema::Result::AclHistory + +=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"); + +__PACKAGE__->might_have( + 'acls', + 'Wallet::Schema::Result::Acl', + { 'foreign.ac_id' => 'self.ah_id' }, + ); + +1; diff --git a/perl/Wallet/Schema/Result/AclScheme.pm b/perl/Wallet/Schema/Result/AclScheme.pm new file mode 100644 index 0000000..96db79d --- /dev/null +++ b/perl/Wallet/Schema/Result/AclScheme.pm @@ -0,0 +1,73 @@ +package Wallet::Schema::Result::AclScheme; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; +__PACKAGE__->load_components (qw//); + +=head1 NAME + +Wallet::Schema::Result::AclScheme + +=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/Enctype.pm b/perl/Wallet/Schema/Result/Enctype.pm new file mode 100644 index 0000000..be41b84 --- /dev/null +++ b/perl/Wallet/Schema/Result/Enctype.pm @@ -0,0 +1,34 @@ +package Wallet::Schema::Result::Enctype; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::Enctype + +=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 new file mode 100644 index 0000000..b38e85f --- /dev/null +++ b/perl/Wallet/Schema/Result/Flag.pm @@ -0,0 +1,54 @@ +package Wallet::Schema::Result::Flag; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::Flag + +=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 new file mode 100644 index 0000000..ae40c52 --- /dev/null +++ b/perl/Wallet/Schema/Result/KeytabEnctype.pm @@ -0,0 +1,42 @@ +package Wallet::Schema::Result::KeytabEnctype; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::KeytabEnctype + +=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 new file mode 100644 index 0000000..92ab6b8 --- /dev/null +++ b/perl/Wallet/Schema/Result/KeytabSync.pm @@ -0,0 +1,42 @@ +package Wallet::Schema::Result::KeytabSync; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::KeytabSync + +=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 new file mode 100644 index 0000000..17c51e2 --- /dev/null +++ b/perl/Wallet/Schema/Result/Object.pm @@ -0,0 +1,258 @@ +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 + +=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 new file mode 100644 index 0000000..067712f --- /dev/null +++ b/perl/Wallet/Schema/Result/ObjectHistory.pm @@ -0,0 +1,127 @@ +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 + +=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"); + +__PACKAGE__->might_have( + 'objects', + 'Wallet::Schema::Result::Object', + { 'foreign.ob_type' => 'self.oh_type', + 'foreign.ob_name' => 'self.oh_name' }, + ); + +1; diff --git a/perl/Wallet/Schema/Result/SyncTarget.pm b/perl/Wallet/Schema/Result/SyncTarget.pm new file mode 100644 index 0000000..17f4320 --- /dev/null +++ b/perl/Wallet/Schema/Result/SyncTarget.pm @@ -0,0 +1,40 @@ +package Wallet::Schema::Result::SyncTarget; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::SyncTarget + +=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 new file mode 100644 index 0000000..89fb4c3 --- /dev/null +++ b/perl/Wallet/Schema/Result/Type.pm @@ -0,0 +1,64 @@ +package Wallet::Schema::Result::Type; + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 NAME + +Wallet::Schema::Result::Type + +=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 index dfb7dbb..402fbe0 100644 --- a/perl/Wallet/Server.pm +++ b/perl/Wallet/Server.pm @@ -18,13 +18,12 @@ use vars qw(%MAPPING $VERSION); use Wallet::ACL; use Wallet::Config; -use Wallet::Database; 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.10'; +$VERSION = '0.11'; ############################################################################## # Utility methods @@ -38,7 +37,7 @@ $VERSION = '0.10'; # for various things. Throw an exception if anything goes wrong. sub new { my ($class, $user, $host) = @_; - my $dbh = Wallet::Database->connect; + my $dbh = Wallet::Schema->connect; my $acl = Wallet::ACL->new ('ADMIN', $dbh); my $self = { dbh => $dbh, @@ -71,8 +70,9 @@ sub error { # Disconnect the database handle on object destruction to avoid warnings. sub DESTROY { my ($self) = @_; - if ($self->{dbh} and not $self->{dbh}->{InactiveDestroy}) { - $self->{dbh}->disconnect; + + if ($self->{dbh}) { + $self->{dbh}->storage->dbh->disconnect; } } @@ -86,13 +86,14 @@ sub type_mapping { my ($self, $type) = @_; my $class; eval { - my $sql = 'select ty_class from types where ty_name = ?'; - ($class) = $self->{dbh}->selectrow_array ($sql, undef, $type); - $self->{dbh}->commit; + my $guard = $self->{dbh}->txn_scope_guard; + my %search = (ty_name => $type); + my $type_rec = $self->{dbh}->resultset('Type')->find (\%search); + $class = $type_rec->ty_class; + $guard->commit; }; if ($@) { $self->error ($@); - $self->{dbh}->rollback; return; } if (defined $class) { diff --git a/perl/create-ddl b/perl/create-ddl new file mode 100755 index 0000000..62deb86 --- /dev/null +++ b/perl/create-ddl @@ -0,0 +1,93 @@ +#!/usr/bin/perl -w +# +# create-ddl - Create DDL files for Wallet +# +# Written by Jon Robertson +# Copyright 2012 Board of Trustees, Leland Stanford Jr. University + +############################################################################# +# Modules and declarations +############################################################################# + +use strict; +use vars qw(); + +use Getopt::Long; +use Wallet::Admin; + +############################################################################# +# Main routine +############################################################################# + +# Get errors and output in the same order. +$| = 0; + +# Clean up the path name. +my $fullpath = $0; +$0 =~ s%^.*/%%; + +# Parse command-line options. +my ($help); +my $oldversion = ''; +Getopt::Long::config ('bundling'); +GetOptions ('h|help' => \$help, + 'o|oldversion=s' => \$oldversion) or exit 1; +if ($help) { + print "Feeding myself to perldoc, please wait....\n"; + exec ('perldoc', '-t', $fullpath); +} + +# Default wallet settings, for Wallet::Admin. +$Wallet::Config::DB_DDL_DIRECTORY = 'sql/'; +$Wallet::Config::DB_DRIVER = 'SQLite'; +$Wallet::Config::DB_INFO = 'wallet-db'; + +# Create a Wallet::Admin object and run the backup. +my $admin = Wallet::Admin->new; +$admin->backup ($oldversion); + +exit(0); + +############################################################################## +# Documentation +############################################################################## + +=head1 NAME + +create-ddl - Create DDL files for Wallet + +=head1 SYNOPSIS + +create-ddl [B<--help>] [B<--oldversion>] + +=head1 DESCRIPTION + +create-ddl is used to create DDL files for the various DBIx::Class +Wallet::Schema modules. It simply is an interface for the backup command +in Wallet::Admin, which does the work via DBIx::Class. The end result +is a number of files that can be used to load the database for each +supported database server. + +These files can be modified after creation to customize the database +load, though should only be done when necessary to prevent confusion +for the schema modules not matching the actual table definitions. This +is currently only done in the case of SQLite databases, due to the +SQLite parser creating keys without AUTOINCREMENT. + +=head1 OPTIONS + +B<--help> + +Prints the perldoc information (this document) for the script. + +B<--oldversion>= + +The version number of the previous version. If there are existing DDL +files for this version, then we will also create diff files to upgrade +a database from the old version to the current. + +=head1 AUTHORS + +Jon Robertson + +=cut diff --git a/perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql b/perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql new file mode 100644 index 0000000..ed0bde1 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.07-0.08-MySQL.sql @@ -0,0 +1,7 @@ +BEGIN; +ALTER TABLE flags MODIFY `fl_flag` enum('locked', 'unchanging') NOT NULL; +DROP TABLE IF EXISTS flag_names; +DROP TABLE IF EXISTS metadata; +ALTER TABLE objects ADD ob_comment varchar(255) default null; +COMMIT; + diff --git a/perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql b/perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql new file mode 100644 index 0000000..3e600b0 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.07-0.08-SQLite.sql @@ -0,0 +1,6 @@ +BEGIN; +DROP TABLE IF EXISTS flag_names; +DROP TABLE IF EXISTS metadata; +ALTER TABLE objects ADD ob_comment varchar(255) default null; +COMMIT; + diff --git a/perl/sql/Wallet-Schema-0.07-MySQL.sql b/perl/sql/Wallet-Schema-0.07-MySQL.sql new file mode 100644 index 0000000..1bd38b3 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.07-MySQL.sql @@ -0,0 +1,211 @@ +-- +-- Created by SQL::Translator::Producer::MySQL +-- Created on Fri Jan 25 14:12:02 2013 +-- +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), + `ah_identifier` varchar(255), + `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), + 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 `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 `flag_names` ( + `fn_name` varchar(32) NOT NULL, + PRIMARY KEY (`fn_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` varchar(32) 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 `metadata`; + +-- +-- Table: `metadata` +-- +CREATE TABLE `metadata` ( + `md_version` integer +); + +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), + 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, + `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, + 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), + `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, + 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.07-SQLite.sql b/perl/sql/Wallet-Schema-0.07-SQLite.sql new file mode 100644 index 0000000..e24ea15 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.07-SQLite.sql @@ -0,0 +1,219 @@ +-- +-- Created by SQL::Translator::Producer::SQLite +-- Created on Fri Jan 25 14:12:02 2013 +-- + +BEGIN TRANSACTION; + +-- +-- Table: acl_history +-- +DROP TABLE IF EXISTS acl_history; + +CREATE TABLE acl_history ( + ah_id INTEGER PRIMARY KEY AUTOINCREMENT 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 AUTOINCREMENT 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 flag_names; + +CREATE TABLE flag_names ( + fn_name varchar(32) NOT NULL, + PRIMARY KEY (fn_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 varchar(32) 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: metadata +-- +DROP TABLE IF EXISTS metadata; + +CREATE TABLE metadata ( + md_version integer +); + +-- +-- 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) +); + +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, + PRIMARY KEY (ob_name, ob_type), + FOREIGN KEY(ob_acl_destroy) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_flags) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_get) REFERENCES acls(ac_id), + FOREIGN KEY(ob_owner) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_show) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_store) REFERENCES acls(ac_id), + 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 AUTOINCREMENT 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) REFERENCES objects(ob_type) +); + +CREATE INDEX object_history_idx_oh_type_oh_name ON object_history (oh_type, oh_name); + +COMMIT; diff --git a/perl/sql/Wallet-Schema-0.08-MySQL.sql b/perl/sql/Wallet-Schema-0.08-MySQL.sql new file mode 100644 index 0000000..44b6475 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.08-MySQL.sql @@ -0,0 +1,193 @@ +-- +-- Created by SQL::Translator::Producer::MySQL +-- Created on Fri Jan 25 14:12:02 2013 +-- +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), + `ah_identifier` varchar(255), + `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), + 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 `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), + 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, + `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), + 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), + `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, + 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.08-PostgreSQL.sql b/perl/sql/Wallet-Schema-0.08-PostgreSQL.sql new file mode 100644 index 0000000..2f79147 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.08-PostgreSQL.sql @@ -0,0 +1,201 @@ +-- +-- Created by SQL::Translator::Producer::PostgreSQL +-- Created on Fri Jan 25 14:12:02 2013 +-- +-- +-- 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 FOREIGN KEY ("ae_scheme") + REFERENCES "acl_schemes" ("as_name") DEFERRABLE; + +ALTER TABLE "acl_entries" ADD FOREIGN KEY ("ae_id") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_acl_destroy") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_acl_flags") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_acl_get") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_owner") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_acl_show") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_acl_store") + REFERENCES "acls" ("ac_id") ON DELETE CASCADE ON UPDATE CASCADE DEFERRABLE; + +ALTER TABLE "objects" ADD FOREIGN KEY ("ob_type") + REFERENCES "types" ("ty_name") DEFERRABLE; + +ALTER TABLE "object_history" ADD FOREIGN KEY ("oh_type", "oh_name") + REFERENCES "objects" ("ob_type", "ob_name") DEFERRABLE; + diff --git a/perl/sql/Wallet-Schema-0.08-SQLite.sql b/perl/sql/Wallet-Schema-0.08-SQLite.sql new file mode 100644 index 0000000..9936c20 --- /dev/null +++ b/perl/sql/Wallet-Schema-0.08-SQLite.sql @@ -0,0 +1,201 @@ +-- +-- Created by SQL::Translator::Producer::SQLite +-- Created on Fri Jan 25 14:12:02 2013 +-- + +BEGIN TRANSACTION; + +-- +-- Table: acl_history +-- +DROP TABLE IF EXISTS acl_history; + +CREATE TABLE acl_history ( + ah_id INTEGER PRIMARY KEY AUTOINCREMENT 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 AUTOINCREMENT 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 varchar(32) 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) +); + +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), + FOREIGN KEY(ob_acl_flags) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_get) REFERENCES acls(ac_id), + FOREIGN KEY(ob_owner) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_show) REFERENCES acls(ac_id), + FOREIGN KEY(ob_acl_store) REFERENCES acls(ac_id), + 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 AUTOINCREMENT 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) REFERENCES objects(ob_type) +); + +CREATE INDEX object_history_idx_oh_type_oh_name ON object_history (oh_type, oh_name); + +COMMIT; diff --git a/perl/t/admin.t b/perl/t/admin.t index 6250f8e..cf6a637 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -8,12 +8,13 @@ # # See LICENSE for licensing terms. -use Test::More tests => 18; +use Test::More tests => 23; use Wallet::Admin; use Wallet::Report; use Wallet::Schema; use Wallet::Server; +use DBI; use lib 't/lib'; use Util; @@ -56,6 +57,24 @@ is ($admin->register_verifier ('base', 'Wallet::ACL::Base'), undef, is ($server->acl_add ('ADMIN', 'base', 'foo'), 1, ' and adding a base ACL now works'); +# Test an upgrade. Reinitialize to an older version, then test upgrade to +# the current version. +$Wallet::Schema::VERSION = '0.07'; +is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, + ' and re-initialization succeeds'); +$Wallet::Schema::VERSION = '0.08'; +my $schema = $admin->dbh; +$schema->upgrade_directory ('sql/'); +my $retval = $admin->upgrade; +is ($retval, 1, 'Performing an upgrade succeeds'); +my $dbh = $schema->storage->dbh; +my $sql = "select version from dbix_class_schema_versions order by version " + ."DESC"; +$version = $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'); + # Clean up. is ($admin->destroy, 1, 'Destruction succeeds'); unlink 'wallet-db'; diff --git a/perl/t/lib/Util.pm b/perl/t/lib/Util.pm index 8bbefc4..c15ccfe 100644 --- a/perl/t/lib/Util.pm +++ b/perl/t/lib/Util.pm @@ -45,6 +45,7 @@ sub contents { # for testing by default, but support t/data/test.database as a configuration # file to use another database backend. sub db_setup { + $Wallet::Config::DB_DDL_DIRECTORY = 'sql/'; if (-f 't/data/test.database') { open (DB, '<', 't/data/test.database') or die "cannot open t/data/test.database: $!"; @@ -60,6 +61,10 @@ sub db_setup { $Wallet::Config::DB_USER = $user if $user; $Wallet::Config::DB_PASSWORD = $password if $password; } else { + + # If we have a new SQLite db by default, disable version checking. + $ENV{DBIC_NO_VERSION_CHECK} = 1; + $Wallet::Config::DB_DRIVER = 'SQLite'; $Wallet::Config::DB_INFO = 'wallet-db'; unlink 'wallet-db'; diff --git a/perl/t/report.t b/perl/t/report.t index 363db20..13ef7b6 100755 --- a/perl/t/report.t +++ b/perl/t/report.t @@ -145,7 +145,7 @@ 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 ownerfinds one'); +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'); diff --git a/perl/t/schema.t b/perl/t/schema.t deleted file mode 100755 index 5dd90d1..0000000 --- a/perl/t/schema.t +++ /dev/null @@ -1,111 +0,0 @@ -#!/usr/bin/perl -w -# -# Tests for the wallet schema class. -# -# Written by Russ Allbery -# Copyright 2007, 2008, 2011 -# The Board of Trustees of the Leland Stanford Junior University -# -# See LICENSE for licensing terms. - -use Test::More tests => 16; - -use DBI (); -use POSIX qw(strftime); -use Wallet::Config (); -use Wallet::Schema (); - -use lib 't/lib'; -use Util; - -my $schema = Wallet::Schema->new; -ok (defined $schema, 'Wallet::Schema creation'); -ok ($schema->isa ('Wallet::Schema'), ' and class verification'); -my @sql = $schema->sql; -ok (@sql > 0, 'sql() returns something'); -is (scalar (@sql), 32, ' and returns the right number of statements'); - -# Connect to a database and test create. -db_setup; -my $connect = "DBI:${Wallet::Config::DB_DRIVER}:${Wallet::Config::DB_INFO}"; -my $user = $Wallet::Config::DB_USER; -my $password = $Wallet::Config::DB_PASSWORD; -$dbh = DBI->connect ($connect, $user, $password); -if (not defined $dbh) { - die "cannot connect to database $connect: $DBI::errstr\n"; -} -$dbh->{RaiseError} = 1; -$dbh->{PrintError} = 0; -eval { $schema->create ($dbh) }; -is ($@, '', "create() doesn't die"); - -# Check that the version number is correct. -my $sql = "select md_version from metadata"; -my $version = $dbh->selectall_arrayref ($sql); -is (@$version, 1, 'metadata has correct number of rows'); -is (@{ $version->[0] }, 1, ' and correct number of columns'); -is ($version->[0][0], 1, ' and the schema version is correct'); - -# Test upgrading the database from version 0. SQLite cannot drop table -# columns, so we have to kill the table and then recreate it. -$dbh->do ("drop table metadata"); -if (lc ($Wallet::Config::DB_DRIVER) eq 'sqlite') { - ($sql) = grep { /create table objects/ } $schema->sql; - $sql =~ s/ob_comment .*,//; - $dbh->do ("drop table objects") - or die "cannot drop objects table: $DBI::errstr\n"; - $dbh->do ($sql) - or die "cannot recreate objects table: $DBI::errstr\n"; -} else { - $dbh->do ("alter table objects drop column ob_comment") - or die "cannot drop ob_comment column: $DBI::errstr\n"; -} -eval { $schema->upgrade ($dbh) }; -is ($@, '', "upgrade() doesn't die"); -$sql = "select md_version from metadata"; -$version = $dbh->selectall_arrayref ($sql); -is (@$version, 1, ' and metadata has correct number of rows'); -is (@{ $version->[0] }, 1, ' and correct number of columns'); -is ($version->[0][0], 1, ' and the schema version is correct'); -$sql = "insert into objects (ob_type, ob_name, ob_created_by, ob_created_from, - ob_created_on, ob_comment) values ('file', 'test', 'test', - 'test.example.org', ?, 'a test comment')"; -$dbh->do ($sql, undef, strftime ('%Y-%m-%d %T', localtime time)); -$sql = "select ob_comment from objects where ob_name = 'test'"; -my ($comment) = $dbh->selectrow_array ($sql); -is ($comment, 'a test comment', ' and ob_comment was added to objects'); - -# Test dropping the database. -eval { $schema->drop ($dbh) }; -is ($@, '', "drop() doesn't die"); - -# Make sure all the tables are gone. -SKIP: { - if (lc ($Wallet::Config::DB_DRIVER) eq 'sqlite') { - my $sql = "select name from sqlite_master where type = 'table'"; - my $sth = $dbh->prepare ($sql); - $sth->execute; - my ($table, @tables); - while (defined ($table = $sth->fetchrow_array)) { - push (@tables, $table) unless $table =~ /^sqlite_/; - } - is ("@tables", '', ' and there are no tables in the database'); - } elsif (lc ($Wallet::Config::DB_DRIVER) eq 'mysql') { - my $sql = "show tables"; - my $sth = $dbh->prepare ($sql); - $sth->execute; - my ($table, @tables); - while (defined ($table = $sth->fetchrow_array)) { - push (@tables, $table); - } - is ("@tables", '', ' and there are no tables in the database'); - } else { - skip 1; - } -} -eval { $schema->create ($dbh) }; -is ($@, '', ' and we can run create again'); - -# Clean up. -eval { $schema->drop ($dbh) }; -unlink 'wallet-db'; diff --git a/perl/t/server.t b/perl/t/server.t index 8e0a30d..63f2e76 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -1030,5 +1030,5 @@ 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/^cannot connect to database: /, +like ($@, qr/unable to open database file/, ' or if the database connection fails'); diff --git a/server/wallet-admin b/server/wallet-admin index 94d62c7..7e5a402 100755 --- a/server/wallet-admin +++ b/server/wallet-admin @@ -15,6 +15,13 @@ use strict; use Wallet::Admin; +# The last non-DBIx::Class version. If a database has no DBIx::Class +# versioning, we want to set it to this so that upgrades can begin. +our $BASE_VERSION = '0.07'; + +# Directory that contains the wallet SQL files for upgrades. +our $SQL_DIR = '/usr/share/wallet/sql/'; + ############################################################################## # Implementation ############################################################################## @@ -41,6 +48,9 @@ sub command { die "too few arguments to initialize\n" if @args < 1; die "invalid admin principal $args[0]\n" unless $args[0] =~ /^[^\@\s]+\@\S+$/; + + my $schema = $admin->{dbh}; + $schema->upgrade_directory ($SQL_DIR); $admin->initialize (@args) or die $admin->error, "\n"; } elsif ($command eq 'register') { die "too many arguments to register\n" if @args > 3; @@ -59,7 +69,20 @@ sub command { } } elsif ($command eq 'upgrade') { die "too many arguments to upgrade\n" if @args; + + my $schema = $admin->{dbh}; + $schema->upgrade_directory ($SQL_DIR); + + # Check to see if the database is versioned. If not, install the + # versioning table and default version. + if (!$schema->get_db_version) { + print "Versioning database.\n"; + $schema->install ($BASE_VERSION); + } + + # Actually upgrade. $admin->upgrade or die $admin->error, "\n"; + } else { die "unknown command $command\n"; } -- cgit v1.2.3 From bf18b39b6afe541e6888d32d6a555643cbe9d22e Mon Sep 17 00:00:00 2001 From: Jon Robertson Date: Thu, 31 Jan 2013 16:27:49 -0800 Subject: Renamed dbh subroutines and variables for clarity In moving from DBI to DBIx::Class, we at first left the various variables the same. This goes through to update them for the proper names. * Wallet::Admin::schema was created to return the schema object (and similarly for Wallet::Server and Wallet::Report). * Wallet::Admin::dbh was modified to return the actual DBI handle again (and similarly for Wallet::Server and Wallet::Report). * Various places that used $admin->{dbh} were moved to $admin->{schema}. * Various places using $dbh for the schema object were changed to $schema. Change-Id: I00914866e9a8250855a7828474aa9ce0f37b914f Reviewed-on: https://gerrit.stanford.edu/733 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/ACL.pm | 64 ++++++++++++++++----------------- perl/Wallet/Admin.pm | 49 ++++++++++++++----------- perl/Wallet/Object/Base.pm | 80 ++++++++++++++++++++--------------------- perl/Wallet/Object/File.pm | 2 +- perl/Wallet/Object/Keytab.pm | 43 +++++++++++----------- perl/Wallet/Object/WAKeyring.pm | 2 +- perl/Wallet/Report.pm | 50 ++++++++++++++------------ perl/Wallet/Schema.pm | 6 ++-- perl/Wallet/Server.pm | 64 +++++++++++++++++++-------------- perl/t/acl.t | 26 +++++++------- perl/t/admin.t | 4 +-- perl/t/file.t | 14 ++++---- perl/t/init.t | 6 ++-- perl/t/keytab.t | 4 +-- perl/t/object.t | 20 +++++------ perl/t/server.t | 4 +-- perl/t/wa-keyring.t | 10 +++--- 17 files changed, 236 insertions(+), 212 deletions(-) (limited to 'perl/t/admin.t') diff --git a/perl/Wallet/ACL.pm b/perl/Wallet/ACL.pm index 4f51c70..1e62e7b 100644 --- a/perl/Wallet/ACL.pm +++ b/perl/Wallet/ACL.pm @@ -32,7 +32,7 @@ $VERSION = '0.07'; # and the database handle to use for future operations. If the object # doesn't exist, throws an exception. sub new { - my ($class, $id, $dbh) = @_; + my ($class, $id, $schema) = @_; my (%search, $data, $name); if ($id =~ /^\d+\z/) { $search{ac_id} = $id; @@ -40,7 +40,7 @@ sub new { $search{ac_name} = $id; } eval { - $data = $dbh->resultset('Acl')->find (\%search); + $data = $schema->resultset('Acl')->find (\%search); }; if ($@) { die "cannot search for ACL $id: $@\n"; @@ -48,9 +48,9 @@ sub new { die "ACL $id not found\n"; } my $self = { - dbh => $dbh, - id => $data->ac_id, - name => $data->ac_name, + schema => $schema, + id => $data->ac_id, + name => $data->ac_name, }; bless ($self, $class); return $self; @@ -60,18 +60,18 @@ sub 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, $dbh, $user, $host, $time) = @_; + 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 = $dbh->txn_scope_guard; + my $guard = $schema->txn_scope_guard; # Create the new record. my %record = (ac_name => $name); - my $acl = $dbh->resultset('Acl')->create (\%record); + my $acl = $schema->resultset('Acl')->create (\%record); $id = $acl->ac_id; die "unable to retrieve new ACL ID" unless defined $id; @@ -82,7 +82,7 @@ sub create { ah_by => $user, ah_from => $host, ah_on => $date); - my $history = $dbh->resultset('AclHistory')->create (\%record); + my $history = $schema->resultset('AclHistory')->create (\%record); die "unable to create new history entry" unless defined $history; $guard->commit; @@ -91,9 +91,9 @@ sub create { die "cannot create ACL $name: $@\n"; } my $self = { - dbh => $dbh, - id => $id, - name => $name, + schema => $schema, + id => $id, + name => $name, }; bless ($self, $class); return $self; @@ -134,7 +134,7 @@ sub scheme_mapping { my $class; eval { my %search = (as_name => $scheme); - my $scheme_rec = $self->{dbh}->resultset('AclScheme') + my $scheme_rec = $self->{schema}->resultset('AclScheme') ->find (\%search); $class = $scheme_rec->as_class; }; @@ -169,7 +169,7 @@ sub log_acl { ah_by => $user, ah_from => $host, ah_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{dbh}->resultset('AclHistory')->create (\%record); + $self->{schema}->resultset('AclHistory')->create (\%record); } ############################################################################## @@ -186,9 +186,9 @@ sub rename { return; } eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %search = (ac_id => $self->{id}); - my $acls = $self->{dbh}->resultset('Acl')->find (\%search); + my $acls = $self->{schema}->resultset('Acl')->find (\%search); $acls->ac_name ($name); $acls->update; $guard->commit; @@ -212,7 +212,7 @@ sub destroy { my ($self, $user, $host, $time) = @_; $time ||= time; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; # Make certain no one is using the ACL. my @search = ({ ob_owner => $self->{id} }, @@ -221,7 +221,7 @@ sub destroy { { ob_acl_show => $self->{id} }, { ob_acl_destroy => $self->{id} }, { ob_acl_flags => $self->{id} }); - my @entries = $self->{dbh}->resultset('Object')->search (\@search); + my @entries = $self->{schema}->resultset('Object')->search (\@search); if (@entries) { my ($entry) = @entries; die "ACL in use by ".$entry->ob_type.":".$entry->ob_name; @@ -229,14 +229,14 @@ sub destroy { # Delete any entries (there may or may not be any). my %search = (ae_id => $self->{id}); - @entries = $self->{dbh}->resultset('AclEntry')->search(\%search); + @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->{dbh}->resultset('Acl')->find(\%search); + my $entry = $self->{schema}->resultset('Acl')->find(\%search); $entry->delete if defined $entry; # Create new history line for the deletion. @@ -245,7 +245,7 @@ sub destroy { ah_by => $user, ah_from => $host, ah_on => $time); - $self->{dbh}->resultset('AclHistory')->create (\%record); + $self->{schema}->resultset('AclHistory')->create (\%record); $guard->commit; }; if ($@) { @@ -268,11 +268,11 @@ sub add { return; } eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %record = (ae_id => $self->{id}, ae_scheme => $scheme, ae_identifier => $identifier); - my $entry = $self->{dbh}->resultset('AclEntry')->create (\%record); + my $entry = $self->{schema}->resultset('AclEntry')->create (\%record); $self->log_acl ('add', $scheme, $identifier, $user, $host, $time); $guard->commit; }; @@ -290,11 +290,11 @@ sub remove { my ($self, $scheme, $identifier, $user, $host, $time) = @_; $time ||= time; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %search = (ae_id => $self->{id}, ae_scheme => $scheme, ae_identifier => $identifier); - my $entry = $self->{dbh}->resultset('AclEntry')->find (\%search); + my $entry = $self->{schema}->resultset('AclEntry')->find (\%search); unless (defined $entry) { die "entry not found in ACL\n"; } @@ -322,9 +322,9 @@ sub list { undef $self->{error}; my @entries; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %search = (ae_id => $self->{id}); - my @entry_recs = $self->{dbh}->resultset('AclEntry') + my @entry_recs = $self->{schema}->resultset('AclEntry') ->search (\%search); for my $entry (@entry_recs) { push (@entries, [ $entry->ae_scheme, $entry->ae_identifier ]); @@ -364,11 +364,11 @@ sub history { my ($self) = @_; my $output = ''; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %search = (ah_acl => $self->{id}); my %options = (order_by => 'ah_on'); - my @data = $self->{dbh}->resultset('AclHistory')->search (\%search, - \%options); + 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); @@ -512,14 +512,14 @@ references. =over 4 -=item new(ACL, DBH) +=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, DBH, PRINCIPAL, HOSTNAME [, DATETIME]) +=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 diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index c0b1730..9fc146c 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -39,8 +39,8 @@ our $BASE_VERSION = '0.07'; # Throw an exception if anything goes wrong. sub new { my ($class) = @_; - my $dbh = Wallet::Schema->connect; - my $self = { dbh => $dbh }; + my $schema = Wallet::Schema->connect; + my $self = { schema => $schema }; bless ($self, $class); return $self; } @@ -48,7 +48,13 @@ sub new { # Returns the database handle (used mostly for testing). sub dbh { my ($self) = @_; - return $self->{dbh}; + 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. @@ -66,7 +72,7 @@ sub error { # Disconnect the database handle on object destruction to avoid warnings. sub DESTROY { my ($self) = @_; - $self->{dbh}->storage->dbh->disconnect; + $self->{schema}->storage->dbh->disconnect; } ############################################################################## @@ -83,7 +89,7 @@ sub initialize { # Deploy the database schema from DDL files, if they exist. If not then # we automatically get the database from the Schema modules. - $self->{dbh}->deploy ({}, $Wallet::Config::DB_DDL_DIRECTORY); + $self->{schema}->deploy ({}, $Wallet::Config::DB_DDL_DIRECTORY); if ($@) { $self->error ($@); return; @@ -91,7 +97,8 @@ sub initialize { $self->default_data; # Create a default admin ACL. - my $acl = Wallet::ACL->create ('ADMIN', $self->{dbh}, $user, 'localhost'); + my $acl = Wallet::ACL->create ('ADMIN', $self->{schema}, $user, + 'localhost'); unless ($acl->add ('krb5', $user, $user, 'localhost')) { $self->error ($acl->error); return; @@ -106,7 +113,7 @@ sub default_data { my ($self) = @_; # acl_schemes default rows. - my ($r1) = $self->{dbh}->resultset('AclScheme')->populate ([ + my ($r1) = $self->{schema}->resultset('AclScheme')->populate ([ [ qw/as_name as_class/ ], [ 'krb5', 'Wallet::ACL::Krb5' ], [ 'krb5-regex', 'Wallet::ACL::Krb5::Regex' ], @@ -120,7 +127,7 @@ sub default_data { my @record = ([ qw/ty_name ty_class/ ], [ 'file', 'Wallet::Object::File' ], [ 'keytab', 'Wallet::Object::Keytab' ]); - ($r1) = $self->{dbh}->resultset('Type')->populate (\@record); + ($r1) = $self->{schema}->resultset('Type')->populate (\@record); warn "default Type not installed" unless defined $r1; return 1; @@ -141,13 +148,13 @@ sub destroy { my ($self) = @_; # Get an actual DBI handle and use it to delete all tables. - my $real_dbh = $self->{dbh}->storage->dbh; + 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"; - $real_dbh->do ($sql); + $dbh->do ($sql); } return 1; @@ -160,9 +167,9 @@ sub backup { my @dbs = qw/MySQL SQLite PostgreSQL/; my $version = $Wallet::Schema::VERSION; - $self->{dbh}->create_ddl_dir (\@dbs, $version, - $Wallet::Config::DB_DDL_DIRECTORY, - $oldversion); + $self->{schema}->create_ddl_dir (\@dbs, $version, + $Wallet::Config::DB_DDL_DIRECTORY, + $oldversion); return 1; } @@ -174,8 +181,8 @@ sub upgrade { # Check to see if the database is versioned. If not, install the # versioning table and default version. - if (!$self->{dbh}->get_db_version) { - $self->{dbh}->install ($BASE_VERSION); + if (!$self->{schema}->get_db_version) { + $self->{schema}->install ($BASE_VERSION); } # Suppress warnings that actually are just informational messages. @@ -187,8 +194,8 @@ sub upgrade { }; # Perform the actual upgrade. - if ($self->{dbh}->get_db_version) { - eval { $self->{dbh}->upgrade; }; + if ($self->{schema}->get_db_version) { + eval { $self->{schema}->upgrade; }; } if ($@) { $self->error ($@); @@ -210,10 +217,10 @@ sub upgrade { sub register_object { my ($self, $type, $class) = @_; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %record = (ty_name => $type, ty_class => $class); - $self->{dbh}->resultset('Type')->create (\%record); + $self->{schema}->resultset('Type')->create (\%record); $guard->commit; }; if ($@) { @@ -230,10 +237,10 @@ sub register_object { sub register_verifier { my ($self, $scheme, $class) = @_; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %record = (as_name => $scheme, as_class => $class); - $self->{dbh}->resultset('AclScheme')->create (\%record); + $self->{schema}->resultset('AclScheme')->create (\%record); $guard->commit; }; if ($@) { diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm index 5bd89a7..dd128cc 100644 --- a/perl/Wallet/Object/Base.pm +++ b/perl/Wallet/Object/Base.pm @@ -36,16 +36,16 @@ $VERSION = '0.06'; # 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, $dbh) = @_; + my ($class, $type, $name, $schema) = @_; my %search = (ob_type => $type, ob_name => $name); - my $object = $dbh->resultset('Object')->find (\%search); + my $object = $schema->resultset('Object')->find (\%search); die "cannot find ${type}:${name}\n" unless ($object and $object->ob_name eq $name); my $self = { - dbh => $dbh, - name => $name, - type => $type, + schema => $schema, + name => $name, + type => $type, }; bless ($self, $class); return $self; @@ -56,11 +56,11 @@ sub new { # 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, $dbh, $user, $host, $time) = @_; + 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 = $dbh->txn_scope_guard; + my $guard = $schema->txn_scope_guard; eval { my %record = (ob_type => $type, ob_name => $name, @@ -68,7 +68,7 @@ sub create { ob_created_from => $host, ob_created_on => strftime ('%Y-%m-%d %T', localtime $time)); - $dbh->resultset('Object')->create (\%record); + $schema->resultset('Object')->create (\%record); %record = (oh_type => $type, oh_name => $name, @@ -76,7 +76,7 @@ sub create { oh_by => $user, oh_from => $host, oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $dbh->resultset('ObjectHistory')->create (\%record); + $schema->resultset('ObjectHistory')->create (\%record); $guard->commit; }; @@ -84,9 +84,9 @@ sub create { die "cannot create object ${type}:${name}: $@\n"; } my $self = { - dbh => $dbh, - name => $name, - type => $type, + schema => $schema, + name => $name, + type => $type, }; bless ($self, $class); return $self; @@ -136,7 +136,7 @@ sub log_action { # 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->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; eval { my %record = (oh_type => $self->{type}, oh_name => $self->{name}, @@ -144,11 +144,11 @@ sub log_action { oh_by => $user, oh_from => $host, oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{dbh}->resultset('ObjectHistory')->create (\%record); + $self->{schema}->resultset('ObjectHistory')->create (\%record); my %search = (ob_type => $self->{type}, ob_name => $self->{name}); - my $object = $self->{dbh}->resultset('Object')->find (\%search); + my $object = $self->{schema}->resultset('Object')->find (\%search); if ($action eq 'get') { $object->ob_downloaded_by ($user); $object->ob_downloaded_from ($host); @@ -202,7 +202,7 @@ sub log_set { oh_by => $user, oh_from => $host, oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{dbh}->resultset('ObjectHistory')->create (\%record); + $self->{schema}->resultset('ObjectHistory')->create (\%record); } ############################################################################## @@ -225,11 +225,11 @@ sub _set_internal { return; } - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; eval { my %search = (ob_type => $type, ob_name => $name); - my $object = $self->{dbh}->resultset('Object')->find (\%search); + my $object = $self->{schema}->resultset('Object')->find (\%search); my $old = $object->get_column ("ob_$attr"); $object->update ({ "ob_$attr" => $value }); @@ -261,7 +261,7 @@ sub _get_internal { eval { my %search = (ob_type => $type, ob_name => $name); - my $object = $self->{dbh}->resultset('Object')->find (\%search); + my $object = $self->{schema}->resultset('Object')->find (\%search); $value = $object->get_column ($attr); }; if ($@) { @@ -282,7 +282,7 @@ sub acl { my $attr = "acl_$type"; if ($id) { my $acl; - eval { $acl = Wallet::ACL->new ($id, $self->{dbh}) }; + eval { $acl = Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -352,7 +352,7 @@ sub owner { my ($self, $owner, $user, $host, $time) = @_; if ($owner) { my $acl; - eval { $acl = Wallet::ACL->new ($owner, $self->{dbh}) }; + eval { $acl = Wallet::ACL->new ($owner, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -375,13 +375,13 @@ sub flag_check { my ($self, $flag) = @_; my $name = $self->{name}; my $type = $self->{type}; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my $value; eval { my %search = (fl_type => $type, fl_name => $name, fl_flag => $flag); - my $flag = $dbh->resultset('Flag')->find (\%search); + my $flag = $schema->resultset('Flag')->find (\%search); if (not defined $flag) { $value = 0; } else { @@ -403,13 +403,13 @@ sub flag_clear { $time ||= time; my $name = $self->{name}; my $type = $self->{type}; - my $dbh = $self->{dbh}; - my $guard = $dbh->txn_scope_guard; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; eval { my %search = (fl_type => $type, fl_name => $name, fl_flag => $flag); - my $flag = $dbh->resultset('Flag')->find (\%search); + my $flag = $schema->resultset('Flag')->find (\%search); unless (defined $flag) { die "flag not set\n"; } @@ -435,8 +435,8 @@ sub flag_list { my %search = (fl_type => $self->{type}, fl_name => $self->{name}); my %attrs = (order_by => 'fl_flag'); - my @flags_rs = $self->{dbh}->resultset('Flag')->search (\%search, - \%attrs); + my @flags_rs = $self->{schema}->resultset('Flag')->search (\%search, + \%attrs); for my $flag (@flags_rs) { push (@flags, $flag->fl_flag); } @@ -457,17 +457,17 @@ sub flag_set { $time ||= time; my $name = $self->{name}; my $type = $self->{type}; - my $dbh = $self->{dbh}; - my $guard = $dbh->txn_scope_guard; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; eval { my %search = (fl_type => $type, fl_name => $name, fl_flag => $flag); - my $flag = $dbh->resultset('Flag')->find (\%search); + my $flag = $schema->resultset('Flag')->find (\%search); if (defined $flag) { die "flag already set\n"; } - $flag = $dbh->resultset('Flag')->create (\%search); + $flag = $schema->resultset('Flag')->create (\%search); $self->log_set ('flags', undef, $flag->fl_flag, $user, $host, $time); $guard->commit; }; @@ -489,7 +489,7 @@ sub format_acl_id { my $name = $id; my %search = (ac_id => $id); - my $acl_rs = $self->{dbh}->resultset('Acl')->find (\%search); + my $acl_rs = $self->{schema}->resultset('Acl')->find (\%search); if (defined $acl_rs) { $name = $acl_rs->ac_name . " ($id)"; } @@ -507,7 +507,7 @@ sub history { my %search = (oh_type => $self->{type}, oh_name => $self->{name}); my %attrs = (order_by => 'oh_on'); - my @history = $self->{dbh}->resultset('ObjectHistory') + my @history = $self->{schema}->resultset('ObjectHistory') ->search (\%search, \%attrs); for my $history_rs (@history) { @@ -620,7 +620,7 @@ sub show { eval { my %search = (ob_type => $type, ob_name => $name); - $object_rs = $self->{dbh}->resultset('Object')->find (\%search); + $object_rs = $self->{schema}->resultset('Object')->find (\%search); }; if ($@) { $self->error ("cannot retrieve data for ${type}:${name}: $@"); @@ -658,7 +658,7 @@ sub show { $output .= $attr_output; } if ($field =~ /^ob_(owner|acl_)/) { - my $acl = eval { Wallet::ACL->new ($value, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($value, $self->{schema}) }; if ($acl and not $@) { $value = $acl->name || $value; push (@acls, [ $acl, $value ]); @@ -688,18 +688,18 @@ sub destroy { $self->error ("cannot destroy ${type}:${name}: object is locked"); return; } - my $guard = $self->{dbh}->txn_scope_guard; + 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->{dbh}->resultset('Flag')->search (\%search)->delete; + $self->{schema}->resultset('Flag')->search (\%search)->delete; # Remove any object records %search = (ob_type => $type, ob_name => $name); - $self->{dbh}->resultset('Object')->search (\%search)->delete; + $self->{schema}->resultset('Object')->search (\%search)->delete; # And create a new history object for the destroy action. my %record = (oh_type => $type, @@ -708,7 +708,7 @@ sub destroy { oh_by => $user, oh_from => $host, oh_on => strftime ('%Y-%m-%d %T', localtime $time)); - $self->{dbh}->resultset('ObjectHistory')->create (\%record); + $self->{schema}->resultset('ObjectHistory')->create (\%record); $guard->commit; }; if ($@) { diff --git a/perl/Wallet/Object/File.pm b/perl/Wallet/Object/File.pm index 47c8ac2..69468e1 100644 --- a/perl/Wallet/Object/File.pm +++ b/perl/Wallet/Object/File.pm @@ -143,7 +143,7 @@ API HOSTNAME DATETIME keytab remctld backend nul Allbery wallet-backend my @name = qw(file mysql-lsdb) my @trace = ($user, $host, time); - my $object = Wallet::Object::Keytab->create (@name, $dbh, @trace); + my $object = Wallet::Object::Keytab->create (@name, $schema, @trace); unless ($object->store ("the-password\n")) { die $object->error, "\n"; } diff --git a/perl/Wallet/Object/Keytab.pm b/perl/Wallet/Object/Keytab.pm index b50fb6e..962c19b 100644 --- a/perl/Wallet/Object/Keytab.pm +++ b/perl/Wallet/Object/Keytab.pm @@ -40,12 +40,12 @@ sub enctypes_set { my @trace = ($user, $host, $time); my $name = $self->{name}; my %enctypes = map { $_ => 1 } @$enctypes; - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; eval { # Find all enctypes for the given keytab. my %search = (ke_name => $name); - my @enctypes = $self->{dbh}->resultset('KeytabEnctype') + my @enctypes = $self->{schema}->resultset('KeytabEnctype') ->search (\%search); my (@current); for my $enctype_rs (@enctypes) { @@ -61,7 +61,7 @@ sub enctypes_set { } else { %search = (ke_name => $name, ke_enctype => $enctype); - $self->{dbh}->resultset('KeytabEnctype')->find (\%search) + $self->{schema}->resultset('KeytabEnctype')->find (\%search) ->delete; $self->log_set ('type_data enctypes', $enctype, undef, @trace); } @@ -73,13 +73,13 @@ sub enctypes_set { # to make it easier to test. for my $enctype (sort keys %enctypes) { my %search = (en_name => $enctype); - my $enctype_rs = $self->{dbh}->('Enctype')->find (\%search); + my $enctype_rs = $self->{schema}->('Enctype')->find (\%search); unless (defined $enctype_rs) { die "unknown encryption type $enctype\n"; } my %record = (ke_name => $name, ke_enctype => $enctype); - $self->{dbh}->resultset('Enctype')->create (\%record); + $self->{schema}->resultset('Enctype')->create (\%record); $self->log_set ('type_data enctypes', undef, $enctype, @trace); } $guard->commit; @@ -101,7 +101,7 @@ sub enctypes_list { eval { my %search = (ke_name => $self->{name}); my %attrs = (order_by => 'ke_enctype'); - my @enctypes_rs = $self->{dbh}->resultset('KeytabEnctype') + my @enctypes_rs = $self->{schema}->resultset('KeytabEnctype') ->search (\%search, \%attrs); for my $enctype_rs (@enctypes_rs) { push (@enctypes, $enctype_rs->ke_enctype); @@ -136,11 +136,11 @@ sub sync_set { $self->error ("unsupported synchronization target $target"); return; } else { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; eval { my $name = $self->{name}; my %search = (ks_name => $name); - my $sync_rs = $self->{dbh}->resultset('KeytabSync') + my $sync_rs = $self->{schema}->resultset('KeytabSync') ->find (\%search); if (defined $sync_rs) { my $target = $sync_rs->ks_target; @@ -167,8 +167,8 @@ sub sync_list { eval { my %search = (ks_name => $self->{name}); my %attrs = (order_by => 'ks_target'); - my @syncs = $self->{dbh}->resultset('KeytabSync')->search (\%search, - \%attrs); + my @syncs = $self->{schema}->resultset('KeytabSync')->search (\%search, + \%attrs); for my $sync_rs (@syncs) { push (@targets, $sync_rs->ks_target); } @@ -239,16 +239,16 @@ sub attr_show { # Override new to start by creating a handle for the kadmin module we're # using. sub new { - my ($class, $type, $name, $dbh) = @_; + my ($class, $type, $name, $schema) = @_; my $self = { - dbh => $dbh, + schema => $schema, kadmin => undef, }; bless $self, $class; my $kadmin = Wallet::Kadmin->new (); $self->{kadmin} = $kadmin; - $self = $class->SUPER::new ($type, $name, $dbh); + $self = $class->SUPER::new ($type, $name, $schema); $self->{kadmin} = $kadmin; return $self; } @@ -258,9 +258,9 @@ sub new { # great here since we don't have a way to communicate the error back to the # caller. sub create { - my ($class, $type, $name, $dbh, $creator, $host, $time) = @_; + my ($class, $type, $name, $schema, $creator, $host, $time) = @_; my $self = { - dbh => $dbh, + schema => $schema, kadmin => undef, }; bless $self, $class; @@ -270,7 +270,8 @@ sub create { if (not $kadmin->create ($name)) { die $kadmin->error, "\n"; } - $self = $class->SUPER::create ($type, $name, $dbh, $creator, $host, $time); + $self = $class->SUPER::create ($type, $name, $schema, $creator, $host, + $time); $self->{kadmin} = $kadmin; return $self; } @@ -283,15 +284,15 @@ sub destroy { $self->error ("cannot destroy $id: object is locked"); return; } - my $dbh = $self->{dbh}; - my $guard = $dbh->txn_scope_guard; + my $schema = $self->{schema}; + my $guard = $schema->txn_scope_guard; eval { my %search = (ks_name => $self->{name}); - my $sync_rs = $dbh->resultset('KeytabSync')->search (\%search); + my $sync_rs = $schema->resultset('KeytabSync')->search (\%search); $sync_rs->delete_all if defined $sync_rs; %search = (ke_name => $self->{name}); - my $enctype_rs = $dbh->resultset('KeytabEnctype')->search (\%search); + my $enctype_rs = $schema->resultset('KeytabEnctype')->search (\%search); $enctype_rs->delete_all if defined $enctype_rs; $guard->commit; @@ -353,7 +354,7 @@ Wallet::Object::Keytab - Keytab object implementation for wallet my @name = qw(keytab host/shell.example.com); my @trace = ($user, $host, time); - my $object = Wallet::Object::Keytab->create (@name, $dbh, @trace); + my $object = Wallet::Object::Keytab->create (@name, $schema, @trace); my $keytab = $object->get (@trace); $object->destroy (@trace); diff --git a/perl/Wallet/Object/WAKeyring.pm b/perl/Wallet/Object/WAKeyring.pm index b26be58..f33497c 100644 --- a/perl/Wallet/Object/WAKeyring.pm +++ b/perl/Wallet/Object/WAKeyring.pm @@ -255,7 +255,7 @@ Wallet::Object::WAKeyring - WebAuth keyring object implementation for wallet my ($user, $host, $time); my @name = qw(wa-keyring www.stanford.edu); my @trace = ($user, $host, $time); - my $object = Wallet::Object::WAKeyring->create (@name, $dbh, $trace); + my $object = Wallet::Object::WAKeyring->create (@name, $schema, $trace); my $keyring = $object->get (@trace); unless ($object->store ($keyring)) { die $object->error, "\n"; diff --git a/perl/Wallet/Report.pm b/perl/Wallet/Report.pm index ea8cd2f..ff25b3a 100644 --- a/perl/Wallet/Report.pm +++ b/perl/Wallet/Report.pm @@ -32,8 +32,8 @@ $VERSION = '0.04'; # exception if anything goes wrong. sub new { my ($class) = @_; - my $dbh = Wallet::Schema->connect; - my $self = { dbh => $dbh }; + my $schema = Wallet::Schema->connect; + my $self = { schema => $schema }; bless ($self, $class); return $self; } @@ -41,7 +41,13 @@ sub new { # Returns the database handle (used mostly for testing). sub dbh { my ($self) = @_; - return $self->{dbh}; + 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. @@ -59,7 +65,7 @@ sub error { # Disconnect the database handle on object destruction to avoid warnings. sub DESTROY { my ($self) = @_; - $self->{dbh}->storage->dbh->disconnect; + $self->{schema}->storage->dbh->disconnect; } ############################################################################## @@ -106,7 +112,7 @@ sub objects_owner { if (lc ($owner) eq 'null') { %search = (ob_owner => undef); } else { - my $acl = eval { Wallet::ACL->new ($owner, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($owner, $self->{schema}) }; return unless $acl; %search = (ob_owner => $acl->id); } @@ -138,8 +144,8 @@ sub objects_acl { my ($self, $search) = @_; my @objects; - my $dbh = $self->{dbh}; - my $acl = eval { Wallet::ACL->new ($search, $dbh) }; + my $schema = $self->{schema}; + my $acl = eval { Wallet::ACL->new ($search, $schema) }; return unless $acl; my @search = ({ ob_owner => $acl->id }, @@ -202,10 +208,10 @@ sub objects { # Perform the search and return on any errors. my @objects; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; eval { - my @objects_rs = $dbh->resultset('Object')->search ($search_ref, - $options_ref); + 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 ]); } @@ -228,13 +234,13 @@ sub acls_all { my ($self) = @_; my @acls; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my %search = (); my %options = (order_by => [ qw/ac_id/ ], select => [ qw/ac_id ac_name/ ]); eval { - my @acls_rs = $dbh->resultset('Acl')->search (\%search, \%options); + 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 ]); } @@ -252,7 +258,7 @@ sub acls_empty { my ($self) = @_; my @acls; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my %search = (ae_id => undef); my %options = (join => 'acl_entries', prefetch => 'acl_entries', @@ -260,7 +266,7 @@ sub acls_empty { select => [ qw/ac_id ac_name/ ]); eval { - my @acls_rs = $dbh->resultset('Acl')->search (\%search, \%options); + 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 ]); } @@ -280,7 +286,7 @@ sub acls_entry { my ($self, $type, $identifier) = @_; my @acls; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my %search = (ae_scheme => $type, ae_identifier => { like => '%'.$identifier.'%' }); my %options = (join => 'acl_entries', @@ -290,7 +296,7 @@ sub acls_entry { distinct => 1); eval { - my @acls_rs = $dbh->resultset('Acl')->search (\%search, \%options); + 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 ]); } @@ -308,7 +314,7 @@ sub acls_unused { my ($self) = @_; my @acls; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my %search = ( #'acls_owner.ob_owner' => undef, #'acls_get.ob_owner' => undef, @@ -322,7 +328,7 @@ sub acls_unused { select => [ qw/ac_id ac_name/ ]); eval { - my @acls_rs = $dbh->resultset('Acl')->search (\%search, \%options); + 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) { @@ -347,7 +353,7 @@ sub acls_unused { # on error and setting the internal error. sub acl_membership { my ($self, $id) = @_; - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -433,7 +439,7 @@ sub acls { sub owners { my ($self, $type, $name) = @_; undef $self->{error}; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my @owners; eval { @@ -446,8 +452,8 @@ sub owners { distinct => 1, ); - my @acls_rs = $dbh->resultset('AclEntry')->search (\%search, - \%options); + 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; diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm index d36b7ac..cee94f7 100644 --- a/perl/Wallet/Schema.pm +++ b/perl/Wallet/Schema.pm @@ -40,11 +40,11 @@ sub connect { 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) }; + my $schema = eval { $class->SUPER::connect ($dsn, $user, $pass, \%attrs) }; if ($@) { die "cannot connect to database: $@\n"; } - return $dbh; + return $schema; } __END__ @@ -62,7 +62,7 @@ Wallet::Schema - Database schema and connector for the wallet system =head1 SYNOPSIS use Wallet::Schema; - my $dbh = Wallet::Schema->connect; + my $schema = Wallet::Schema->connect; =head1 DESCRIPTION diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm index 402fbe0..db53f6c 100644 --- a/perl/Wallet/Server.pm +++ b/perl/Wallet/Server.pm @@ -37,13 +37,13 @@ $VERSION = '0.11'; # for various things. Throw an exception if anything goes wrong. sub new { my ($class, $user, $host) = @_; - my $dbh = Wallet::Schema->connect; - my $acl = Wallet::ACL->new ('ADMIN', $dbh); + my $schema = Wallet::Schema->connect; + my $acl = Wallet::ACL->new ('ADMIN', $schema); my $self = { - dbh => $dbh, - user => $user, - host => $host, - admin => $acl, + schema => $schema, + user => $user, + host => $host, + admin => $acl, }; bless ($self, $class); return $self; @@ -52,7 +52,13 @@ sub new { # Returns the database handle (used mostly for testing). sub dbh { my ($self) = @_; - return $self->{dbh}; + 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. @@ -71,8 +77,8 @@ sub error { sub DESTROY { my ($self) = @_; - if ($self->{dbh}) { - $self->{dbh}->storage->dbh->disconnect; + if ($self->{schema}) { + $self->{schema}->storage->dbh->disconnect; } } @@ -86,9 +92,9 @@ sub type_mapping { my ($self, $type) = @_; my $class; eval { - my $guard = $self->{dbh}->txn_scope_guard; + my $guard = $self->{schema}->txn_scope_guard; my %search = (ty_name => $type); - my $type_rec = $self->{dbh}->resultset('Type')->find (\%search); + my $type_rec = $self->{schema}->resultset('Type')->find (\%search); $class = $type_rec->ty_class; $guard->commit; }; @@ -118,7 +124,7 @@ sub create_check { my ($self, $type, $name) = @_; my $user = $self->{user}; my $host = $self->{host}; - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; unless (defined (&Wallet::Config::default_owner)) { $self->error ("$user not authorized to create ${type}:${name}"); return; @@ -128,9 +134,9 @@ sub create_check { $self->error ("$user not authorized to create ${type}:${name}"); return; } - my $acl = eval { Wallet::ACL->new ($aname, $dbh) }; + my $acl = eval { Wallet::ACL->new ($aname, $schema) }; if ($@) { - $acl = eval { Wallet::ACL->create ($aname, $dbh, $user, $host) }; + $acl = eval { Wallet::ACL->create ($aname, $schema, $user, $host) }; if ($@) { $self->error ($@); return; @@ -181,10 +187,10 @@ sub create_object { $self->error ("unknown object type $type"); return; } - my $dbh = $self->{dbh}; + my $schema = $self->{schema}; my $user = $self->{user}; my $host = $self->{host}; - my $object = eval { $class->create ($type, $name, $dbh, $user, $host) }; + my $object = eval { $class->create ($type, $name, $schema, $user, $host) }; if ($@) { $self->error ($@); return; @@ -246,7 +252,7 @@ sub retrieve { $self->error ("unknown object type $type"); return; } - my $object = eval { $class->new ($type, $name, $self->{dbh}) }; + my $object = eval { $class->new ($type, $name, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -302,7 +308,7 @@ sub acl_verify { $self->object_error ($object, $action); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -556,7 +562,7 @@ sub flag_set { # 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->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { if ($@ =~ /^ACL .* not found/) { return 0; @@ -585,8 +591,8 @@ sub acl_create { return; } } - my $dbh = $self->{dbh}; - my $acl = eval { Wallet::ACL->create ($name, $dbh, $user, $host) }; + my $schema = $self->{schema}; + my $acl = eval { Wallet::ACL->create ($name, $schema, $user, $host) }; if ($@) { $self->error ($@); return; @@ -617,7 +623,7 @@ sub acl_history { $self->acl_error ($id, 'history'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -637,7 +643,7 @@ sub acl_show { $self->acl_error ($id, 'show'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -658,7 +664,7 @@ sub acl_rename { $self->acl_error ($id, 'rename'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -689,7 +695,7 @@ sub acl_destroy { $self->acl_error ($id, 'destroy'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -713,7 +719,7 @@ sub acl_add { $self->acl_error ($id, 'add'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -733,7 +739,7 @@ sub acl_remove { $self->acl_error ($id, 'remove'); return; } - my $acl = eval { Wallet::ACL->new ($id, $self->{dbh}) }; + my $acl = eval { Wallet::ACL->new ($id, $self->{schema}) }; if ($@) { $self->error ($@); return; @@ -975,6 +981,10 @@ 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 schema() + +Returns the DBIx::Class schema object. + =item error() Returns the error of the last failing operation or undef if no operations diff --git a/perl/t/acl.t b/perl/t/acl.t index f169eb5..62eb411 100755 --- a/perl/t/acl.t +++ b/perl/t/acl.t @@ -29,30 +29,30 @@ db_setup; my $setup = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($setup->reinitialize ($setup), 1, 'Database initialization succeeded'); -my $dbh = $setup->dbh; +my $schema = $setup->schema; # Test create and new. -my $acl = eval { Wallet::ACL->create ('test', $dbh, @trace) }; +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, $dbh, @trace) }; +$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', $dbh, @trace) }; +$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', $dbh) }; +$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', $dbh) }; +$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, $dbh) }; +$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'); @@ -66,15 +66,15 @@ if ($acl->rename ('example')) { } 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', $dbh) }; +$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', $dbh) }; +$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, $dbh) }; +$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'); @@ -212,13 +212,13 @@ if ($acl->destroy (@trace)) { } else { is ($acl->error, '', 'Destroying the ACL works'); } -$acl = eval { Wallet::ACL->new ('example', $dbh) }; +$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, $dbh) }; +$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', $dbh, @trace) }; +$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'); diff --git a/perl/t/admin.t b/perl/t/admin.t index cf6a637..ff69ee9 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -63,11 +63,11 @@ $Wallet::Schema::VERSION = '0.07'; is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, ' and re-initialization succeeds'); $Wallet::Schema::VERSION = '0.08'; -my $schema = $admin->dbh; +my $schema = $admin->schema; $schema->upgrade_directory ('sql/'); my $retval = $admin->upgrade; is ($retval, 1, 'Performing an upgrade succeeds'); -my $dbh = $schema->storage->dbh; +my $dbh = $admin->dbh; my $sql = "select version from dbix_class_schema_versions order by version " ."DESC"; $version = $dbh->selectall_arrayref ($sql); diff --git a/perl/t/file.t b/perl/t/file.t index a821c4f..f902fba 100755 --- a/perl/t/file.t +++ b/perl/t/file.t @@ -31,7 +31,7 @@ db_setup; my $admin = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $dbh = $admin->dbh; +my $schema = $admin->schema; # Use this to accumulate the history traces so that we can check history. my $history = ''; @@ -39,7 +39,7 @@ 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', $dbh, @trace) + 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'); @@ -55,7 +55,7 @@ $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', $dbh, @trace) + 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'); @@ -66,7 +66,7 @@ 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', $dbh, @trace) + 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'); @@ -103,7 +103,7 @@ ok (! -f 'test-files/09/test', ' and the file is gone'); # Now try some aggressive names. $object = eval { - Wallet::Object::File->create ('file', '../foo', $dbh, @trace) + 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'); @@ -115,7 +115,7 @@ 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", $dbh, @trace) + 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'); @@ -130,7 +130,7 @@ 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', $dbh, @trace) + Wallet::Object::File->create ('file', 'test', $schema, @trace) }; ok (defined ($object), 'Recreating the object succeeds'); is ($object->store ("foo\n", @trace), undef, diff --git a/perl/t/init.t b/perl/t/init.t index 213aedf..aa028e3 100755 --- a/perl/t/init.t +++ b/perl/t/init.t @@ -24,7 +24,7 @@ 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->dbh) }; +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; @@ -38,7 +38,7 @@ is ($admin->reinitialize ('admin@EXAMPLE.ORG'), 1, 'Reinitialization succeeded'); # Now repeat the database content checks. -$acl = eval { Wallet::ACL->new ('ADMIN', $admin->dbh) }; +$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; @@ -49,7 +49,7 @@ 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->dbh) }; +$acl = eval { Wallet::ACL->new ('ADMIN', $admin->schema) }; like ($@, qr/^cannot search for ACL ADMIN: /, ' and now the database is gone'); unlink 'wallet-db'; diff --git a/perl/t/keytab.t b/perl/t/keytab.t index c263f58..561f130 100755 --- a/perl/t/keytab.t +++ b/perl/t/keytab.t @@ -147,8 +147,8 @@ db_setup; my $admin = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $schema = $admin->dbh; -my $dbh = $schema->storage->dbh; +my $schema = $admin->schema; +my $dbh = $admin->dbh; # Use this to accumulate the history traces so that we can check history. my $history = ''; diff --git a/perl/t/object.t b/perl/t/object.t index 2d60dd2..5eb6941 100755 --- a/perl/t/object.t +++ b/perl/t/object.t @@ -30,26 +30,26 @@ db_setup; my $admin = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $dbh = $admin->dbh; +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, $dbh, @trace) + 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, $dbh, @trace) + Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) }; like ($@, qr/^cannot create object \Qkeytab:$princ: /, 'Repeating fails'); -$other = eval { Wallet::Object::Base->create ('', $princ, $dbh, @trace) }; +$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', '', $dbh, @trace) }; +$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", $dbh) }; +$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, $dbh) }; +$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'); @@ -58,7 +58,7 @@ 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', $dbh); +my $acl = Wallet::ACL->new ('ADMIN', $schema); # Owner. is ($object->owner, undef, 'Owner is not set to start'); @@ -266,12 +266,12 @@ if ($object->destroy (@trace)) { } else { is ($object->error, '', 'Destroy is successful'); } -$object = eval { Wallet::Object::Base->new ('keytab', $princ, $dbh) }; +$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, $dbh, @trace) + Wallet::Object::Base->create ('keytab', $princ, $schema, @trace) }; ok (defined ($object), 'Recreating the object succeeds'); $output = <<"EOO"; diff --git a/perl/t/server.t b/perl/t/server.t index 63f2e76..8474989 100755 --- a/perl/t/server.t +++ b/perl/t/server.t @@ -36,8 +36,8 @@ is ($setup->reinitialize ($admin), 1, 'Database initialization succeeded'); $server = eval { Wallet::Server->new (@trace) }; is ($@, '', 'Reopening with new did not die'); ok ($server->isa ('Wallet::Server'), ' and returned the right class'); -my $dbh = $server->dbh; -ok (defined ($dbh), ' and returns a defined database handle'); +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'); diff --git a/perl/t/wa-keyring.t b/perl/t/wa-keyring.t index 703b7fe..3011d54 100755 --- a/perl/t/wa-keyring.t +++ b/perl/t/wa-keyring.t @@ -40,14 +40,14 @@ db_setup; my $admin = eval { Wallet::Admin->new }; is ($@, '', 'Database connection succeeded'); is ($admin->reinitialize ($user), 1, 'Database initialization succeeded'); -my $dbh = $admin->dbh; +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', $dbh, @trace) + 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'); @@ -65,7 +65,7 @@ $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', $dbh, @trace) + 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'); @@ -100,7 +100,7 @@ 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', $dbh, @trace) + 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); @@ -159,7 +159,7 @@ 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', $dbh, @trace) + 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'); -- cgit v1.2.3 From b750e56ea3f93fbc09917cacfc6b2737ef9671a7 Mon Sep 17 00:00:00 2001 From: Russ Allbery Date: Wed, 13 Feb 2013 18:24:56 -0800 Subject: Set upgrade directory in Wallet::Admin In the upgrade() wrapper in Wallet::Admin, set the DDL directory in the schema before attempting an upgrade. Change-Id: I691184fc4cf416e68f300bc78f7caffc41bf94b8 Reviewed-on: https://gerrit.stanford.edu/793 Reviewed-by: Russ Allbery Tested-by: Russ Allbery --- perl/Wallet/Admin.pm | 1 + perl/t/admin.t | 2 -- 2 files changed, 1 insertion(+), 2 deletions(-) (limited to 'perl/t/admin.t') diff --git a/perl/Wallet/Admin.pm b/perl/Wallet/Admin.pm index 9fc146c..fd184a0 100644 --- a/perl/Wallet/Admin.pm +++ b/perl/Wallet/Admin.pm @@ -195,6 +195,7 @@ sub upgrade { # Perform the actual upgrade. if ($self->{schema}->get_db_version) { + $self->{schema}->upgrade_directory ($Wallet::Config::DB_DDL_DIRECTORY); eval { $self->{schema}->upgrade; }; } if ($@) { diff --git a/perl/t/admin.t b/perl/t/admin.t index ff69ee9..a11b9b2 100755 --- a/perl/t/admin.t +++ b/perl/t/admin.t @@ -63,8 +63,6 @@ $Wallet::Schema::VERSION = '0.07'; is ($admin->reinitialize ('admin@EXAMPLE.COM'), 1, ' and re-initialization succeeds'); $Wallet::Schema::VERSION = '0.08'; -my $schema = $admin->schema; -$schema->upgrade_directory ('sql/'); my $retval = $admin->upgrade; is ($retval, 1, 'Performing an upgrade succeeds'); my $dbh = $admin->dbh; -- cgit v1.2.3