nailing-cargo

   1 #!/usr/bin/perl -w
   2
   3 #    nailing-cargo: wrapper to use unpublished local crates
   4 #
   5 #    Copyright (C) 2019-2020 Ian Jackson
   6 #
   7 #    This program is free software: you can redistribute it and/or modify
   8 #    it under the terms of the GNU Affero General Public License as
   9 #    published by the Free Software Foundation, either version 3 of the
  10 #    License, or (at your option) any later version.
  11 #
  12 #    This program is distributed in the hope that it will be useful,
  13 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 #    GNU Affero General Public License for more details.
  16 #
  17 #    You should have received a copy of the GNU Affero General Public License
  18 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 # example usages:
  21 #   ../nailing-cargo/nailing-caretwgo make
  22 #   ../nailing-cargo/nailing-cargo cargo build
  23 #   CARGO='../nailing-cargo/nailing-cargo cargo' make
  24
  25 # Why do we need this ?
  26 #
  27 #  https://github.com/rust-lang/cargo/issues/6713
  28 #  https://stackoverflow.com/questions/33025887/how-to-use-a-local-unpublished-crate
  29 #  https://github.com/rust-lang/cargo/issues/1481
  30
  31 # Needs libtoml-perl
  32
  33 #: Cargo.nail:
  34 #
  35 #    [packages]
  36 #    package = subdir
  37 #    package = { subdir = ... }
  38 #
  39 #    [subdirs]
  40 #    subdir
  41
  42 our $self;
  43
  44 use strict;
  45 use POSIX;
  46
  47 BEGIN {
  48   $self = $0;  $self =~ s{^.*/(?=.)}{};
  49   my $deref = $0;
  50   while ($deref =~ m{^/}) {
  51     my $link = readlink $deref;
  52     if (!defined $link) {
  53       $! == EINVAL
  54         or die "$self: checking our script location $deref: $!\n";
  55       $deref =~ s{/[^/]+$}{}
  56         or die "$self: unexpected script path: $deref\n";
  57       unshift @INC, $deref."/TOML-Tiny/lib";
  58       last;
  59     }
  60     last if $link !~ m{^/};
  61     $deref = $link;
  62   }
  63 }
  64
  65 use Fcntl qw(LOCK_EX);
  66 use File::Compare;
  67 use TOML::Tiny::Faithful;
  68
  69 our $worksphere = getcwd() // die "$self: getcwd failed: $!\n";
  70 $worksphere =~ s{/[^/]+$}{} or die "$self: cwd \`$worksphere' unsupported!\n";
  71 our $lockfile = "../.nailing-cargo.lock";
  72
  73 our @configs;
  74 our $verbose=1;
  75 our ($noact,$dump);
  76
  77 sub read_or_enoent ($) {
  78   my ($fn) = @_;
  79   if (!open R, '<', $fn) {
  80     return undef if $!==ENOENT;
  81     die "$self: open $fn: $!\n";
  82   }
  83   local ($/) = undef;
  84   my ($r) = <R> // die "$self: read $fn: $!\n";
  85   $r;
  86 }
  87
  88 sub toml_or_enoent ($$) {
  89   my ($f,$what) = @_;
  90   my $toml = read_or_enoent($f) // return;
  91   my ($v,$e) = from_toml($toml);
  92   die "$self: parse TOML: $what: $f: $e\n" unless defined $v;
  93   die "$e ?" if length $e;
  94   $v;
  95 }
  96
  97 sub load1config ($) {
  98   my ($f) = @_;
  99   my $toml = toml_or_enoent($f, "config file");
 100   push @configs, $toml if defined $toml;
 101 }
 102
 103 sub loadconfigs () {
 104   my $cfgleaf = ".nailing-cargo-cfg.toml";
 105   load1config("/etc/nailing-cargo/cfg.toml");
 106   load1config("$worksphere/$cfgleaf");
 107   load1config("$ENV{HOME}/$cfgleaf") if defined $ENV{HOME};
 108 }
 109
 110 sub getcfg ($$) {
 111   my ($k, $def) = @_;
 112   foreach my $cfg (@configs) {
 113     my $v = $cfg->{$k};
 114     return $v if defined $v;
 115   }
 116   return $def;
 117 }
 118
 119 sub unlink_or_enoent ($) { unlink $_[0] or $!==ENOENT; }
 120
 121 sub takelock () {
 122   for (;;) {
 123     open LOCK, ">", $lockfile or die "$self: open/create $lockfile: $!\n";
 124     flock LOCK, LOCK_EX or die "$self: lock $lockfile: $!\n";
 125     my @fstat = stat LOCK or die "$self: fstat: $!\n";
 126     my @stat  = stat $lockfile;
 127     if (!@stat) {
 128       next if $! == ENOENT;
 129       die "$self: stat $lockfile: $!\n";
 130     }
 131     last if "@fstat[0..5]" eq "@stat[0..5]";
 132   }
 133 }
 134 sub unlock () {
 135   unlink $lockfile or die "$self: removing lockfile: $!\n";
 136 }
 137
 138 our $nail;
 139
 140 sub readnail () {
 141   my $nailfile = "../Cargo.nail";
 142   open N, '<', $nailfile or die "$self: open $nailfile: $!\n";
 143   local ($/) = undef;
 144   my $toml = <N> // die "$self: read $nailfile: $!";
 145   my $transformed;
 146   if ($toml !~ m{^\s*\[/}m &&
 147       $toml !~ m{^[^\n\#]*\=}m &&
 148       # old non-toml syntax
 149       $toml =~ s{^[ \t]*([-_0-9a-z]+)[ \t]+(\S+)[ \t]*$}{$1 = \"$2\"}mig) {
 150     $toml =~ s{^}{[packages\]\n};
 151     my @sd;
 152     $toml =~ s{^[ \t]*\-[ \t]*\=[ \t]*(\"[-_0-9a-z]+\"\n?)$}{
 153       push @sd, $1; '';
 154     }mige;
 155     $toml = "subdirs = [\n".(join '', map { "$_\n" } @sd)."]\n".$toml;
 156     $transformed = 1;
 157   }
 158   my $e;
 159   ($nail,$e) = from_toml($toml);
 160   if (!defined $nail) {
 161     if ($transformed) {
 162       $toml =~ s/^/    /mg;
 163       print STDERR "$self: $nailfile transformed into TOML:\n$toml\n";
 164     }
 165     die "$self: parse $nailfile: $e\n";
 166   }
 167   die "$e ?" if length $e;
 168
 169   if (!ref $nail->{subdirs}) {
 170     $nail->{subdirs} = [
 171       grep /^[^\#]/,
 172       map { s/^\s+//; s/\s+$//; $_; }
 173       split m{\n},
 174       $nail->{subdirs}
 175     ];
 176   }
 177 }
 178
 179 our %manifests;
 180 our %packagemap;
 181
 182 sub read_manifest ($) {
 183   my ($subdir) = @_;
 184   my $manifest = "../$subdir/Cargo.toml";
 185   print STDERR "$self: reading $manifest...\n" if $verbose>=4;
 186   if (defined $manifests{$manifest}) {
 187     print STDERR
 188  "$self: warning: $subdir: specified more than once!\n";
 189     return undef;
 190   }
 191   foreach my $try ("$manifest.unnailed", "$manifest") {
 192     my $toml = toml_or_enoent($try, "package manifest") // next;
 193     my $p = $toml->{package}{name};
 194     if (!defined $p) {
 195       print STDERR
 196  "$self: warning: $subdir: missing package.name in $try, ignoring\n";
 197       next;
 198     }
 199     $manifests{$manifest} = $toml;
 200     return $p;
 201   }
 202   return undef;
 203 }
 204
 205 sub readorigs () {
 206   foreach my $p (keys %{ $nail->{packages} }) {
 207     my $v = $nail->{packages}{$p};
 208     my $subdir = ref($v) ? $v->{subdir} : $v;
 209     my $gotpackage = read_manifest($subdir) // '<nothing!>';
 210     if ($gotpackage ne $p) {
 211       print STDERR
 212  "$self: warning: honouring Cargo.nail packages.$subdir=$p even though $subdir contains package $gotpackage!\n";
 213     }
 214     die if defined $packagemap{$p};
 215     $packagemap{$p} = $subdir;
 216   }
 217   foreach my $subdir (@{ $nail->{subdirs} }) {
 218     my $gotpackage = read_manifest($subdir);
 219     if (!defined $gotpackage) {
 220       print STDERR
 221  "$self: warning: ignoring subdir $subdir which has no Cargo.toml\n";
 222       next;
 223     }
 224     $packagemap{$gotpackage} //= $subdir;
 225   }
 226 }
 227
 228 sub calculate () {
 229   foreach my $p (sort keys %packagemap) {
 230     print STDERR "$self: package $p in $packagemap{$p}\n" if $verbose>=2;
 231   }
 232   foreach my $mf (keys %manifests) {
 233     my $toml = $manifests{$mf};
 234     foreach my $k (qw(dependencies build-dependencies dev-dependencies)) {
 235       my $deps = $toml->{$k};
 236       next unless $deps;
 237       foreach my $p (keys %packagemap) {
 238         my $info = $deps->{$p};
 239         next unless defined $info;
 240         $deps->{$p} = $info = { } unless ref $info;
 241         delete $info->{version};
 242         $info->{path} = $worksphere.'/'.$packagemap{$p};
 243       }
 244     }
 245     my $nailing = "$mf.nailing~";
 246     unlink_or_enoent $nailing or die "$self: remove old $nailing: $!\n";
 247     open N, '>', $nailing or die "$self: create new $nailing: $!\n";
 248     print N to_toml($toml) or die "$self: write new $nailing: $!\n";
 249     close N or die "$self: close new $nailing: $!\n";
 250   }
 251 }
 252
 253 our $want_uninstall;
 254
 255 END {
 256   if ($want_uninstall) {
 257     local ($?);
 258     foreach my $mf (keys %manifests) {
 259       eval { uninstall1($mf,1); 1; } or warn "$@";
 260     }
 261   }
 262 }
 263
 264 sub makebackups () {
 265   foreach my $mf (keys %manifests) {
 266     link "$mf", "$mf.unnailed" or $!==EEXIST
 267       or die "$self: make backup link $mf.unnailed: $!\n";
 268   }
 269 }
 270
 271 sub nailed ($) {
 272   my ($mf) = @_;
 273   my $nailed  = "$mf.nailed~"; $nailed =~ s{/([^/]+)$}{/.$1} or die;
 274   $nailed;
 275 }
 276
 277 sub install () {
 278   foreach my $mf (keys %manifests) {
 279     my $nailing = "$mf.nailing~";
 280     my $nailed = nailed($mf);
 281     my ($use, $rm);
 282     my $diff;
 283     if (open NN, '<', $nailed) {
 284       $diff = compare($nailing, \*NN);
 285       die "$self: compare $nailing and $nailed: $!" if $diff<0;
 286     } else {
 287       $!==ENOENT or die "$self: check previous $nailed: $!\n";
 288       $diff = 1;
 289     }
 290     if ($diff) {
 291       $use = $nailing;
 292       $rm  = $nailed;
 293     } else {
 294       $use = $nailed;
 295       $rm  = $nailing;
 296     }
 297     rename $use, $mf or die "$self: install nailed $use: $!\n";
 298     unlink_or_enoent $rm or die "$self: remove old $rm: $!\n";
 299     print STDERR "$self: nailed $mf\n" if $verbose>=3;
 300   }
 301 }
 302
 303 sub invoke () {
 304   my $r = system @ARGV;
 305   if (!$r) {
 306     return 0;
 307   } elsif ($r<0) {
 308     print STDERR "$self: could not execute $ARGV[0]: $!\n";
 309     return 127;
 310   } elsif ($r & 0xff00) {
 311     print STDERR "$self: $ARGV[0] failed (exit status $r)\n";
 312     return $r >> 8;
 313   } else {
 314     print STDERR "$self: $ARGV[0] died due to signal! (wait status $r)\n";
 315     return 125;
 316   }
 317 }
 318
 319 sub uninstall1 ($$) {
 320   my ($mf, $enoentok) = @_;
 321   my $unnailed = "$mf.unnailed";
 322   rename $unnailed, $mf or ($enoentok && $!==ENOENT)
 323     or die "$self: failed to restore: rename $unnailed back to $mf: $!\n";
 324 }
 325
 326 sub uninstall () {
 327   foreach my $mf (keys %manifests) {
 328     my $nailed = nailed($mf);
 329     link $mf, $nailed or die "$self: preserve (link) $mf as $nailed: $!\n";
 330     uninstall1($mf,0);
 331   }
 332 }
 333
 334 while (@ARGV && $ARGV[0] =~ m/^-/) {
 335   $_ = shift @ARGV;
 336   last if m{^--$};
 337   if (m{^-[^-]}) {
 338     while (m{^-.}) {
 339       if (s{^-v}{-}) {
 340         $verbose++;
 341       } elsif (s{^-q}{-}) {
 342         $verbose=0;
 343       } elsif (s{^-n}{-}) {
 344         $noact++;
 345       } elsif (s{^-D}{-}) {
 346         $dump++;
 347       } else {
 348         die "$self: unknown short option(s) $_\n";
 349       }
 350     }
 351   } else {
 352     die "$self: unknown long option $_\n";
 353   }
 354 }
 355
 356 die "$self: need command to run\n" unless @ARGV || $noact;
 357
 358 takelock();
 359 readnail();
 360 readorigs();
 361 calculate();
 362
 363 if ($dump) {
 364   eval '
 365     use Data::Dumper;
 366     print STDERR Dumper(\%manifests, \%packagemap);
 367   ' or die $@;
 368 }
 369
 370 exit 0 if $noact;
 371
 372 $want_uninstall = 1;
 373 makebackups();
 374 install();
 375
 376 printf STDERR "$self: Nailed (%s manifests, %s packages)\n",
 377   (scalar keys %manifests), (scalar keys %packagemap)
 378   if $verbose;
 379
 380 my $estatus = invoke();
 381
 382 uninstall();
 383 $want_uninstall = 1;
 384 print STDERR "$self: unnailed.\n" if $verbose;
 385
 386 exit $estatus;