Changes for release 1.7.0

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";

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;

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;

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'));