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;