From ac4f337ad7d7e70e5d5d0d3f7eb51025c21a5fec Mon Sep 17 00:00:00 2001
From: Ian Jackson <ijackson@chiark.greenend.org.uk>
Date: Sat, 25 Jul 2020 17:04:31 +0100
Subject: [PATCH] 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>
---
 nailing-cargo | 84 ++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 80 insertions(+), 4 deletions(-)

diff --git a/nailing-cargo b/nailing-cargo
index dae805c..e9436f0 100755
--- 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 () {
-- 
2.30.2