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