summaryrefslogtreecommitdiff
path: root/perl
diff options
context:
space:
mode:
Diffstat (limited to 'perl')
-rw-r--r--perl/Wallet/Object/Base.pm39
-rw-r--r--perl/Wallet/Schema.pm5
-rw-r--r--perl/Wallet/Server.pm53
-rwxr-xr-xperl/t/object.t32
-rwxr-xr-xperl/t/schema.t31
-rwxr-xr-xperl/t/server.t58
6 files changed, 197 insertions, 21 deletions
diff --git a/perl/Wallet/Object/Base.pm b/perl/Wallet/Object/Base.pm
index 5097729..28ec6b9 100644
--- a/perl/Wallet/Object/Base.pm
+++ b/perl/Wallet/Object/Base.pm
@@ -1,7 +1,8 @@
# Wallet::Object::Base -- Parent class for any object stored in the wallet.
#
# Written by Russ Allbery <rra@stanford.edu>
-# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University
+# Copyright 2007, 2008, 2010, 2011
+# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
@@ -17,6 +18,7 @@ use vars qw($VERSION);
use DBI;
use POSIX qw(strftime);
+use Text::Wrap qw(wrap);
use Wallet::ACL;
# This version should be increased on any code change to this module. Always
@@ -169,7 +171,7 @@ sub log_set {
}
my %fields = map { $_ => 1 }
qw(owner acl_get acl_store acl_show acl_destroy acl_flags expires
- flags type_data);
+ comment flags type_data);
unless ($fields{$field}) {
die "invalid history field $field";
}
@@ -291,6 +293,19 @@ sub attr_show {
return '';
}
+# Get or set the comment value of an object. If setting it, trace information
+# must also be provided.
+sub comment {
+ my ($self, $comment, $user, $host, $time) = @_;
+ if ($comment) {
+ return $self->_set_internal ('comment', $comment, $user, $host, $time);
+ } elsif (defined $comment) {
+ return $self->_set_internal ('comment', undef, $user, $host, $time);
+ } else {
+ return $self->_get_internal ('comment');
+ }
+}
+
# Get or set the expires value of an object. Expects an expiration time in
# seconds since epoch. If setting the expiration, trace information must also
# be provided.
@@ -565,6 +580,7 @@ sub show {
[ ob_acl_destroy => 'Destroy ACL' ],
[ ob_acl_flags => 'Flags ACL' ],
[ ob_expires => 'Expires' ],
+ [ ob_comment => 'Comment' ],
[ ob_created_by => 'Created by' ],
[ ob_created_from => 'Created from' ],
[ ob_created_on => 'Created on' ],
@@ -592,7 +608,14 @@ 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) {
+ if ($attrs[$i][0] eq 'ob_comment' && length ($data[$i]) > 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}//;
+ }
if ($attrs[$i][0] eq 'ob_created_by') {
my @flags = $self->flag_list;
if (not @flags and $self->error) {
@@ -778,6 +801,18 @@ attributes set, this method should return that metadata, formatted as key:
value pairs with the keys right-aligned in the first 15 characters,
followed by a space, a colon, and the value.
+=item comment([COMMENT, PRINCIPAL, HOSTNAME [, DATETIME]])
+
+Sets or retrieves the comment associated with an object. If no arguments
+are given, returns the current comment or undef if no comment is set. If
+arguments are given, change the comment to COMMENT and return true on
+success and false on failure. Pass in the empty string for COMMENT to
+clear the comment.
+
+The other arguments are used for logging and history and should indicate
+the user and host from which the change is made and the time of the
+change.
+
=item destroy(PRINCIPAL, HOSTNAME [, DATETIME])
Destroys the object by removing all record of it from the database. The
diff --git a/perl/Wallet/Schema.pm b/perl/Wallet/Schema.pm
index 0f6c53f..7400776 100644
--- a/perl/Wallet/Schema.pm
+++ b/perl/Wallet/Schema.pm
@@ -145,7 +145,9 @@ sub upgrade {
return;
} elsif ($version == 0) {
@sql = ('create table metadata (md_version integer)',
- 'insert into metadata (md_version) values (1)');
+ 'insert into metadata (md_version) values (1)',
+ 'alter table objects add ob_comment varchar(255) default null'
+ );
} else {
die "unknown database version $version\n";
}
@@ -367,6 +369,7 @@ table:
ob_downloaded_by varchar(255) default null,
ob_downloaded_from varchar(255) default null,
ob_downloaded_on datetime default null,
+ ob_comment varchar(255) default null,
primary key (ob_name, ob_type));
create index ob_owner on objects (ob_owner);
create index ob_expires on objects (ob_expires);
diff --git a/perl/Wallet/Server.pm b/perl/Wallet/Server.pm
index 185bf23..7b3fb8f 100644
--- a/perl/Wallet/Server.pm
+++ b/perl/Wallet/Server.pm
@@ -1,7 +1,8 @@
# Wallet::Server -- Wallet system server implementation.
#
# Written by Russ Allbery <rra@stanford.edu>
-# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University
+# Copyright 2007, 2008, 2010, 2011
+# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
@@ -23,7 +24,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.09';
+$VERSION = '0.10';
##############################################################################
# Utility methods
@@ -276,7 +277,9 @@ sub object_error {
# set the ACL accordingly.
sub acl_check {
my ($self, $object, $action) = @_;
- unless ($action =~ /^(get|store|show|destroy|flags|setattr|getattr)\z/) {
+ my %actions = map { $_ => 1 }
+ qw(get store show destroy flags setattr getattr comment);
+ unless ($actions{$action}) {
$self->error ("unknown action $action");
return;
}
@@ -288,10 +291,10 @@ sub acl_check {
$id = $object->acl ('show');
} elsif ($action eq 'setattr') {
$id = $object->acl ('store');
- } else {
+ } elsif ($action ne 'comment') {
$id = $object->acl ($action);
}
- if (! defined ($id) and $action =~ /^(get|(get|set)attr|store|show)\z/) {
+ if (! defined ($id) and $action ne 'flags' and $action ne 'destroy') {
$id = $object->owner;
}
unless (defined $id) {
@@ -365,6 +368,26 @@ sub attr {
}
}
+# Retrieves or sets the comment of an object.
+sub comment {
+ my ($self, $type, $name, $comment) = @_;
+ undef $self->{error};
+ my $object = $self->retrieve ($type, $name);
+ return unless defined $object;
+ my $result;
+ if (defined $comment) {
+ return unless $self->acl_check ($object, 'comment');
+ $result = $object->comment ($comment, $self->{user}, $self->{host});
+ } else {
+ return unless $self->acl_check ($object, 'show');
+ $result = $object->comment;
+ }
+ if (not defined ($result) and $object->error) {
+ $self->error ($object->error);
+ }
+ return $result;
+}
+
# Retrieves or sets the expiration of an object.
sub expires {
my ($self, $type, $name, $expires) = @_;
@@ -895,6 +918,20 @@ Check whether an object of type TYPE and name NAME exists. Returns 1 if
it does, 0 if it doesn't, and undef if some error occurred while checking
for the existence of the object.
+=item comment(TYPE, NAME, [COMMENT])
+
+Gets or sets the comment for the object identified by TYPE and NAME. If
+COMMENT is not given, returns the current comment or undef if no comment
+is set or on an error. To distinguish between an expiration that isn't
+set and a failure to retrieve the expiration, the caller should call
+error() after an undef return. If error() also returns undef, no comment
+was set; otherwise, error() will return the error message.
+
+If COMMENT is given, sets the comment to COMMENT. Pass in the empty
+string for COMMENT to clear the comment. To set a comment, the current
+user must be the object owner or be on the ADMIN ACL. Returns true for
+success and false for failure.
+
=item create(TYPE, NAME)
Creates a new object of type TYPE and name NAME. TYPE must be a
@@ -933,12 +970,12 @@ Gets or sets the expiration for the object identified by TYPE and NAME.
If EXPIRES is not given, returns the current expiration or undef if no
expiration is set or on an error. To distinguish between an expiration
that isn't set and a failure to retrieve the expiration, the caller should
-call error() after an undef return. If error() also returns undef, that
-ACL wasn't set; otherwise, error() will return the error message.
+call error() after an undef return. If error() also returns undef, the
+expiration wasn't set; otherwise, error() will return the error message.
If EXPIRES is given, sets the expiration to EXPIRES. EXPIRES must be in
the format C<YYYY-MM-DD +HH:MM:SS>, although the time portion may be
-omitted. Pass in the empty +string for EXPIRES to clear the expiration
+omitted. Pass in the empty string for EXPIRES to clear the expiration
date. To set an expiration, the current user must be authorized by the
ADMIN ACL. Returns true for success and false for failure.
diff --git a/perl/t/object.t b/perl/t/object.t
index 3949786..2d60dd2 100755
--- a/perl/t/object.t
+++ b/perl/t/object.t
@@ -3,12 +3,13 @@
# Tests for the basic object implementation.
#
# Written by Russ Allbery <rra@stanford.edu>
-# Copyright 2007, 2008 Board of Trustees, Leland Stanford Jr. University
+# Copyright 2007, 2008, 2011
+# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
use POSIX qw(strftime);
-use Test::More tests => 131;
+use Test::More tests => 137;
use Wallet::ACL;
use Wallet::Admin;
@@ -99,6 +100,23 @@ if ($object->expires ('', @trace)) {
is ($object->expires, undef, ' at which point it is cleared');
is ($object->expires ($now, @trace), 1, ' and setting it again works');
+# Comment.
+is ($object->comment, undef, 'Comment is not set to start');
+if ($object->comment ('this is a comment', @trace)) {
+ ok (1, ' and setting it works');
+} else {
+ is ($object->error, '', ' and setting it works');
+}
+is ($object->comment, 'this is a comment', ' at which point it matches');
+if ($object->comment ('', @trace)) {
+ ok (1, ' and clearing it works');
+} else {
+ is ($object->error, '', ' and clearing it works');
+}
+is ($object->comment, undef, ' at which point it is cleared');
+is ($object->comment (join (' ', ('this is a comment') x 5), @trace), 1,
+ ' and setting it again works');
+
# ACLs.
for my $type (qw/get store show destroy flags/) {
is ($object->acl ($type), undef, "ACL $type is not set to start");
@@ -203,6 +221,8 @@ my $output = <<"EOO";
Destroy ACL: ADMIN
Flags ACL: ADMIN
Expires: $now
+ Comment: this is a comment this is a comment this is a comment this is
+ a comment this is a comment
Flags: unchanging
Created by: $user
Created from: $host
@@ -223,6 +243,8 @@ $output = <<"EOO";
Destroy ACL: ADMIN
Flags ACL: ADMIN
Expires: $now
+ Comment: this is a comment this is a comment this is a comment this is
+ a comment this is a comment
Flags: locked unchanging
Created by: $user
Created from: $host
@@ -267,6 +289,12 @@ $date unset expires (was $now)
by $user from $host
$date set expires to $now
by $user from $host
+$date set comment to this is a comment
+ by $user from $host
+$date unset comment (was this is a comment)
+ by $user from $host
+$date set comment to this is a comment this is a comment this is a comment this is a comment this is a comment
+ by $user from $host
$date set acl_get to ADMIN (1)
by $user from $host
$date unset acl_get (was ADMIN (1))
diff --git a/perl/t/schema.t b/perl/t/schema.t
index c66ad59..ce8a62a 100755
--- a/perl/t/schema.t
+++ b/perl/t/schema.t
@@ -8,11 +8,12 @@
#
# See LICENSE for licensing terms.
-use Test::More tests => 15;
+use Test::More tests => 16;
-use DBI;
-use Wallet::Config;
-use Wallet::Schema;
+use DBI ();
+use POSIX qw(strftime);
+use Wallet::Config ();
+use Wallet::Schema ();
use lib 't/lib';
use Util;
@@ -45,14 +46,34 @@ 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.
+# 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) };
diff --git a/perl/t/server.t b/perl/t/server.t
index ed92d6e..ad16151 100755
--- a/perl/t/server.t
+++ b/perl/t/server.t
@@ -3,11 +3,12 @@
# Tests for the wallet server API.
#
# Written by Russ Allbery <rra@stanford.edu>
-# Copyright 2007, 2008, 2010 Board of Trustees, Leland Stanford Jr. University
+# Copyright 2007, 2008, 2010, 2011
+# The Board of Trustees of the Leland Stanford Junior University
#
# See LICENSE for licensing terms.
-use Test::More tests => 355;
+use Test::More tests => 377;
use POSIX qw(strftime);
use Wallet::Admin;
@@ -199,6 +200,24 @@ is ($server->check ('base', 'service/test'), 0,
is ($server->destroy ('base', 'service/test'), undef, ' but not twice');
is ($server->error, 'cannot find base:service/test', ' with the right error');
+# Test manipulating comments.
+is ($server->comment ('base', 'service/test'), undef,
+ 'Retrieving comment on an unknown object fails');
+is ($server->error, 'cannot find base:service/test', ' with the right error');
+is ($server->comment ('base', 'service/test', 'this is a comment'), undef,
+ ' and setting it also fails');
+is ($server->error, 'cannot find base:service/test', ' with the right error');
+is ($server->comment ('base', 'service/admin'), undef,
+ 'Retrieving comment for the right object returns undef');
+is ($server->error, undef, ' but there is no error');
+is ($server->comment ('base', 'service/admin', 'this is a comment'), 1,
+ ' and we can set it');
+is ($server->comment ('base', 'service/admin'), 'this is a comment',
+ ' and get the value back');
+is ($server->comment ('base', 'service/admin', ''), 1, ' and clear it');
+is ($server->comment ('base', 'service/admin'), undef, ' and now it is gone');
+is ($server->error, undef, ' and still no error');
+
# Test manipulating expires.
my $now = strftime ('%Y-%m-%d %T', localtime time);
is ($server->expires ('base', 'service/test'), undef,
@@ -393,6 +412,10 @@ is ($server->flag_clear ('base', 'service/admin', 'unchanging'), 1,
$history = <<"EOO";
DATE create
by $admin from $host
+DATE set comment to this is a comment
+ by $admin from $host
+DATE unset comment (was this is a comment)
+ by $admin from $host
DATE set expires to $now
by $admin from $host
DATE unset expires (was $now)
@@ -510,12 +533,15 @@ is ($server->store ('base', 'service/user1', 'stuff'), undef,
is ($server->error,
"cannot store base:service/user1: object type is immutable",
' and the method is called');
+is ($server->comment ('base', 'service/user1', 'this is a comment'), 1,
+ ' and set a comment');
$show = $server->show ('base', 'service/user1');
$show =~ s/(Created on:) [\d-]+ [\d:]+$/$1 0/m;
$expected = <<"EOO";
Type: base
Name: service/user1
Owner: user1
+ Comment: this is a comment
Created by: $admin
Created from: $host
Created on: 0
@@ -529,6 +555,8 @@ DATE create
by $admin from $host
DATE set owner to user1 (2)
by $admin from $host
+DATE set comment to this is a comment
+ by $user1 from $host
EOO
$seen = $server->history ('base', 'service/user1');
$seen =~ s/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d/DATE/gm;
@@ -566,6 +594,11 @@ is ($server->attr ('base', 'service/user2', 'foo', ''), undef,
is ($server->error,
"$user1 not authorized to set attributes for base:service/user2",
' with the right error');
+is ($server->comment ('base', 'service/user2', 'this is a comment'), undef,
+ ' and set comment');
+is ($server->error,
+ "$user1 not authorized to set comment for base:service/user2",
+ ' with the right error');
# And only some things on an object we own with some ACLs.
$result = eval { $server->get ('base', 'service/both') };
@@ -702,8 +735,27 @@ is ($server->history ('base', 'service/user1'), undef,
' or see history for it');
is ($server->error, "$user2 not authorized to show base:service/user1",
' with the right error');
+is ($server->comment ('base', 'service/user1', 'this is a comment'), undef,
+ ' or set a comment for it');
+is ($server->error,
+ "$user2 not authorized to set comment for base:service/user1",
+ ' with the right error');
-# And only some things on an object we own with some ACLs.
+# Test that setting a comment is controlled by the owner but retrieving it is
+# controlled by the show ACL.
+$result = eval { $server->get ('base', 'service/both') };
+is ($result, undef, 'We can get an object we jointly own');
+is ($@, "Do not instantiate Wallet::Object::Base directly\n",
+ ' and the method is called');
+is ($server->comment ('base', 'service/both', 'this is a comment'), 1,
+ ' and can set a comment on it');
+is ($server->error, undef, ' with no error');
+is ($server->comment ('base', 'service/both'), undef,
+ ' but cannot see the comment on it');
+is ($server->error, "$user2 not authorized to show base:service/both",
+ ' with the right error');
+
+# And can only do some things on an object we own with some ACLs.
$result = eval { $server->get ('base', 'service/both') };
is ($result, undef, 'We can get an object we jointly own');
is ($@, "Do not instantiate Wallet::Object::Base directly\n",
generated by cgit v1.2.3 (git 2.39.1) at 2025-02-06 04:56:34 +0000