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 use strict;
  43 use TOML::Tiny::Faithful;
  44 use POSIX;
  45 use Fcntl qw(LOCK_EX);
  46 use File::Compare;
  47
  48 my $self = $0;  $self =~ s{^.*/(?=.)}{};
  49
  50 our $worksphere = getcwd() // die "$self: getcwd failed: $!\n";
  51 $worksphere =~ s{/[^/]+$}{} or die "$self: cwd \`$worksphere' unsupported!\n";
  52 our $lockfile = "../.nailing-cargo-sphere.lock";
  53
  54 our @configs;
  55 our $verbose=1;
  56 our ($noact,$dump);
  57
  58 sub read_or_enoent ($) {
  59   my ($fn) = @_;
  60   if (!open R, '<', $fn) {
  61     return undef if $!==ENOENT;
  62     die "$self: open $fn: $!\n";
  63   }
  64   local ($/) = undef;
  65   my ($r) = <R> // die "$self: read $fn: $!\n";
  66   $r;
  67 }
  68
  69 sub toml_or_enoent ($$) {
  70   my ($f,$what) = @_;
  71   my $toml = read_or_enoent($f) // return;
  72   my ($v,$e) = from_toml($toml);
  73   die "$self: parse TOML: $what: $f: $e\n" unless defined $v;
  74   die "$e ?" if length $e;
  75   $v;
  76 }
  77
  78 sub load1config ($) {
  79   my ($f) = @_;
  80   my $toml = toml_or_enoent($f, "config file");
  81   push @configs, $toml if defined $toml;
  82 }
  83
  84 sub loadconfigs () {
  85   my $cfgleaf = ".nailing-cargo-cfg.toml";
  86   load1config("/etc/nailing-cargo/cfg.toml");
  87   load1config("$worksphere/$cfgleaf");
  88   load1config("$ENV{HOME}/$cfgleaf") if defined $ENV{HOME};
  89 }
  90
  91 sub getcfg ($$) {
  92   my ($k, $def) = @_;
  93   foreach my $cfg (@configs) {
  94     my $v = $cfg->{$k};
  95     return $v if defined $v;
  96   }
  97   return $def;
  98 }
  99
 100 sub unlink_or_enoent ($) { unlink $_[0] or $!==ENOENT; }
 101
 102 sub takelock () {
 103   for (;;) {
 104     open LOCK, ">", $lockfile or die "$self: open/create $lockfile: $!\n";
 105     flock LOCK, LOCK_EX or die "$self: lock $lockfile: $!\n";
 106     my @fstat = stat LOCK or die "$self: fstat: $!\n";
 107     my @stat  = stat $lockfile;
 108     if (!@stat) {
 109       next if $! == ENOENT;
 110       die "$self: stat $lockfile: $!\n";
 111     }
 112     last if "@fstat[0..5]" eq "@stat[0..5]";
 113   }
 114 }
 115 sub unlock () {
 116   unlink $lockfile or die "$self: removing lockfile: $!\n";
 117 }
 118
 119 our $nail;
 120
 121 sub readnail () {
 122   my $nailfile = "../Cargo.nail";
 123   open N, '<', $nailfile or die "$self: open $nailfile: $!\n";
 124   local ($/) = undef;
 125   my $toml = <N> // die "$self: read $nailfile: $!";
 126   my $transformed;
 127   if ($toml !~ m{^\s*\[/}m &&
 128       $toml !~ m{^[^\n\#]*\=}m &&
 129       # old non-toml syntax
 130       $toml =~ s{^[ \t]*([-_0-9a-z]+)[ \t]+(\S+)[ \t]*$}{$1 = \"$2\"}mig) {
 131     $toml =~ s{^}{[packages\]\n};
 132     my @sd;
 133     $toml =~ s{^[ \t]*\-[ \t]*\=[ \t]*(\"[-_0-9a-z]+\"\n?)$}{
 134       push @sd, $1; '';
 135     }mige;
 136     $toml = "subdirs = [\n".(join '', map { "$_\n" } @sd)."]\n".$toml;
 137     $transformed = 1;
 138   }
 139   my $e;
 140   ($nail,$e) = from_toml($toml);
 141   if (!defined $nail) {
 142     if ($transformed) {
 143       $toml =~ s/^/    /mg;
 144       print STDERR "$self: $nailfile transformed into TOML:\n$toml\n";
 145     }
 146     die "$self: parse $nailfile: $e\n";
 147   }
 148   die "$e ?" if length $e;
 149 }
 150
 151 our %manifests;
 152 our %packagemap;
 153
 154 sub read_manifest ($) {
 155   my ($subdir) = @_;
 156   my $manifest = "../$subdir/Cargo.toml";
 157   print STDERR "$self: reading $manifest...\n" if $verbose>=4;
 158   if (defined $manifests{$manifest}) {
 159     print STDERR
 160  "$self: warning: $subdir: specified more than once!\n";
 161     return undef;
 162   }
 163   foreach my $try ("$manifest.unnailed", "$manifest") {
 164     my $toml = toml_or_enoent($try, "package manifest") // next;
 165     my $p = $toml->{package}{name};
 166     if (!defined $p) {
 167       print STDERR
 168  "$self: warning: $subdir: missing package.name in $try, ignoring\n";
 169       next;
 170     }
 171     $manifests{$manifest} = $toml;
 172     return $p;
 173   }
 174   return undef;
 175 }
 176
 177 sub readorigs () {
 178   foreach my $p (keys %{ $nail->{packages} }) {
 179     my $v = $nail->{packages}{$p};
 180     my $subdir = ref($v) ? $v->{subdir} : $v;
 181     my $gotpackage = read_manifest($subdir) // '<nothing!>';
 182     if ($gotpackage ne $p) {
 183       print STDERR
 184  "$self: warning: honouring Cargo.nail packages.$subdir=$p even though $subdir contains package $gotpackage!\n";
 185     }
 186     die if defined $packagemap{$p};
 187     $packagemap{$p} = $subdir;
 188   }
 189   foreach my $subdir (@{ $nail->{subdirs} }) {
 190     my $gotpackage = read_manifest($subdir);
 191     if (!defined $gotpackage) {
 192       print STDERR
 193  "$self: warning: ignoring subdir $subdir which has no Cargo.toml\n";
 194       next;
 195     }
 196     $packagemap{$gotpackage} //= $subdir;
 197   }
 198 }
 199
 200 sub calculate () {
 201   foreach my $mf (keys %manifests) {
 202     my $toml = $manifests{$mf};
 203     foreach my $k (qw(dependencies build-dependencies dev-dependencies)) {
 204       my $deps = $toml->{$k};
 205       next unless $deps;
 206       foreach my $p (keys %packagemap) {
 207         my $info = $deps->{$p};
 208         next unless defined $info;
 209         $deps->{$p} = $info = { } unless ref $info;
 210         delete $info->{version};
 211         $info->{path} = $worksphere.'/'.$packagemap{$p};
 212       }
 213     }
 214     my $nailing = "$mf.nailing~";
 215     unlink_or_enoent $nailing or die "$self: remove old $nailing: $!\n";
 216     open N, '>', $nailing or die "$self: create new $nailing: $!\n";
 217     print N to_toml($toml) or die "$self: write new $nailing: $!\n";
 218     close N or die "$self: close new $nailing: $!\n";
 219   }
 220 }
 221
 222 our $want_uninstall;
 223
 224 END {
 225   if ($want_uninstall) {
 226     local ($?);
 227     foreach my $mf (keys %manifests) {
 228       eval { uninstall1($mf,1); 1; } or warn "$@";
 229     }
 230   }
 231 }
 232
 233 sub makebackups () {
 234   foreach my $mf (keys %manifests) {
 235     link "$mf", "$mf.unnailed" or $!==EEXIST
 236       or die "$self: make backup link $mf.unnailed: $!\n";
 237   }
 238 }
 239
 240 sub nailed ($) {
 241   my ($mf) = @_;
 242   my $nailed  = "$mf.nailed~"; $nailed =~ s{/([^/]+)$}{/.$1} or die;
 243   $nailed;
 244 }
 245
 246 sub install () {
 247   foreach my $mf (keys %manifests) {
 248     my $nailing = "$mf.nailing~";
 249     my $nailed = nailed($mf);
 250     my ($use, $rm);
 251     my $diff;
 252     if (open NN, '<', $nailed) {
 253       $diff = compare($nailing, \*NN);
 254       die "$self: compare $nailing and $nailed: $!" if $diff<0;
 255     } else {
 256       $!==ENOENT or die "$self: check previous $nailed: $!\n";
 257       $diff = 1;
 258     }
 259     if ($diff) {
 260       $use = $nailing;
 261       $rm  = $nailed;
 262     } else {
 263       $use = $nailed;
 264       $rm  = $nailing;
 265     }
 266     rename $use, $mf or die "$self: install nailed $use: $!\n";
 267     unlink_or_enoent $rm or die "$self: remove old $rm: $!\n";
 268     print STDERR "Nailed $mf\n" if $verbose>=3;
 269   }
 270 }
 271
 272 sub invoke () {
 273   my $r = system @ARGV;
 274   if (!$r) {
 275     return 0;
 276   } elsif ($r<0) {
 277     print STDERR "$self: could not execute $ARGV[0]: $!\n";
 278     return 127;
 279   } elsif ($r & 0xff00) {
 280     print STDERR "$self: $ARGV[0] failed (exit status $r)\n";
 281     return $r >> 8;
 282   } else {
 283     print STDERR "$self: $ARGV[0] died due to signal! (wait status $r)\n";
 284     return 125;
 285   }
 286 }
 287
 288 sub uninstall1 ($$) {
 289   my ($mf, $enoentok) = @_;
 290   my $unnailed = "$mf.unnailed";
 291   rename $unnailed, $mf or ($enoentok && $!==ENOENT)
 292     or die "$self: failed to restore: rename $unnailed back to $mf: $!\n";
 293 }
 294
 295 sub uninstall () {
 296   foreach my $mf (keys %manifests) {
 297     my $nailed = nailed($mf);
 298     link $mf, $nailed or die "$self: preserve (link) $mf as $nailed: $!\n";
 299     uninstall1($mf,0);
 300   }
 301 }
 302
 303 while (@ARGV && $ARGV[0] =~ m/^-/) {
 304   $_ = shift @ARGV;
 305   last if m{^--$};
 306   if (m{^-[^-]}) {
 307     while (m{^-.}) {
 308       if (s{^-v}{-}) {
 309         $verbose++;
 310       } elsif (s{^-q}{-}) {
 311         $verbose=0;
 312       } elsif (s{^-n}{-}) {
 313         $noact++;
 314       } elsif (s{^-D}{-}) {
 315         $dump++;
 316       } else {
 317         die "$self: unknown short option(s) $_\n";
 318       }
 319     }
 320   } else {
 321     die "$self: unknown long option $_\n";
 322   }
 323 }
 324
 325 takelock();
 326 readnail();
 327 readorigs();
 328 calculate();
 329
 330 if ($dump) {
 331   eval '
 332     use Data::Dumper;
 333     print STDERR Dumper(\%manifests, \%packagemap);
 334   ' or die $@;
 335 }
 336
 337 exit 0 if $noact;
 338
 339 $want_uninstall = 1;
 340 makebackups();
 341 install();
 342
 343 printf STDERR "$self: Nailed (%d manifests, %d packages)\n",
 344   (scalar %manifests, scalar %packagemap)
 345   if $verbose;
 346
 347 my $estatus = invoke();
 348
 349 uninstall();
 350 $want_uninstall = 1;
 351 print STDERR "$self: Unnailed.\n" if $verbose;
 352
 353 exit $estatus;