--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/bin/rpi Fri Jul 03 15:23:10 2009 +0200
@@ -0,0 +1,410 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use IO::File;
+use IPC::Run qw(run);
+use Mail::Sendmail;
+use Sys::Hostname::Long;
+
+=head1 Name
+
+rpi - a wrapper around B<reprepro processincoming>
+
+=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>:
+
+ --- incoming.c.orig 2009-06-11 10:48:27.000000000 +0200
+ +++ reprepro-3.5.2/incoming.c 2009-06-11 14:29:28.000000000 +0200
+ @@ -1854,6 +1854,8 @@
+ for( j = 0 ; j < i->files.count ; j ++ ) {
+ const char *basename = i->files.values[j];
+ size_t l = strlen(basename);
+ + char *fullfilename;
+ +
+ #define C_SUFFIX ".changes"
+ #define C_LEN strlen(C_SUFFIX)
+ if( l <= C_LEN || strcmp(basename+(l-C_LEN),C_SUFFIX) != 0 )
+ @@ -1861,7 +1863,16 @@
+ if( changesfilename != NULL && strcmp(basename, changesfilename) != 0 )
+ continue;
+ /* a .changes file, check it */
+ + fullfilename = calc_dirconcat(i->directory, i->files.values[j]);
+ + if( fullfilename == NULL ) {
+ + result = RET_ERROR_OOM;
+ + continue;
+ + }
+ + printf("processing changesfile '%s'\n", fullfilename);
+ + fprintf(stderr, "processing changesfile '%s'\n", fullfilename);
+ r = process_changes(database, dereferenced, i, j);
+ + printf("changesfile '%s' done\n", fullfilename);
+ + fprintf(stderr, "changesfile '%s' done\n", fullfilename);
+ RET_UPDATE(result, r);
+ }
+
+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.
+
+=cut
+
+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 = 1;
+
+# 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,
+ "^ERROR: File '([^']+)' does not match expextations:\$" => \&m_asis,
+ "^Not putting '([^']+)' in '([^']+)' as already in there with equal or newer version.\$" => \&m_equal_or_newer
+};
+
+# anything matching these will not be sent to anyone
+my $unimportant = '^'
+ . ( join '|',
+ "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") };
+my $messages = run_command_and_parse_output([@cmd], $uploaders, $important, $unimportant, $log_uncaught, $log_raw);
+sendmails($messages, $valid_receivers, $fallback, $hostname);
+
+# 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 $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} .= "[$c]: $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 $line if defined $uncaught;
+
+ }
+
+ return $m;
+
+}
+
+# send the notification mails
+sub sendmails($$$$) {
+
+ my ($messages, $valid_receivers, $fallback, $hostname) = @_;
+
+ 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 => "[apt] Possible Problem importing your changes",
+ 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";
+}