#!/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

our $self;

use strict;
use POSIX;

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 $oot_cargo_lock_faff;

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);
  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 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 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 cfg {
  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 @_;
  (cfg $exp, @_) // badcfg @_, "missing";
}

sub cfgs  { cfg  'scalar', @_ }
sub cfgsn { cfgn 'scalar', @_ }

sub cfgn_list {
  my $l = cfg '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 = <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";
    }
    $/="\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 %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 $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";
  }
}

our @out_command;

our $oot_dir;      # oot.dir or "Build"
our $oot_absdir;

our $build_absdir; # .../Build/<subdir>

sub calculate_oot () {
  $oot_dir = cfgs qw(oot dir);
  my $use = cfgs qw(oot use);
  return unless defined($oot_dir) || defined($use);
  $oot_dir //= 'Build';

  if (@ARGV && $ARGV[0] =~ m/generate-lockfile|update/) {
    $oot_cargo_lock_faff = 1;
  }

  $oot_absdir = ($oot_dir !~ m{^/} ? "$worksphere/" : ""). $oot_dir;
  $build_absdir = "$oot_absdir/$subdir";

  my ($pre,$post);
  my @xargs;
  if (!$oot_cargo_lock_faff) {
    push @xargs, $build_absdir;
    ($pre, $post) = ('cd "$1"; shift;', '');
  } else {
    push @xargs, $build_absdir, $subdir, $src_absdir;
    ($pre, $post) = (<<'END', <<'END');
        cd "$1"; shift;
        mkdir -p -- "$1"; cd "$1"; shift;
        cp -- "$1"/Cargo.toml "$1"/Cargo.lock .; shift;
        mkdir -p src; >src/lib.rs;
END
        rm -r src Cargo.toml;
END
    $pre  =~ s/^\s+//mg; $pre  =~ s/^\s+\n/ /g;
    $post =~ s/^\s+//mg; $post =~ s/^\s+\n/ /g;
  }
  my $getuser = sub { cfgsn qw(oot user) };
  my @command;
  my $xe = $verbose >= 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";
  };
  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");
  } elsif ($use eq 'ssh') {
    my $user = $getuser->();
    $user .= '@localhost' unless $user =~ m/\@/;
    $command_sh->('ssh',$user);
  } elsif ($use eq 'command_sh') {
    $command_sh->(cfgn_list qw(oot command));
  } elsif ($use eq 'command_args') {
    $sh_ec->(cfgn_list qw(oot command))
  } else {
    die "$self: oot.use mode $use not recognised\n";
  }
  die unless @command;
  @ARGV = @command;
}

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

die "$self: need command to run\n" unless @ARGV || $noact;

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

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

exit 0 if $noact;

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

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

my $estatus = invoke();

uninstall();
$want_uninstall = 1;

get_cargo_lock() if $oot_cargo_lock_faff;

print STDERR "$self: unnailed.  status $estatus.\n" if $verbose;

exit $estatus;