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