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 $src_absdir = getcwd() // die "$self: getcwd failed: $!\n";
  70
  71 our $worksphere = $src_absdir;
  72 $worksphere =~ s{/([^/]+)$}{}
  73   or die "$self: cwd \`$worksphere' unsupported!\n";
  74 our $subdir = $1; # leafname
  75
  76 our $lockfile = "../.nailing-cargo.lock";
  77 our $oot_cargo_lock_faff;
  78
  79 our @configs;
  80 our $verbose=1;
  81 our ($noact,$dump);
  82
  83 sub read_or_enoent ($) {
  84   my ($fn) = @_;
  85   if (!open R, '<', $fn) {
  86     return undef if $!==ENOENT;
  87     die "$self: open $fn: $!\n";
  88   }
  89   local ($/) = undef;
  90   my ($r) = <R> // die "$self: read $fn: $!\n";
  91   $r;
  92 }
  93
  94 sub toml_or_enoent ($$) {
  95   my ($f,$what) = @_;
  96   my $toml = read_or_enoent($f) // return;
  97   my ($v,$e) = from_toml($toml);
  98   die "$self: parse TOML: $what: $f: $e\n" unless defined $v;
  99   die "$e ?" if length $e;
 100   $v;
 101 }
 102
 103 sub load1config ($) {
 104   my ($f) = @_;
 105   my $toml = toml_or_enoent($f, "config file");
 106   push @configs, $toml if defined $toml;
 107 }
 108
 109 sub loadconfigs () {
 110   my $cfgleaf = ".nailing-cargo-cfg.toml";
 111   load1config("/etc/nailing-cargo/cfg.toml");
 112   load1config("$worksphere/$cfgleaf");
 113   load1config("$ENV{HOME}/$cfgleaf") if defined $ENV{HOME};
 114 }
 115
 116 sub getcfg ($$) {
 117   my ($k, $def) = @_;
 118   foreach my $cfg (@configs) {
 119     my $v = $cfg->{$k};
 120     return $v if defined $v;
 121   }
 122   return $def;
 123 }
 124
 125 sub unlink_or_enoent ($) { unlink $_[0] or $!==ENOENT; }
 126
 127 sub takelock () {
 128   for (;;) {
 129     open LOCK, ">", $lockfile or die "$self: open/create $lockfile: $!\n";
 130     flock LOCK, LOCK_EX or die "$self: lock $lockfile: $!\n";
 131     my @fstat = stat LOCK or die "$self: fstat: $!\n";
 132     my @stat  = stat $lockfile;
 133     if (!@stat) {
 134       next if $! == ENOENT;
 135       die "$self: stat $lockfile: $!\n";
 136     }
 137     last if "@fstat[0..5]" eq "@stat[0..5]";
 138   }
 139 }
 140 sub unlock () {
 141   unlink $lockfile or die "$self: removing lockfile: $!\n";
 142 }
 143
 144 our $nail;
 145
 146 sub badcfg {
 147   my $m = pop @_;
 148   $" = '.';
 149   die "$self: config key \`@_': $m\n";
 150 }
 151
 152 sub cfg_uc {
 153   my $v = $nail;
 154   foreach my $k (@_) {
 155     last unless defined $v;
 156     ref($v) eq 'HASH' or badcfg @, "parent key \`$k' is not a hash";
 157     $v = $v->{$k};
 158   }
 159   return $v;
 160 }
 161
 162 sub cfg {
 163   my $exp = shift @_;
 164   my $v = cfg_uc @_;
 165   my $got = ref($v) || 'scalar';
 166   return $v if !defined($v) || $got eq $exp;
 167   badcfg @_, "found \L$got\E, expected \L$exp\E";
 168   # ^ toml doesn't make refs to scalars, so this is unambiguous
 169 }
 170
 171 sub cfgn {
 172   my $exp = shift @_;
 173   cfg $exp, @_ // badcfg @_, "missing";
 174 }
 175
 176 sub cfgs  { cfg  'scalar', @_ }
 177 sub cfgsn { cfgn 'scalar', @_ }
 178
 179 sub cfgn_list {
 180   my $l = cfg 'ARRAY', @_;
 181   foreach my $x (@l) {
 182     !ref $x or badcfg @_, "list contains non-scalar element";
 183   }
 184   @$l
 185 }
 186
 187 sub readnail () {
 188   my $nailfile = "../Cargo.nail";
 189   open N, '<', $nailfile or die "$self: open $nailfile: $!\n";
 190   local ($/) = undef;
 191   my $toml = <N> // die "$self: read $nailfile: $!";
 192   my $transformed;
 193   if ($toml !~ m{^\s*\[/}m &&
 194       $toml !~ m{^[^\n\#]*\=}m &&
 195       # old non-toml syntax
 196       $toml =~ s{^[ \t]*([-_0-9a-z]+)[ \t]+(\S+)[ \t]*$}{$1 = \"$2\"}mig) {
 197     $toml =~ s{^}{[packages\]\n};
 198     my @sd;
 199     $toml =~ s{^[ \t]*\-[ \t]*\=[ \t]*(\"[-_0-9a-z]+\"\n?)$}{
 200       push @sd, $1; '';
 201     }mige;
 202     $toml = "subdirs = [\n".(join '', map { "$_\n" } @sd)."]\n".$toml;
 203     $transformed = 1;
 204   }
 205   my $e;
 206   ($nail,$e) = from_toml($toml);
 207   if (!defined $nail) {
 208     if ($transformed) {
 209       $toml =~ s/^/    /mg;
 210       print STDERR "$self: $nailfile transformed into TOML:\n$toml\n";
 211     }
 212     die "$self: parse $nailfile: $e\n";
 213   }
 214   die "$e ?" if length $e;
 215
 216   if (!ref $nail->{subdirs}) {
 217     $nail->{subdirs} = [
 218       grep /^[^\#]/,
 219       map { s/^\s+//; s/\s+$//; $_; }
 220       split m{\n},
 221       $nail->{subdirs}
 222     ];
 223   }
 224 }
 225
 226 our %manifests;
 227 our %packagemap;
 228
 229 sub read_manifest ($) {
 230   my ($subdir) = @_;
 231   my $manifest = "../$subdir/Cargo.toml";
 232   print STDERR "$self: reading $manifest...\n" if $verbose>=4;
 233   if (defined $manifests{$manifest}) {
 234     print STDERR
 235  "$self: warning: $subdir: specified more than once!\n";
 236     return undef;
 237   }
 238   foreach my $try ("$manifest.unnailed", "$manifest") {
 239     my $toml = toml_or_enoent($try, "package manifest") // next;
 240     my $p = $toml->{package}{name};
 241     if (!defined $p) {
 242       print STDERR
 243  "$self: warning: $subdir: missing package.name in $try, ignoring\n";
 244       next;
 245     }
 246     $manifests{$manifest} = $toml;
 247     return $p;
 248   }
 249   return undef;
 250 }
 251
 252 sub readorigs () {
 253   foreach my $p (keys %{ $nail->{packages} }) {
 254     my $v = $nail->{packages}{$p};
 255     my $subdir = ref($v) ? $v->{subdir} : $v;
 256     my $gotpackage = read_manifest($subdir) // '<nothing!>';
 257     if ($gotpackage ne $p) {
 258       print STDERR
 259  "$self: warning: honouring Cargo.nail packages.$subdir=$p even though $subdir contains package $gotpackage!\n";
 260     }
 261     die if defined $packagemap{$p};
 262     $packagemap{$p} = $subdir;
 263   }
 264   foreach my $subdir (@{ $nail->{subdirs} }) {
 265     my $gotpackage = read_manifest($subdir);
 266     if (!defined $gotpackage) {
 267       print STDERR
 268  "$self: warning: ignoring subdir $subdir which has no Cargo.toml\n";
 269       next;
 270     }
 271     $packagemap{$gotpackage} //= $subdir;
 272   }
 273 }
 274
 275 sub calculate () {
 276   foreach my $p (sort keys %packagemap) {
 277     print STDERR "$self: package $p in $packagemap{$p}\n" if $verbose>=2;
 278   }
 279   foreach my $mf (keys %manifests) {
 280     my $toml = $manifests{$mf};
 281     foreach my $k (qw(dependencies build-dependencies dev-dependencies)) {
 282       my $deps = $toml->{$k};
 283       next unless $deps;
 284       foreach my $p (keys %packagemap) {
 285         my $info = $deps->{$p};
 286         next unless defined $info;
 287         $deps->{$p} = $info = { } unless ref $info;
 288         delete $info->{version};
 289         $info->{path} = $worksphere.'/'.$packagemap{$p};
 290       }
 291     }
 292     my $nailing = "$mf.nailing~";
 293     unlink_or_enoent $nailing or die "$self: remove old $nailing: $!\n";
 294     open N, '>', $nailing or die "$self: create new $nailing: $!\n";
 295     print N to_toml($toml) or die "$self: write new $nailing: $!\n";
 296     close N or die "$self: close new $nailing: $!\n";
 297   }
 298 }
 299
 300 our @out_command;
 301
 302 our $oot_dir;      # oot.dir or "Build"
 303 our $oot_absdir;
 304
 305 our $build_absdir; # .../Build/<subdir>
 306
 307 sub calculate_oot () {
 308   $oot_dir = cfgs qw(oot dir);
 309   my $use = cfgs qw(oot use);
 310   return unless defined($oot_dir) || defined($use);
 311   $oot_dir //= 'Build';
 312
 313   if (@ARGV && $ARGV[0] =~ m/generate-lockfile|update/) {
 314     $oot_cargo_lock_faff = 1;
 315   }
 316
 317   $oot_absdir = ($oot_dir !~ m{^/} ? "$worksphere/"). $oot_dir;
 318   $build_absdir = "$oot_absdir/$subdir";
 319
 320   my ($pre,$post);
 321   my @xargs;
 322   if (!$oot_cargo_lock_faff) {
 323     @xargs = $build_absdir;
 324     ($pre, $post) = ('cd "$1"; shift', '');
 325   } else {
 326     @xargs = $build_absdir, $subdir, $src_absdir;
 327     ($pre, $post) = (<<'END', <<'END');
 328         cd "$1"; shift;
 329         mkdir -p -- "$1"; cd "$1"; shift;
 330         cp -- "$1"/Cargo.toml "$1"/Cargo.lock .; shift;
 331         mkdir -p src; >src/lib.rs;
 332 END
 333         rm -r src Cargo.toml;
 334 END
 335     $pre  =~ s/^\s+//mg; $pre  =~ s/^\s+\n/ /g;
 336     $post =~ s/^\s+//mg; $post =~ s/^\s+\n/ /g;
 337   }
 338   my $getuser = sub { cfgsn qw(oot user) };
 339   my @command;
 340   my $sh_ec = sub {
 341     if (!length $post) {
 342       @command = @_, 'sh','-ec',$pre.' exec "$@"','--',@xargs;
 343     } else {
 344       @command = @_, 'sh','-ec',$pre.' "$@"; '.$post,'--',@xargs;
 345     }
 346   };
 347   my $command_sh = sub {
 348     my $quoted = join ' ', map {
 349       return $_ if !m/\W/;
 350       s/\'/\'\\'\'/g;
 351       "'$_'"
 352     } @ARGV;
 353     @command = @_, "set -e; $pre $quoted; $post";
 354   };
 355   if ($use eq 'really') {
 356     my $user = $getuser->();
 357     my @pw = getpwnam $user or "die $self: oot.user lookup failed\n";
 358     my $homedir = $pw[7];
 359     $sh_ec->('really','-u',$user,'env',"HOME=$homedir");
 360   } elsif ($use eq 'ssh') {
 361     my $user = $getuser->();
 362     $user .= '@localhost' unless $user =~ m/\@/;
 363     $command_sh->('ssh',$user);
 364   } elsif ($use eq 'command_sh') {
 365     $command_sh->(cfgn_list qw(oot command));
 366   } elsif ($use eq 'command_args') {
 367     $sh_ec->(cfgn_list qw(oot command))
 368   } else {
 369     die "$self: oot.use mode $use not recognised\n";
 370   }
 371   die unless @command;
 372   @ARGV = @command;
 373 }
 374
 375 our $want_uninstall;
 376
 377 END {
 378   if ($want_uninstall) {
 379     local ($?);
 380     foreach my $mf (keys %manifests) {
 381       eval { uninstall1($mf,1); 1; } or warn "$@";
 382     }
 383   }
 384 }
 385
 386 sub makebackups () {
 387   foreach my $mf (keys %manifests) {
 388     link "$mf", "$mf.unnailed" or $!==EEXIST
 389       or die "$self: make backup link $mf.unnailed: $!\n";
 390   }
 391 }
 392
 393 sub nailed ($) {
 394   my ($mf) = @_;
 395   my $nailed  = "$mf.nailed~"; $nailed =~ s{/([^/]+)$}{/.$1} or die;
 396   $nailed;
 397 }
 398
 399 sub install () {
 400   foreach my $mf (keys %manifests) {
 401     my $nailing = "$mf.nailing~";
 402     my $nailed = nailed($mf);
 403     my ($use, $rm);
 404     my $diff;
 405     if (open NN, '<', $nailed) {
 406       $diff = compare($nailing, \*NN);
 407       die "$self: compare $nailing and $nailed: $!" if $diff<0;
 408     } else {
 409       $!==ENOENT or die "$self: check previous $nailed: $!\n";
 410       $diff = 1;
 411     }
 412     if ($diff) {
 413       $use = $nailing;
 414       $rm  = $nailed;
 415     } else {
 416       $use = $nailed;
 417       $rm  = $nailing;
 418     }
 419     rename $use, $mf or die "$self: install nailed $use: $!\n";
 420     unlink_or_enoent $rm or die "$self: remove old $rm: $!\n";
 421     print STDERR "$self: nailed $mf\n" if $verbose>=3;
 422   }
 423 }
 424
 425 sub invoke () {
 426   my $r = system @ARGV;
 427   if (!$r) {
 428     return 0;
 429   } elsif ($r<0) {
 430     print STDERR "$self: could not execute $ARGV[0]: $!\n";
 431     return 127;
 432   } elsif ($r & 0xff00) {
 433     print STDERR "$self: $ARGV[0] failed (exit status $r)\n";
 434     return $r >> 8;
 435   } else {
 436     print STDERR "$self: $ARGV[0] died due to signal! (wait status $r)\n";
 437     return 125;
 438   }
 439 }
 440
 441 sub uninstall1 ($$) {
 442   my ($mf, $enoentok) = @_;
 443   my $unnailed = "$mf.unnailed";
 444   rename $unnailed, $mf or ($enoentok && $!==ENOENT)
 445     or die "$self: failed to restore: rename $unnailed back to $mf: $!\n";
 446 }
 447
 448 sub uninstall () {
 449   foreach my $mf (keys %manifests) {
 450     my $nailed = nailed($mf);
 451     link $mf, $nailed or die "$self: preserve (link) $mf as $nailed: $!\n";
 452     uninstall1($mf,0);
 453   }
 454 }
 455
 456 while (@ARGV && $ARGV[0] =~ m/^-/) {
 457   $_ = shift @ARGV;
 458   last if m{^--$};
 459   if (m{^-[^-]}) {
 460     while (m{^-.}) {
 461       if (s{^-v}{-}) {
 462         $verbose++;
 463       } elsif (s{^-q}{-}) {
 464         $verbose=0;
 465       } elsif (s{^-n}{-}) {
 466         $noact++;
 467       } elsif (s{^-D}{-}) {
 468         $dump++;
 469       } elsif (s{^-L}{-}) {
 470         $oot_cargo_lock_faff=1;
 471       } else {
 472         die "$self: unknown short option(s) $_\n";
 473       }
 474     }
 475   } else {
 476     die "$self: unknown long option $_\n";
 477   }
 478 }
 479
 480 die "$self: need command to run\n" unless @ARGV || $noact;
 481
 482 takelock();
 483 readnail();
 484 readorigs();
 485 calculate();
 486 calculate_oot();
 487
 488 if ($dump) {
 489   eval '
 490     use Data::Dumper;
 491     print STDERR Dumper(\%manifests, \%packagemap, \@ARGV);
 492   ' or die $@;
 493 }
 494
 495 exit 0 if $noact;
 496
 497 $want_uninstall = 1;
 498 makebackups();
 499 install();
 500
 501 printf STDERR "$self: Nailed (%s manifests, %s packages)\n",
 502   (scalar keys %manifests), (scalar keys %packagemap)
 503   if $verbose;
 504
 505 my $estatus = invoke();
 506
 507 uninstall();
 508 $want_uninstall = 1;
 509
 510 get_cargo_lock() if $oot_cargo_lock_faff;
 511
 512 print STDERR "$self: unnailed.  status $estatus.\n" if $verbose;
 513
 514 exit $estatus;