#!/usr/bin/perl

=encoding utf8

=cut

use warnings;
use strict;

use IO::File;
use IPC::Run qw(run);
use Getopt::Long;
use Mail::Sendmail;
use Pod::Usage;
use Sys::Hostname::Long;

my %opt = (
    'run-lintian' => 1,
);

GetOptions(
    "l|run-lintian"     => \$opt{'run-lintian'},
    "h|help"            => sub { pod2usage(-exit => 0, -verbose => 1) },
    "m|man"             => sub {
        pod2usage(
            -exit    => 0,
            -verbose => 2,

            # "system('perldoc -V &>/dev/null')" appears shorter, but may not
            # do what you expect ( it still returns 0 on debian squeeze with
            # dash as system shell even if cannot find the command in $PATH)
            -noperldoc => system('perldoc -V >/dev/null 2>&1')
        );
    }
) or pod2usage;

my $hostname = hostname_long;
for (*STDERR, *STDOUT) { select $_; $|=1; }

# see man reprepro
# used as argument to the -b option of reprepro
my $repo = "$ENV{HOME}/repo";

# the ruleset to use for processincoming
my $ruleset = "ius";

# the actual reprepro command to execute
my @cmd = ('/usr/bin/reprepro', '-b', $repo, 'processincoming', $ruleset);

# wont send any notification mails to anyone not matching this regexp
my $valid_receivers = '[@.]schlittermann.de>?$';

# anything noteworthy not sent to anyone else will be sent here; does not need
# to match $valid_receivers
my $fallback = "apt\@$hostname";

# any output not matching any of the defined patterns will be logged here if
# defined, dont forget to also pass the write mode, fex: "> /path/to/file" if
# you want to overwrite it or ">> /path/to/file" if you want to append to it
my $log_uncaught;
$log_uncaught = ">> $ENV{HOME}/var/log/reprepro/uncaught";

# raw command output will be logged here if defined, dont forget the write mode
# - see $log_uncaught
my $log_raw;
$log_raw = ">> $ENV{HOME}/var/log/reprepro/raw";

# anything that would be sent to the signer/changer/maintainer goes to
# $fallback instead if this is set
my $dont_send_to_real_uploader = 0;

# prototypes for message handling routines
sub m_mismatch($);
sub m_missingfile($$$);
sub m_mayexist($$$);
sub m_allskipped($);
sub m_equal_or_newer($$);
sub m_unsigned($);
sub m_asis();

# prototypes for other routines
sub parse_incoming($);
sub uploader($);
sub run_command_and_parse_output($$$$$$);
sub parse_output($$$$$$$$);
sub sendmails($$$$$);

# anything matching these is considered noteworthy and should be sent to someone
my $important = {
  qq{^File "([^"]+)" is already registered with different checksums!} => \&m_mismatch,
  "^file '([^']+)' is needed for '([^']+)', not yet registered in the pool and not found in '([^']+)'\$" => \&m_missingfile,
  "^Warning: trying to put version '([^']+)' of '([^']+)' in '([^']+)',\$" => \&m_mayexist,
  "^Skipping ([^ ]+) because all packages are skipped!\$" => \&m_allskipped,
  "^Data seems not to be signed trying to use directly...\$" => \&m_unsigned,
  "^Not putting '([^']+)' in '([^']+)' as already in there with equal or newer version.\$" => \&m_equal_or_newer,
#  "^ERROR: File '([^']+)' does not match expextations:\$" => \&m_asis,
#  "^In 'littlebird_2011072500-2_amd64.changes': file 'littlebird_2011072500.orig.tar.gz' not found in the incoming dir!" => \&m_asis,
# send *everything* for now
  "." => \&m_asis
};

# anything matching these will not be sent to anyone
my $unimportant = '^'
  . ( join '|',
    "Deleting files no longer referenced...",
    "Exporting indices...",
    "while there already is '[^']+' in there.",
    "(md5|sha(1|256)) expected: [[:xdigit:]]{32,}, got: [[:xdigit:]]{32,}",
    "size expected: \\d+, got: \\d+",
    "There have been errors!")
  . '$';

my $rci = "$repo/conf/incoming";
my $i = parse_incoming($rci)->{$ruleset}->{'IncomingDir'};
die "Can't find IncomingDir for ruleset [$ruleset] in configuration file: [$rci]\n" unless defined $i;

# we need to determine uploaders before running reprepro, because it will
# remove the *.changes files before we are going to parse its output
my $uploaders = { map { $_ => uploader($_) } glob("$i/*.changes") };
for my $c (keys %{$uploaders}) { sendmails ({ $uploaders->{$c} => scalar qx{lintian $c 2>&1} }, $valid_receivers, $fallback, $hostname, "[$hostname] Lintian Report"); }
my $messages = run_command_and_parse_output([@cmd], $uploaders, $important, $unimportant, $log_uncaught, $log_raw);
sendmails($messages, $valid_receivers, $fallback, $hostname, "[$hostname] Import Report");

# determine 'uploader' of changes file; 'uploader' means here: either the
# signer of the changes file or the changer or the maintainer in that order of
# preference; the 'changer' means what is extracted from the 'Changed-By' field
# of the .changes file if present; 'maintainer' will be extracted from the
# 'Maintainer' field if necessary; nothing will be returned if the signature
# verification command fails for some reason
sub uploader($) {
  my ($c) = @_;
  my $vc = "LANG=POSIX /usr/bin/gpg --verify $c 2>&1";

  my @r = qx{$vc};

  if ($?) {
    warn "[$0]: [$vc] failed: [$!] [$?]\n";
    return;
  }

  for (@r) {
    return "$1" if /^gpg: Good signature from "(.+)"$/;
  }

  my $e;
  my $fh = new IO::File "< $c" or warn "[$0]: Can't open [< $c]: $!\n";
  while (<$fh>) {
    if (/^Changed-By:\s*(\S.+\S)\s*$/) {
      $e = $1; last;
    }
    $e = $1 if /^Maintainer:\s*(\S.+\S)\s*$/
  }
  close $fh or warn "[$0]: Can't close [$fh]: $!\n";

  return $e;

}

# checksum mismatch
sub m_mismatch($) {
  return "Try to remove the offending lines from the changesfile or just rebuild with dpkg-buildpackage -B\n";
}

# missingfile
sub m_missingfile($$$) {
  my ($m, $i, $c) = @_;
  my $t = $m =~ /\.orig\.tar\.gz$/ ? "Try to rebuild with dpkg-buildpackage -sa or do 'changestool <.changes-filename> includeallsources' and resign the changesfile afterwards\n" : '';
  #print "MISSINGFILE: [$c], [$t]\n";
  return $t;
}

# mayexist
sub m_mayexist($$$) {
  # package & version are confused in reprepro output
  # currently (3.5.2-6)
  # my ($p, $v, $cca) = @_;
  # $cca =~ /^[^|]+\|[^|]+\|([^|]+)$/;

  #print "MAYEXIST: [$c], [package ..]\n";
  return "package may be already present with higher version\n";
}

# allskipped
sub m_allskipped($) {
  #print "ALLSKIPPED: [$_[0]], [nüx ..]\n";
  return "package may be already present with same or higher version\n";
}

# equal or newer
sub m_equal_or_newer($$) {
  #print "EQUAL_OR_NEWER: [$_[0]], [nüx ..]\n";
  return '';
}

# unsigned
sub m_unsigned($) { return 'You may want to check whether both the .changes and the .dsc file are signed'; }

# return empty string
sub m_asis() { return ''; }

# parse conf/incoming, return ref to hash:
# { name1 => { field11 => value11, field12 => value12, ... },
# { name2 => { field21 => value21, ... }, ...
sub parse_incoming($) {

  my ($cf) = @_;
  my ($name, $conf);
  my $fh = new IO::File "< $cf" or warn "Can't open [< $cf]: $!";

  while (<$fh>) { 

    if (/^(\S+)\s*:\s*(\S+)\s/) {

      if ($1 eq 'Name') {
	$name = $2;
	$conf->{$name} = {};
      } else {
	warn "Undefined Name\n" unless defined $name;
	$conf->{$name}->{$1} = $2;
      }

    }

  }
  close $fh or warn "Can't close [$fh]: $!\n";

  return $conf;

}

# run the command and parse its output
sub run_command_and_parse_output($$$$$$) {

  my @cmd = @{shift()};
  my ($u, $important, $unimportant, $luname, $lrname) = @_;

  my ($ih, $oh, $eh);

  run \@cmd, \$ih, \$oh, \$eh or warn "running [@cmd] returned: [$?] [$!]\n";

  my ($ln, $lh);
  $ln = { uncaught => $luname, raw => $lrname };

  for (keys %{$ln}) {
    if (defined $ln->{$_}) {
      $lh->{$_} = new IO::File $ln->{$_} or warn "Can't open [$ln->{$_}]: $!\n";
    }
  }

  my $messages = parse_output([@cmd], $oh, $eh, $u, $important, $unimportant, $lh->{'uncaught'}, $lh->{'raw'});
  
  for (keys %{$lh}) {
    if (defined $lh->{$_}) {
      close $lh->{$_} or warn "Can't close [$lh->{$_}]: $!";
    }
  }

  return $messages;

}

# parse the commands output extract messages matching the defined patterns from
# stdout/err, add suggestions for problem resolution if possible and try to
# assign it to an uploader
sub parse_output($$$$$$$$) {

  my @cmd = @{shift()};
  my ($oh, $eh, $u, $important, $unimportant, $uncaught, $raw) = @_;

  my ($m, $c, $f);

  $f = 'fallback';

  LINE:
  for my $line (split /\n/, $oh . $eh) {

    $line .= "\n";
    print "[@cmd]: $line";
    print $raw "[" . gmtime() . " +0000] $line" if defined $raw;

    # try to determine uploader
    if ($line =~ /^processing changesfile '([^']+)'$/) {
      $c = $1;
      $u = $uploaders->{$c};
      unless (defined $u) {

	$u = $f;
	my $w = "Won't send notification for [$i/$c] because i couldn't determine any uploader to sent it to.\n"; 
	$m->{$u} //= '';
	$m->{$u} .= "[$c]: $w";
	warn "[$0]: $w";

      }

      next LINE;

    }

    # done with that changesfile
    if ($line =~ /^changesfile '[^']+' done$/) { 
      undef $c;
      $u = $f;
      next LINE;
    }

    # anything matching $important should be sent to someone
    for (keys(%{$important})) {
      if ($line =~ $_) {
	my $t = $important->{$_}->($1, $2, $3, $4, $5, $6, $7, $8, $9);
	if (defined $u) {
	  $m->{$u} = '' unless defined $m->{$u};
	  $m->{$u} .= "[" . ( defined $c ? $c : "no changesfile" ) . "]: $line";
	  $m->{$u} .= $t if defined $t;
	  $m->{$u} .= "\n";
	}
	next LINE;
      }

    }

    # unimportant stuff?
    next LINE if $line =~ /$unimportant/;

    # everything not matching any other pattern
    $m->{$f} = '' unless defined $m->{$f};
    $m->{$f} .= "[uncaught line]: $line\n";

    print $uncaught "[" . gmtime() . " +0000] $line" if defined $uncaught;

  }

  return $m;

}

# send the notification mails
sub sendmails($$$$$) {

  my ($messages, $valid_receivers, $fallback, $hostname, $subject) = @_;

  my $from = "$ENV{LOGNAME}\@$hostname";
  my $mfb = $messages->{'fallback'};

  for my $u (keys %{$messages}) {

    next if $u eq 'fallback';

    if ($u =~ $valid_receivers) {

      my ($msg, $to) = ($messages->{$u}, $u);
      ($msg, $to) = ("[This is just a test mail to you. If this wasn't a test mail, then it should have been sent to [$u]]\n\n" . $messages->{$u}, $fallback) if $dont_send_to_real_uploader;

      sendmail(From => $from,
	Subject => $subject,
	To => $to,
	Message => $msg);
      print "[$0]: ", $Mail::Sendmail::log, "\n";
      warn "[$0]: ", $Mail::Sendmail::error, "\n" if $Mail::Sendmail::error;

    } else {

      my $w = "Won't send notification: invalid receiver [$u]\n\n";
      $mfb //= ''; $mfb .= $w; $mfb .= ">>>\n[$messages->{$u}]\n<<<\n\n";
      warn "[$0]: $w";

    }

  }

  if (defined $mfb) {

    sendmail(From => $from,
      Subject => "[apt] Possible Problem processing incoming",
      To => $fallback,
      Message => $mfb);
    print "[$0]: ", $Mail::Sendmail::log, "\n";
    warn "[$0]: ", $Mail::Sendmail::error, "\n" if $Mail::Sendmail::error;

  }

}

sub BEGIN {
  print "[$0]: Started at ", scalar localtime, "\n";
}

sub END {
  print "[$0]: Finished at ", scalar localtime, "\n";
}

__END__

=head1 NAME

rpi - a wrapper around B<reprepro processincoming>

=head1 SYNOPSIS

rpi

rpi -m|--man
    -h|--help

=head1 DESCRIPTION

Until B<reprepro> supports a better mechanism for sending notifications for
rejected packages we just execute B<reprepro processincoming> and parse its
stdout and its stderr. Everything matching C<$important> patterns will be sent
to either the signer of the changes file, the changer (from the B<Changed-By>
field if present) or the maintainer (from the B<Maintainer> field). Depending
on the type of message suggestions for problem resolution may be added. To
enable us to determine which message relates to which .changes file we need a
patched B<reprepro>: L<https://keller.schlittermann.de/hg/ius/diffs/raw-file/8d32753c0599/reprepro/3.5.2/changes-file-process-messages.patch>.

To avoid possibly bothering random people we can limit possible recipients with
a regular expression in C<$valid_receivers>. Any output matching the
C<$unimportant> regular expression will not be sent to anyone. If we cant
determine anyone to send the notification to we will try to send it to the
C<$fallback> address. Anything matching none of the defined patterns will be
sent to the C<$fallback> address too. Everything will be printed to stdout.

=head1 OPTIONS

=over

=item B<-l>|B<--[no]run-lintian>

Do or don't run lintian on each changesfile an try to mail results to uploader. (default: do)

=back

=head1 AUTHORS

Matthias Förste L<<foerste@schlittermann.de>>

=cut
