#!/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 <http://www.gnu.org/licenses/>.

# 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

use strict;
use TOML::Tiny::Faithful;
use POSIX;
use Fcntl qw(LOCK_EX);
use File::Compare;

my $self = $0;  $self =~ s{^.*/(?=.)}{};

our $worksphere = getcwd() // die "$self: getcwd failed: $!\n";
$worksphere =~ s{/[^/]+$}{} or die "$self: cwd \`$worksphere' unsupported!\n";
our $lockfile = "../.nailing-cargo-sphere.lock";

our @configs;
our $verbose=1;
our ($noact,$dump);

sub read_or_enoent ($) {
    my ($fn) = @_;
    if (!open R, '<', $fn) {
	return undef if $!==ENOENT;
	die "$self: open $fn: $!\n";
    }
    local ($/) = undef;
    my ($r) = <R> // die "$self: read $fn: $!\n";
    $r;
}

sub toml_or_enoent ($$) {
    my ($f,$what) = @_;
    my $toml = read_or_enoent($f) // return;
    my ($v,$e) = from_toml($toml);
    die "$self: parse TOML: $what: $f: $e\n" unless defined $v;
    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 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 "@fstat[0..5]" eq "@stat[0..5]";
    }
}
sub unlock () {
    unlink $lockfile or die "$self: removing lockfile: $!\n";
}

our $nail;

sub readnail () {
    my $nailfile = "../Cargo.nail";
    open N, '<', $nailfile or die "$self: open $nailfile: $!\n";
    local ($/) = undef;
    my $toml = <N> // 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";
	}
	die "$self: parse $nailfile: $e\n";
    }
    die "$e ?" if length $e;
}

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) // '<nothing!>';
	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 $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";
    }
}

our $want_uninstall;

END {
    if ($want_uninstall) {
	local ($?);
	foreach my $mf (keys %manifests) {
	    eval { uninstall1($mf,1); 1; } or warn "$@";
	}
    }
}

sub makebackups () {
    foreach my $mf (keys %manifests) {
	link "$mf", "$mf.unnailed" or $!==EEXIST
	    or die "$self: make backup link $mf.unnailed: $!\n";
    }
}

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 "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 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 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);
    }
}

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++;
	    } else {
		die "$self: unknown short option(s) $_\n";
	    }
	}
    } else {
	die "$self: unknown long option $_\n";
    }
}

takelock();
readnail();
readorigs();
calculate();

if ($dump) {
    eval '
        use Data::Dumper;
        print STDERR Dumper(\%manifests, \%packagemap);
    ' or die $@;
}

exit 0 if $noact;

$want_uninstall = 1;
makebackups();
install();

printf STDERR "$self: Nailed (%d manifests, %d packages)\n",
    (scalar %manifests, scalar %packagemap)
    if $verbose;

my $estatus = invoke();

uninstall();
$want_uninstall = 1;
print STDERR "$self: Unnailed.\n" if $verbose;

exit $estatus;