diff -r 000000000000 -r 98411ab74262 bin/rpi
--- /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";
+}