#!/usr/bin/perl -w
# nailing-cargo: wrapper to use unpublished local crates
#
# Copyright (C) 2019-2020 Ian Jackson
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program. If not, see .
# example usages:
# ../nailing-cargo/nailing-caretwgo make
# ../nailing-cargo/nailing-cargo cargo build
# CARGO='../nailing-cargo/nailing-cargo cargo' make
# Why do we need this ?
#
# https://github.com/rust-lang/cargo/issues/6713
# https://stackoverflow.com/questions/33025887/how-to-use-a-local-unpublished-crate
# https://github.com/rust-lang/cargo/issues/1481
# Needs libtoml-perl
#: Cargo.nail:
#
# [packages]
# package = subdir
# package = { subdir = ... }
#
# [subdirs]
# subdir
our $self;
use strict;
use POSIX;
use Types::Serialiser;
our %archmap = (
RPI => 'arm-unknown-linux-gnueabihf',
);
BEGIN {
$self = $0; $self =~ s{^.*/(?=.)}{};
my $deref = $0;
while ($deref =~ m{^/}) {
my $link = readlink $deref;
if (!defined $link) {
$! == EINVAL
or die "$self: checking our script location $deref: $!\n";
$deref =~ s{/[^/]+$}{}
or die "$self: unexpected script path: $deref\n";
unshift @INC, $deref."/TOML-Tiny/lib";
last;
}
last if $link !~ m{^/};
$deref = $link;
}
}
use Fcntl qw(LOCK_EX);
use File::Compare;
use TOML::Tiny::Faithful;
our $src_absdir = getcwd() // die "$self: getcwd failed: $!\n";
our $worksphere = $src_absdir;
$worksphere =~ s{/([^/]+)$}{}
or die "$self: cwd \`$worksphere' unsupported!\n";
our $subdir = $1; # leafname
our $lockfile = "../.nailing-cargo.lock";
our $cargo_lock_update;
our $cargo_manifest_args;
our $alt_cargo_lock;
our @configs;
our $verbose=1;
our ($noact,$dump);
our $target;
sub read_or_enoent ($) {
my ($fn) = @_;
if (!open R, '<', $fn) {
return undef if $!==ENOENT;
die "$self: open $fn: $!\n";
}
local ($/) = undef;
my ($r) = // die "$self: read $fn: $!\n";
$r;
}
sub stat_exists ($$) {
my ($fn, $what) = @_;
if (stat $fn) { return 1; }
$!==ENOENT or die "$self: stat $what: $fn: $!\n";
return 0;
}
sub toml_or_enoent ($$) {
my ($f,$what) = @_;
my $toml = read_or_enoent($f) // return;
my ($v,$e) = from_toml($toml);
if (!defined $v) {
chomp $e;
die "$self: parse TOML: $what: $f: $e\n";
}
die "$e ?" if length $e;
$v;
}
sub load1config ($) {
my ($f) = @_;
my $toml = toml_or_enoent($f, "config file");
push @configs, $toml if defined $toml;
}
sub loadconfigs () {
my $cfgleaf = ".nailing-cargo-cfg.toml";
load1config("/etc/nailing-cargo/cfg.toml");
load1config("$worksphere/$cfgleaf");
load1config("$ENV{HOME}/$cfgleaf") if defined $ENV{HOME};
}
sub getcfg ($$) {
my ($k, $def) = @_;
foreach my $cfg (@configs) {
my $v = $cfg->{$k};
return $v if defined $v;
}
return $def;
}
sub unlink_or_enoent ($) { unlink $_[0] or $!==ENOENT; }
sub same_file ($$) {
my ($x,$y) = @_;
"@$x[0..5]" eq "@$y[0..5]";
}
sub takelock () {
for (;;) {
open LOCK, ">", $lockfile or die "$self: open/create $lockfile: $!\n";
flock LOCK, LOCK_EX or die "$self: lock $lockfile: $!\n";
my @fstat = stat LOCK or die "$self: fstat: $!\n";
my @stat = stat $lockfile;
if (!@stat) {
next if $! == ENOENT;
die "$self: stat $lockfile: $!\n";
}
last if same_file(\@fstat,\@stat);
}
}
sub unlock () {
unlink $lockfile or die "$self: removing lockfile: $!\n";
}
our $nail;
sub badcfg {
my $m = pop @_;
$" = '.';
die "$self: config key \`@_': $m\n";
}
sub cfg_uc {
my $v = $nail;
foreach my $k (@_) {
last unless defined $v;
ref($v) eq 'HASH' or badcfg @_, "parent key \`$k' is not a hash";
$v = $v->{$k};
}
return $v;
}
sub cfge {
my $exp = shift @_;
my $v = cfg_uc @_;
my $got = ref($v) || 'scalar';
return $v if !defined($v) || $got eq $exp;
badcfg @_, "found \L$got\E, expected \L$exp\E";
# ^ toml doesn't make refs to scalars, so this is unambiguous
}
sub cfgn {
my $exp = shift @_;
(cfge $exp, @_) // badcfg @_, "missing";
}
sub cfgs { cfge 'scalar', @_ }
sub cfgsn { cfgn 'scalar', @_ }
sub cfg_bool {
my $v = cfg_uc @_;
return $v if !defined($v) || Types::Serialiser::is_bool $v;
badcfg @_, "expected boolean";
}
sub cfgn_list {
my $l = cfge 'ARRAY', @_;
foreach my $x (@$l) {
!ref $x or badcfg @_, "list contains non-scalar element";
}
@$l
}
sub readnail () {
my $nailfile = "../Cargo.nail";
open N, '<', $nailfile or die "$self: open $nailfile: $!\n";
local ($/) = undef;
my $toml = // die "$self: read $nailfile: $!";
my $transformed;
if ($toml !~ m{^\s*\[/}m &&
$toml !~ m{^[^\n\#]*\=}m &&
# old non-toml syntax
$toml =~ s{^[ \t]*([-_0-9a-z]+)[ \t]+(\S+)[ \t]*$}{$1 = \"$2\"}mig) {
$toml =~ s{^}{[packages\]\n};
my @sd;
$toml =~ s{^[ \t]*\-[ \t]*\=[ \t]*(\"[-_0-9a-z]+\"\n?)$}{
push @sd, $1; '';
}mige;
$toml = "subdirs = [\n".(join '', map { "$_\n" } @sd)."]\n".$toml;
$transformed = 1;
}
my $e;
($nail,$e) = from_toml($toml);
if (!defined $nail) {
if ($transformed) {
$toml =~ s/^/ /mg;
print STDERR "$self: $nailfile transformed into TOML:\n$toml\n";
}
$/="\n"; chomp $e;
die "$self: parse $nailfile: $e\n";
}
die "$e ?" if length $e;
if (!ref $nail->{subdirs}) {
$nail->{subdirs} = [
grep /^[^\#]/,
map { s/^\s+//; s/\s+$//; $_; }
split m{\n},
$nail->{subdirs}
];
}
}
our @alt_cargo_lock_stat;
sub consider_alt_cargo_lock () {
my @ck = qw(alt_cargo_lock);
# User should *either* have Cargo.lock in .gitignore,
# or expect to commit Cargo.lock.example ($alt_cargo_lock)
$alt_cargo_lock = (cfg_uc @ck);
my $force = 0;
if (defined($alt_cargo_lock) && ref($alt_cargo_lock) eq 'HASH') {
$force = cfg_bool qw(alt_cargo_lock force);
my @ck = qw(alt_cargo_lock file);
$alt_cargo_lock = cfg_uc @ck;
}
$alt_cargo_lock //= Types::Serialiser::true;
if (Types::Serialiser::is_bool $alt_cargo_lock) {
if (!$alt_cargo_lock) { $alt_cargo_lock = undef; return; }
$alt_cargo_lock = 'Cargo.lock.example';
}
if (ref($alt_cargo_lock) || $alt_cargo_lock =~ m{/}) {
badcfg @ck, "expected boolean, or leafname";
}
if (!stat_exists $alt_cargo_lock, "alt_cargo_lock") {
$alt_cargo_lock = undef unless $force;
return;
}
@alt_cargo_lock_stat = stat _;
}
our $oot_dir; # oot.dir or "Build"
sub consider_oot () {
$oot_dir = cfgs qw(oot dir);
my $use = cfgs qw(oot use);
unless (defined($oot_dir) || defined($use)) {
die "$self: specified --cargo-lock-update but not out-of-tree build!\n"
if $cargo_lock_update;
$cargo_lock_update=0;
return;
}
$oot_dir //= 'Build';
}
our %manifests;
our %packagemap;
sub read_manifest ($) {
my ($subdir) = @_;
my $manifest = "../$subdir/Cargo.toml";
print STDERR "$self: reading $manifest...\n" if $verbose>=4;
if (defined $manifests{$manifest}) {
print STDERR
"$self: warning: $subdir: specified more than once!\n";
return undef;
}
foreach my $try ("$manifest.unnailed", "$manifest") {
my $toml = toml_or_enoent($try, "package manifest") // next;
my $p = $toml->{package}{name};
if (!defined $p) {
print STDERR
"$self: warning: $subdir: missing package.name in $try, ignoring\n";
next;
}
$manifests{$manifest} = $toml;
return $p;
}
return undef;
}
sub readorigs () {
foreach my $p (keys %{ $nail->{packages} }) {
my $v = $nail->{packages}{$p};
my $subdir = ref($v) ? $v->{subdir} : $v;
my $gotpackage = read_manifest($subdir) // '';
if ($gotpackage ne $p) {
print STDERR
"$self: warning: honouring Cargo.nail packages.$subdir=$p even though $subdir contains package $gotpackage!\n";
}
die if defined $packagemap{$p};
$packagemap{$p} = $subdir;
}
foreach my $subdir (@{ $nail->{subdirs} }) {
my $gotpackage = read_manifest($subdir);
if (!defined $gotpackage) {
print STDERR
"$self: warning: ignoring subdir $subdir which has no Cargo.toml\n";
next;
}
$packagemap{$gotpackage} //= $subdir;
}
}
sub calculate () {
foreach my $p (sort keys %packagemap) {
print STDERR "$self: package $p in $packagemap{$p}\n" if $verbose>=2;
}
foreach my $mf (keys %manifests) {
my $toml = $manifests{$mf};
foreach my $k (qw(dependencies build-dependencies dev-dependencies)) {
my $deps = $toml->{$k};
next unless $deps;
foreach my $p (keys %packagemap) {
my $info = $deps->{$p};
next unless defined $info;
$deps->{$p} = $info = { } unless ref $info;
delete $info->{version};
$info->{path} = $worksphere.'/'.$packagemap{$p};
}
}
my $nailing = "$mf.nailing~";
unlink_or_enoent $nailing or die "$self: remove old $nailing: $!\n";
open N, '>', $nailing or die "$self: create new $nailing: $!\n";
print N to_toml($toml) or die "$self: write new $nailing: $!\n";
close N or die "$self: close new $nailing: $!\n";
}
}
sub addargs () {
if (@ARGV>=2 &&
$ARGV[0] =~ m{\bcargo\b} &&
$ARGV[1] =~ m/generate-lockfile|update/) {
$cargo_lock_update //= 1;
} else {
$cargo_lock_update //= 0;
}
$cargo_manifest_args //=
(defined $oot_dir) && !$cargo_lock_update;
if ($cargo_manifest_args) {
push @ARGV, "--manifest-path=${src_absdir}/Cargo.toml",
qw(--locked --target-dir=target);
}
if (defined $target) {
if ($target =~ m{^[A-Z]}) {
$target = (cfgs 'arch', $target) // $archmap{$target}
// die "$self: --target=$target alias specified; not in cfg or map\n";
}
push @ARGV, "--target=$target";
}
}
our $oot_absdir;
our $build_absdir; # .../Build/
sub oot_massage_cmdline () {
return unless defined $oot_dir;
my $use = cfgs qw(oot use);
$oot_absdir = ($oot_dir !~ m{^/} ? "$worksphere/" : ""). $oot_dir;
$build_absdir = "$oot_absdir/$subdir";
my ($pre,$post);
my @xargs;
if (!$cargo_lock_update) {
push @xargs, $build_absdir;
($pre, $post) = ('cd "$1"; shift; ', '');
} else {
push @xargs, $oot_absdir, $subdir, $src_absdir;
$pre = <<'END';
cd "$1"; shift;
mkdir -p -- "$1"; cd "$1"; shift;
cp -- "$1"/Cargo.toml
END
$pre .= <<'ENDLK' if stat_exists 'Cargo.lock', 'working cargo lockfile';
"$1"/Cargo.lock
ENDLK
$pre .= <<'ENDCP';
.;
ENDCP
$pre .= <<'ENDPRE';
shift;
mkdir -p src; >src/lib.rs;
ENDPRE
$post = <<'ENDPOST';
rm -r src Cargo.toml;
ENDPOST
}
my $addpath = (cfg_uc qw(oot path_add)) //
$use eq 'really' ? Types::Serialiser::true : Types::Serialiser::false;
$addpath =
!Types::Serialiser::is_bool $addpath ? $addpath :
$addpath ? '$HOME/.cargo/bin' :
undef;
if (defined $addpath) {
$pre .= <= 2 ? 'xe' : 'e';
my $sh_ec = sub {
if (!length $post) {
@command = (@_, 'sh',"-${xe}c",$pre.'exec "$@"','--',@xargs);
} else {
@command = (@_, 'sh',"-${xe}c",$pre.'"$@"; '.$post,'--',@xargs);
}
push @command, @ARGV;
};
my $command_sh = sub {
my $quoted = join ' ', map {
return $_ if !m/\W/;
s/\'/\'\\'\'/g;
"'$_'"
} @ARGV;
@command = @_, "set -${xe}; $pre $quoted; $post";
};
print STDERR "$self: out-of-tree, building in: \`$build_absdir'\n"
if $verbose;
if ($use eq 'really') {
my $user = $getuser->();
my @pw = getpwnam $user or die "$self: oot.user \`$user' lookup failed\n";
my $homedir = $pw[7];
$sh_ec->('really','-u',$user,'env',"HOME=$homedir");
print STDERR "$self: using really to run as user \`$user'\n" if $verbose;
} elsif ($use eq 'ssh') {
my $user = $getuser->();
$user .= '@localhost' unless $user =~ m/\@/;
$command_sh->('ssh',$user);
print STDERR "$self: using ssh to run as \`$user'\n" if $verbose;
} elsif ($use eq 'command_args') {
my @c = cfgn_list qw(oot command);
$sh_ec->(@c);
print STDERR "$self: out-of-tree, adverbial command: @c\n" if $verbose;
} elsif ($use eq 'command_sh') {
my @c = cfgn_list qw(oot command);
$command_sh->(@c);
print STDERR "$self: out-of-tree, ssh'ish command: @c\n" if $verbose;
} elsif ($use eq 'null') {
$sh_ec->();
} else {
die "$self: oot.use mode $use not recognised\n";
}
die unless @command;
@ARGV = @command;
}
sub setenvs () {
$ENV{NAILINGCARGO_WORKSPHERE} = $worksphere;
$ENV{NAILINGCARGO_MANIFEST_DIR} = $src_absdir;
$ENV{NAILINGCARGO_BUILDSPHERE} = $oot_absdir;
delete $ENV{NAILINGCARGO_BUILDSPHERE} unless $oot_absdir;
$ENV{NAILINGCARGO_BUILD_DIR} = $build_absdir // $src_absdir;
}
our $want_uninstall;
END {
if ($want_uninstall) {
local ($?);
foreach my $mf (keys %manifests) {
eval { uninstall1($mf,1); 1; } or warn "$@";
}
eval { unaltcargolock(1); 1; } or warn "$@";
}
}
our $cleanup_cargo_lock;
sub makebackups () {
foreach my $mf (keys %manifests) {
link "$mf", "$mf.unnailed" or $!==EEXIST
or die "$self: make backup link $mf.unnailed: $!\n";
}
if (defined($alt_cargo_lock)) {
if (@alt_cargo_lock_stat) {
print STDERR "$self: using alt_cargo_lock `$alt_cargo_lock'..."
if $verbose>=3;
if (link $alt_cargo_lock, 'Cargo.lock') {
print STDERR " linked\n" if $verbose>=3;
} elsif ($! != EEXIST) {
print STDERR "\n" if $verbose>=3;
die "$self: make \`Cargo.lock' available as \`$alt_cargo_lock': $!\n";
} else {
print STDERR "checking quality." if $verbose>=3;
my @lock_stat = stat 'Cargo.lock'
or die "$self: stat Cargo.lock (for alt check: $!\n";
same_file(\@alt_cargo_lock_stat, \@lock_stat)
or die
"$self: \`Cargo.lock' and alt file \`$alt_cargo_lock' both exist and are not the same file!\n";
}
$cleanup_cargo_lock = 1;
} else {
$cleanup_cargo_lock = 1;
# If Cargo.lock exists and alt doesn't, that means either
# that a previous run was interrupted, or that the user has
# messed up.
}
}
}
sub nailed ($) {
my ($mf) = @_;
my $nailed = "$mf.nailed~"; $nailed =~ s{/([^/]+)$}{/.$1} or die;
$nailed;
}
sub install () {
foreach my $mf (keys %manifests) {
my $nailing = "$mf.nailing~";
my $nailed = nailed($mf);
my ($use, $rm);
my $diff;
if (open NN, '<', $nailed) {
$diff = compare($nailing, \*NN);
die "$self: compare $nailing and $nailed: $!" if $diff<0;
} else {
$!==ENOENT or die "$self: check previous $nailed: $!\n";
$diff = 1;
}
if ($diff) {
$use = $nailing;
$rm = $nailed;
} else {
$use = $nailed;
$rm = $nailing;
}
rename $use, $mf or die "$self: install nailed $use: $!\n";
unlink_or_enoent $rm or die "$self: remove old $rm: $!\n";
print STDERR "$self: nailed $mf\n" if $verbose>=3;
}
}
sub invoke () {
my $r = system @ARGV;
if (!$r) {
return 0;
} elsif ($r<0) {
print STDERR "$self: could not execute $ARGV[0]: $!\n";
return 127;
} elsif ($r & 0xff00) {
print STDERR "$self: $ARGV[0] failed (exit status $r)\n";
return $r >> 8;
} else {
print STDERR "$self: $ARGV[0] died due to signal! (wait status $r)\n";
return 125;
}
}
sub cargo_lock_update_after () {
if ($cargo_lock_update) {
# avoids importing File::Copy and the error handling is about as good
$!=0; $?=0;
my $r= system qw(cp --), "$build_absdir/Cargo.lock", "Cargo.lock";
die "$self: run cp: $! $?" if $r<0 || $r & 0xff;
die "$self: failed to update local Cargo.lock (wait status $r)\n" if $r;
}
}
sub uninstall1 ($$) {
my ($mf, $enoentok) = @_;
my $unnailed = "$mf.unnailed";
rename $unnailed, $mf or ($enoentok && $!==ENOENT)
or die "$self: failed to restore: rename $unnailed back to $mf: $!\n";
}
sub unaltcargolock ($) {
my ($enoentok) = @_;
return unless $cleanup_cargo_lock;
die 'internal error!' unless defined $alt_cargo_lock;
# we ignore $enoentok because we don't know if one was supposed to
# have been created.
rename('Cargo.lock', $alt_cargo_lock) or $!==ENOENT or die
"$self: cleanup: rename possibly-updated \`Cargo.lock' to \`$alt_cargo_lock': $!\n";
unlink 'Cargo.lock' or $!==ENOENT or die
"$self: cleanup: remove \`Cargo.lock' in favour of \`$alt_cargo_lock': $!\n";
# ^ this also helps clean up the stupid rename() corner case
}
sub uninstall () {
foreach my $mf (keys %manifests) {
my $nailed = nailed($mf);
link $mf, $nailed or die "$self: preserve (link) $mf as $nailed: $!\n";
uninstall1($mf,0);
}
unaltcargolock(0);
}
while (@ARGV && $ARGV[0] =~ m/^-/) {
$_ = shift @ARGV;
last if m{^--$};
if (m{^-[^-]}) {
while (m{^-.}) {
if (s{^-v}{-}) {
$verbose++;
} elsif (s{^-q}{-}) {
$verbose=0;
} elsif (s{^-n}{-}) {
$noact++;
} elsif (s{^-D}{-}) {
$dump++;
} elsif (s{^-T(.+)}{-}s) {
$target = $1;
} elsif (s{^-([uU])}{-}) {
$cargo_lock_update= $1=~m/[a-z]/;
} elsif (s{^-([mM])}{-}) {
$cargo_manifest_args= $1=~m/[a-z]/;
} else {
die "$self: unknown short option(s) $_\n";
}
}
} elsif (s{^--target=}{}) {
$target = $_;
} elsif (m{^--(no-)?cargo-lock-update}) {
$cargo_lock_update= !!$1;
} elsif (m{^--(no-)?cargo-manifest-args}) {
$cargo_manifest_args= !!$1;
} else {
die "$self: unknown long option $_\n";
}
}
die "$self: need command to run\n" unless @ARGV || $noact;
takelock();
readnail();
consider_alt_cargo_lock();
consider_oot();
readorigs();
calculate();
addargs();
our @display_cmd = @ARGV;
oot_massage_cmdline();
setenvs();
if ($dump) {
eval '
use Data::Dumper;
print STDERR Dumper(\%manifests) if $dump>=2;
print STDERR Dumper(\%packagemap, \@ARGV,
{ src_absdir => $src_absdir,
worksphere => $worksphere,
subdir => $subdir,
oot_dir => $oot_dir,
oot_absdir => $oot_absdir,
build_absdir => $build_absdir });
' or die $@;
}
exit 0 if $noact;
$want_uninstall = 1;
makebackups();
install();
printf STDERR "$self: nailed (%s manifests, %s packages)%s\n",
(scalar keys %manifests), (scalar keys %packagemap),
(defined($alt_cargo_lock) and ", using `$alt_cargo_lock'")
if $verbose;
print STDERR "$self: invoking: @display_cmd\n" if $verbose;
my $estatus = invoke();
cargo_lock_update_after();
uninstall();
$want_uninstall = 0;
print STDERR "$self: unnailed. status $estatus.\n" if $verbose;
exit $estatus;