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