nailing-cargo: Chase down workspace members

When workspaces are in use, we need to look at their members.
This is quite a palaver.

We want to process them after all the stuff in the config, so we must
queue them up when we see them.  And we want to chase recursively,
perhaps.  (We certainly will do when we extend this to path
dependencies.)  So rather than an actual recursive function, we have a
queue.

We use realpath(1) to check that the paths we find don't
escape.  (Strictly, this code might [l]stat or readdir various
pathnames controlled by hostile cargo metadata, but that's all.
Basically, I'm assuming it's OK to pass a hostile path to realpath(1)
and then check what realpath(1) said.)

Now we record a manifest as relevant if it has a [workspace], even if
it didn't have a package.

Signed-off-by: Ian Jackson <ijackson@chiark.greenend.org.uk>

diff --git a/nailing-cargo b/nailing-cargo
index dae805cbd19f41d1a2b938c538c84dd861fe82b2..e9436f0821852b0bb042ff55f1aa3f4bd460d964 100755 (executable)
--- a/nailing-cargo
+++ b/nailing-cargo
@@ -7,6 +7,7 @@ our $self;
 use strict;
 use POSIX;
 use Types::Serialiser;
+use File::Glob qw(bsd_glob GLOB_ERR GLOB_BRACE GLOB_NOMAGIC);
 
 our %archmap = (
     RPI => 'arm-unknown-linux-gnueabihf',
@@ -289,6 +290,8 @@ sub consider_oot () {
 
 our %manifests;
 our %packagemap;
+our %workspaces;
+our @queued_paths;
 
 sub read_manifest ($$$) {
   my ($subdir, $org_subdir, $why) = @_;
@@ -302,18 +305,84 @@ sub read_manifest ($$$) {
   }
   foreach my $try ("$manifest.unnailed", "$manifest") {
     my $toml = toml_or_enoent($try, "manifest, in $why") // next;
+    my $ws = $toml->{workspace};
+    if ($ws) {
+      queue_workspace_members($subdir, $org_subdir, $ws, "$subdir, $why");
+    }
     my $p = $toml->{package}{name};
-    if (!defined $p) {
+    if (!defined $p and !defined $ws) {
       print STDERR
  "$self: warning: $subdir, $why: missing package.name in $try, ignoring\n";
       next;
     }
-    $manifests{$manifest} = $toml;
-    return ($p, undef);
+    $manifests{$manifest} = $toml if $p;
+    return ($p, $ws);
   }
   return undef;
 }
 
+sub queue_workspace_members ($$) {
+  my ($subdir, $org_subdir, $ws_toml, $what) = @_;
+  # We need to (more or less) reimplement the cargo workspace
+  # membership algorithm (see the "workspaces" section of the cargo
+  # reference).  How tiresome.
+  #
+  # It's not quite the same for us because we aren't interested in
+  # whether cargo thinks things are "in the workspace".  But we do
+  # need to do the automatic discover.
+
+  my @include = @{ $ws_toml->{members} // [ ] };
+  my $exclude = $ws_toml->{exclude} // [ ];
+
+  my @exclude = map {
+    s/[^*?0-9a-zA-Z_]/\\$&/g;
+    s/\?/./g;
+    s/\*/.*/g;
+  } @$exclude;
+
+  foreach my $spec (@include) {
+    if ($spec =~ m{^/}) {
+      print STDERR
+       "$self: warning: absolute workspace member $spec in $what (not nailing, but cargo will probably use it)\n";
+      next;
+    }
+    my $spec_glob = "../$subdir/$spec";
+    my $globflags = GLOB_ERR|GLOB_BRACE|GLOB_NOMAGIC;
+    foreach my $globent (bsd_glob($spec_glob, $globflags)) {
+      next if grep { $globent =~ m{^$_$} } @exclude;
+      queue_referenced_path($globent, $org_subdir,
+                           "member of workspace $what");
+    }
+  }
+}
+
+sub queue_referenced_path ($$$) {
+  my ($spec_path, $org_subdir, $why) = @_;
+  open REALPATH, "-|",
+    qw(realpath), "--relative-to=../$org_subdir", "--", $spec_path
+    or die "$self: fork/pipe/exec for realpath(1)\n";
+  my $rel_path = do { local $/=undef; <REALPATH>; };
+  $?=0; $!=0;
+  my $r = close(REALPATH);
+  die "$self: reap realpath: $!\n" if $!;
+  if (!chomp($rel_path) or $?) {
+    print STDERR
+ "$self: warning: failed to determine realpath for $spec_path in $org_subdir (exit code $?)\n";
+    return;
+  }
+  if ($rel_path =~ m{^\.\./} or $rel_path eq '..') {
+    print STDERR
+      "$self: warning: $spec_path ($why) points outside $org_subdir, not following so not nailing (although cargo probably will follow it)\n";
+    return;
+  }
+
+  my $q_subdir = "$org_subdir/$rel_path";
+  print STDERR "$self: making a note to look at $q_subdir, $why)\n"
+    if $verbose >= 4;
+
+  push @queued_paths, [ "$q_subdir", $org_subdir, $why ];
+}
+
 sub readorigs () {
   foreach my $p (keys %{ $nail->{packages} }) {
     my $v = $nail->{packages}{$p};
@@ -331,11 +400,18 @@ sub readorigs () {
     my ($gotpackage,$ws) = read_manifest($subdir, $subdir, "from [subdirs]");
     if (!defined $gotpackage) {
       print STDERR
- "$self: warning: ignoring subdir $subdir which has no (suitable) Cargo.toml\n";
+ "$self: warning: ignoring subdir $subdir which has no (suitable) Cargo.toml\n"
+        unless $ws;
       next;
     }
     $packagemap{$gotpackage} //= $subdir;
   }
+  while (my ($subdir, $org_subdir, $why) = @{ shift @queued_paths or [] }) {
+    next if $manifests{"../$subdir/Cargo.toml"};
+    my ($gotpackage, $ws) = read_manifest($subdir, $org_subdir, $why);
+    next unless $gotpackage;
+    $packagemap{$gotpackage} //= $subdir;
+  }
 }
 
 sub calculate () {