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,$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 unlink_or_enoent ($) { unlink $_[0] or $!==ENOENT; }
 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 defined $info;
 208                 $deps->{$p} = $info = { } unless ref $info;
 209                 delete $info->{version};
 210                 $info->{path} = $worksphere.'/'.$packagemap{$p};
 211             }
 212         }
 213         my $nailing = "$mf.nailing~";
 214         unlink_or_enoent $nailing 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,1); 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 nailed ($) {
 240     my ($mf) = @_;
 241     my $nailed  = "$mf.nailed~"; $nailed =~ s{/([^/]+)$}{/.$1} or die;
 242     $nailed;
 243 }
 244
 245 sub install () {
 246     foreach my $mf (keys %manifests) {
 247         my $nailing = "$mf.nailing~";
 248         my $nailed = nailed($mf);
 249         my ($use, $rm);
 250         my $diff;
 251         if (open NN, '<', $nailed) {
 252             $diff = compare($nailing, \*NN);
 253             die "$self: compare $nailing and $nailed: $!" if $diff<0;
 254         } else {
 255             $!==ENOENT or die "$self: check previous $nailed: $!\n";
 256             $diff = 1;
 257         }
 258         if ($diff) {
 259             $use = $nailing;
 260             $rm  = $nailed;
 261         } else {
 262             $use = $nailed;
 263             $rm  = $nailing;
 264         }
 265         rename $use, $mf or die "$self: install nailed $use: $!\n";
 266         unlink_or_enoent $rm or die "$self: remove old $rm: $!\n";
 267         print STDERR "Nailed $mf\n" if $verbose>=2;
 268     }
 269 }
 270
 271 sub invoke () {
 272     my $r = system @ARGV;
 273     if (!$r) {
 274         return 0;
 275     } elsif ($r<0) {
 276         print STDERR "$self: could not execute $ARGV[0]: $!\n";
 277         return 127;
 278     } elsif ($r & 0xff00) {
 279         print STDERR "$self: $ARGV[0] failed (exit status $r)\n";
 280         return $r >> 8;
 281     } else {
 282         print STDERR "$self: $ARGV[0] died due to signal! (wait status $r)\n";
 283         return 125;
 284     }
 285 }
 286
 287 sub uninstall1 ($$) {
 288     my ($mf, $enoentok) = @_;
 289     my $unnailed = "$mf.unnailed";
 290     rename $unnailed, $mf or ($enoentok && $!==ENOENT)
 291         or die "$self: failed to restore: rename $unnailed back to $mf: $!\n";
 292 }
 293
 294 sub uninstall () {
 295     foreach my $mf (keys %manifests) {
 296         my $nailed = nailed($mf);
 297         link $mf, $nailed or die "$self: preserve (link) $mf as $nailed: $!\n";
 298         uninstall1($mf,0);
 299     }
 300 }
 301
 302 while (@ARGV && $ARGV[0] =~ m/^-/) {
 303     $_ = shift @ARGV;
 304     last if m{^--$};
 305     if (m{^-[^-]}) {
 306         while (m{^-.}) {
 307             if (s{^-v}{-}) {
 308                 $verbose++;
 309             } elsif (s{^-n}{-}) {
 310                 $noact++;
 311             } elsif (s{^-D}{-}) {
 312                 $dump++;
 313             } else {
 314                 die "$self: unknown short option(s) $_\n";
 315             }
 316         }
 317     } else {
 318         die "$self: unknown long option $_\n";
 319     }
 320 }
 321
 322 takelock();
 323 readnail();
 324 readorigs();
 325 calculate();
 326
 327 if ($dump) {
 328     eval '
 329         use Data::Dumper;
 330         print STDERR Dumper(\%manifests, \%packagemap);
 331     ' or die $@;
 332 }
 333
 334 exit 0 if $noact;
 335
 336 $want_uninstall = 1;
 337 makebackups();
 338 install();
 339
 340 my $estatus = invoke();
 341
 342 print STDERR "INVOKED\n";
 343 uninstall();
 344 print STDERR "UNINSTALLED\n";
 345 $want_uninstall = 1;
 346
 347 exit $estatus;