From 639b985d2ad2f9f80b8f4bfe30033c82b1b37147 Mon Sep 17 00:00:00 2001 From: iainrb Date: Mon, 20 Jul 2015 12:44:53 +0100 Subject: [PATCH] Changes for release 1.7.0 --- lib/WTSI/NPG/iRODS.pm | 21 ++++++++-- lib/WTSI/NPG/iRODS/DataObject.pm | 32 ++++++++++----- t/lib/WTSI/NPG/iRODS/DataObjectTest.pm | 56 +++++++++++++++++++++++++- t/lib/WTSI/NPG/iRODSTest.pm | 20 +++++++-- 4 files changed, 112 insertions(+), 17 deletions(-) diff --git a/lib/WTSI/NPG/iRODS.pm b/lib/WTSI/NPG/iRODS.pm index 38c23217..379ef97d 100644 --- a/lib/WTSI/NPG/iRODS.pm +++ b/lib/WTSI/NPG/iRODS.pm @@ -988,10 +988,14 @@ sub make_collection_avu_history { Arg [1] : iRODS collection path. Arg [2] : ArrayRef attribute value tuples - Example : $irods->find_collections_by_meta('/my/path/foo', + Example : $irods->find_collections_by_meta('/my/path/foo/', ['id' => 'ABCD1234']) Description: Find collections by their metadata, restricted to a parent - collection. Return a list of collections. + collection. The collection path argument is not a simple + string prefix, it is a collection. i.e. '/my/path/foo' is + equivalent to '/my/path/foo/' and will not return results + in collection '/my/path/foo_1'. + Return a list of collections, sorted by their path. Returntype : Array =cut @@ -1005,6 +1009,9 @@ sub find_collections_by_meta { $root = File::Spec->canonpath($root); $root = $self->_ensure_absolute_path($root); + # Ensure a single trailing slash for collection boundary matching. + $root =~ s/\/*$/\//msx; + my $zone = $self->find_zone_name($root); # baton >= 0.10.0 uses paths as per-query zone hints my $zone_path = "/$zone"; @@ -1583,10 +1590,13 @@ sub make_object_avu_history { Arg [1] : iRODS collection path. Arg [2] : ArrayRefs of attribute value tuples. - Example : $irods->find_objects_by_meta('/my/path/foo', + Example : $irods->find_objects_by_meta('/my/path/foo/', ['id' => 'ABCD1234']) Description: Find objects by their metadata, restricted to a parent - collection. + collection. The collection path argument is not a simple + string prefix, it is a collection. i.e. '/my/path/foo' is + equivalent to '/my/path/foo/' and will not return results + in collection '/my/path/foo_1'. Return a list of objects, sorted by their data object name component. Returntype : Array @@ -1602,6 +1612,9 @@ sub find_objects_by_meta { $root = File::Spec->canonpath($root); $root = $self->_ensure_absolute_path($root); + # Ensure a single trailing slash for collection boundary matching. + $root =~ s/\/*$/\//msx; + my $zone = $self->find_zone_name($root); # baton >= 0.10.0 uses paths as per-query zone hints my $zone_path = "/$zone"; diff --git a/lib/WTSI/NPG/iRODS/DataObject.pm b/lib/WTSI/NPG/iRODS/DataObject.pm index 56b6f6e8..1fb6dc78 100644 --- a/lib/WTSI/NPG/iRODS/DataObject.pm +++ b/lib/WTSI/NPG/iRODS/DataObject.pm @@ -279,7 +279,7 @@ sub set_permissions { Example : $obj->get_object_groups('read') Description: Return a list of the data access groups in the object's ACL. - If a permission leve argument is supplied, only groups with + If a permission level argument is supplied, only groups with that level of access will be returned. Returntype : Array @@ -292,7 +292,12 @@ sub get_groups { } sub update_group_permissions { - my ($self) = @_; + my ($self, $strict_groups) = @_; + + $strict_groups = $strict_groups ? 1 : 0; + # If strict_groups is true, we only work with groups we can see with + # igroupadmin. Across zones we usually have to work non-strict + # because the stock igroupadmin can't see them. # Record the current group permissions my @groups_permissions = $self->get_groups('read'); @@ -321,16 +326,17 @@ sub update_group_permissions { my @all_groups = $self->irods->list_groups; foreach my $group (@to_remove) { - if (any { $group eq $_ } @all_groups) { + if (not $strict_groups or any { $group eq $_ } @all_groups) { try { $self->set_permissions('null', $group); } catch { $num_errors++; $self->error("Failed to remove permissions for group '$group' from '", - $self->str, q{':}, $_); + $self->str, q{': }, $_); }; } else { + $num_errors++; $self->error("Attempted to remove permissions for non-existent group ", "'$group' on '", $self->str, q{'}); } @@ -339,25 +345,33 @@ sub update_group_permissions { $self->debug("Groups to add: [", join(', ', @to_add), "]"); foreach my $group (@to_add) { - if (any { $group eq $_ } @all_groups) { + if (not $strict_groups or any { $group eq $_ } @all_groups) { try { $self->set_permissions('read', $group); } catch { $num_errors++; $self->error("Failed to add read permissions for group '$group' to '", - $self->str, q{':}, $_); + $self->str, q{': }, $_); }; } else { + $num_errors++; $self->error("Attempted to add read permissions for non-existent group ", "'$group' on '", $self->str, q{'}); } } if ($num_errors > 0) { - $self->logconfess("Failed to update cleanly group permissions on '", - $self->str, "'; $num_errors errors were recorded. ", - "See logs for details."); + my $msg = "Failed to update cleanly group permissions on '" . $self->str . + "'; $num_errors errors were recorded. See logs for details ". + "(strict groups = $strict_groups)."; + + if ($strict_groups) { + $self->logconfess($msg); + } + else { + $self->error($msg); + } } return $self; diff --git a/t/lib/WTSI/NPG/iRODS/DataObjectTest.pm b/t/lib/WTSI/NPG/iRODS/DataObjectTest.pm index 1ca0ee68..b5dfe258 100644 --- a/t/lib/WTSI/NPG/iRODS/DataObjectTest.pm +++ b/t/lib/WTSI/NPG/iRODS/DataObjectTest.pm @@ -8,7 +8,7 @@ use List::AllUtils qw(all any none); use Log::Log4perl; use base qw(Test::Class); -use Test::More tests => 77; +use Test::More tests => 90; use Test::Exception; Log::Log4perl::init('./etc/log4perl_tests.conf'); @@ -511,4 +511,58 @@ sub get_groups : Test(6) { or diag explain \@found_own; } +sub update_group_permissions : Test(13) { + my $irods = WTSI::NPG::iRODS->new(strict_baton_version => 0); + my $obj_path = "$irods_tmp_coll/irods_path_test/test_dir/test_file.txt"; + my $obj = WTSI::NPG::iRODS::DataObject->new($irods, $obj_path); + + SKIP: { + if (not $irods->group_exists('ss_0')) { + skip "Skipping test requiring the test group ss_0", 13; + } + + # Begin + my $r0 = none { exists $_->{owner} && $_->{owner} eq 'ss_0' && + exists $_->{level} && $_->{level} eq 'read' } + $obj->get_permissions; + ok($r0, 'No ss_0 read access'); + + # Add a study 0 AVU and use it to update (add) permissions + ok($obj->add_avu('study_id', '0')); + ok($obj->update_group_permissions); + + my $r1 = any { exists $_->{owner} && $_->{owner} eq 'ss_0' && + exists $_->{level} && $_->{level} eq 'read' } + $obj->get_permissions; + ok($r1, 'Added ss_0 read access'); + + # Remove the study 0 AVU and use it to update (remove) permissions + ok($obj->remove_avu('study_id', '0')); + ok($obj->update_group_permissions); + + my $r2 = none { exists $_->{owner} && $_->{owner} eq 'ss_0' && + exists $_->{level} && $_->{level} eq 'read' } + $obj->get_permissions; + ok($r2, 'Removed ss_0 read access'); + + # Add a study 0 AVU and use it to update (add) permissions + # in the presence of anAVU that will infer a non-existent group + ok($obj->add_avu('study_id', '0')); + ok($obj->add_avu('study_id', 'no_such_group')); + ok($obj->update_group_permissions); + + my $r3 = any { exists $_->{owner} && $_->{owner} eq 'ss_0' && + exists $_->{level} && $_->{level} eq 'read' } + $obj->get_permissions; + ok($r3, 'Restored ss_0 read access'); + + # The bogus study AVU should trigger an exception in strict groups + # mode + dies_ok { + my $strict_groups = 1; + ok($obj->update_group_permissions($strict_groups)); + } 'An unknown iRODS group causes failure'; + } +} + 1; diff --git a/t/lib/WTSI/NPG/iRODSTest.pm b/t/lib/WTSI/NPG/iRODSTest.pm index fac58caf..d4dbac30 100644 --- a/t/lib/WTSI/NPG/iRODSTest.pm +++ b/t/lib/WTSI/NPG/iRODSTest.pm @@ -14,7 +14,7 @@ use Try::Tiny; use Unicode::Collate; use base qw(Test::Class); -use Test::More tests => 200; +use Test::More tests => 202; use Test::Exception; Log::Log4perl::init('./etc/log4perl_tests.conf'); @@ -608,7 +608,7 @@ sub make_collection_avu_history : Test(4) { } } -sub find_collections_by_meta : Test(7) { +sub find_collections_by_meta : Test(8) { my $irods = WTSI::NPG::iRODS->new(strict_baton_version => 0); my $expected_coll = "$irods_tmp_coll/irods"; @@ -625,6 +625,13 @@ sub find_collections_by_meta : Test(7) { ['a', 'x'], ['a', 'y'])], [$expected_coll]); + # All but the last character + my $part_collection_root = substr $irods_tmp_coll, 0, -1; + + is_deeply([$irods->find_collections_by_meta($part_collection_root, + ['a', 'x'])], [], + 'Collection query root is not a simple path string prefix'); + my $new_coll = "$irods_tmp_coll/irods/new"; ok($irods->add_collection($new_coll)); ok($irods->add_collection_avu($new_coll, 'a', 'x99')); @@ -906,7 +913,7 @@ sub make_object_avu_history : Test(4) { } } -sub find_objects_by_meta : Test(6) { +sub find_objects_by_meta : Test(7) { my $irods = WTSI::NPG::iRODS->new(strict_baton_version => 0); my $lorem_object = "$irods_tmp_coll/irods/lorem.txt"; @@ -921,6 +928,13 @@ sub find_objects_by_meta : Test(6) { ['a', 'x'], ['a', 'y'])], [$lorem_object]); + # All but the last character + my $part_collection_root = substr $irods_tmp_coll, 0, -1; + + is_deeply([$irods->find_objects_by_meta($part_collection_root, + ['a', 'x'])], [], + 'Object query root is not a simple path string prefix'); + my $object = "$irods_tmp_coll/irods/test.txt"; ok($irods->add_object_avu($object, 'a', 'x99'));