#!/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") };
if ($opt{'run-lintian'}) {
    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
