scripts/mailbot

   1 #!/usr/bin/perl
   2 # Mail robot for processing of PCI ID submissions
   3 # (c) 2001--2002 Martin Mares <mj@ucw.cz>
   4 # 2008 Michal Vaner <vorner@ucw.cz>
   5
   6 use Mail::Header;
   7 use Getopt::Long;
   8 use IO::Handle;
   9 BEGIN {
  10         unshift @INC, ".";
  11 }
  12 use PciIds::Db;
  13 use PciIds::Log;
  14 use PciIds::Notifications;
  15 use PciIds::DBQ;
  16
  17 my $patch = 0;
  18 my $emulate = 0;
  19 my $debug = 0;
  20 my $original = "";
  21 my $author = "";
  22 GetOptions(
  23         'patch!' => \$patch,
  24         'emulate!' => \$emulate,
  25         'debug!' => \$debug,
  26         'orig=s' => \$original,
  27         'author=s' => \$author
  28 ) || die "Usage: mailbot [--patch] [--emulate] [--debug] [--orig <name>] [--author <mailaddr>]";
  29
  30 my $reply = "";
  31 my $reply_plain = "";
  32 my $msgid = "";
  33 my $subject = "";
  34 my $tables = PciIds::DBQ::new( connectDb() );
  35
  36 my $hasAuth = $tables->dbh()->prepare( 'SELECT id FROM users WHERE email = ?' );
  37 my $addAuth = $tables->dbh()->prepare( "INSERT INTO users (email, passwd) VALUES(?, '')" );
  38 my $hasItem = $tables->dbh()->prepare( "SELECT 1 FROM locations WHERE id = ?" );
  39 my $addItem = $tables->dbh()->prepare( "INSERT INTO locations (id, parent) VALUES (?, ?)" );
  40 my $addComment = $tables->dbh()->prepare( "INSERT INTO history (owner, location, discussion, nodename, nodenote) VALUES (?, ?, ?, ?, ?)" );
  41
  42 sub getAuthor( $ ) {
  43         my( $mail ) = @_;
  44         $hasAuth->execute( $mail );
  45         if( my( $id ) = $hasAuth->fetchrow_array ) {
  46                 tlog( "mailbot: Active user ($mail) id: $nid" );
  47                 return $id;
  48         } else {
  49                 tlog( "mailbot: Creating user $mail" );
  50                 $addAuth->execute( $mail );
  51                 my $nid = $tables->dbh->last_insert_id( undef, undef, undef, undef );
  52                 tlog( "mailbot: Active user ($mail) id: $nid" );
  53                 return $nid;
  54         }
  55 }
  56
  57 sub submitItem( $$$$$ ) {
  58         my( $id, $name, $description, $text, $author ) = @_;
  59         my $created;
  60         $id =~ s/(.{8})(.+)/$1\/$2/;
  61         $id =~ s/(.{4})(.+)/$1\/$2/;
  62         $id = "PC/$id";
  63         if( length $id > 12 ) {
  64                 my( $vendor ) = ( $id =~ /^PC\/....\/....\/(....)/ );
  65                 $vendor = "PC/$vendor";
  66                 $hasItem->execute( $vendor );
  67                 error( "Missing subsystem vendor" ) unless( $hasItem->fetchrow_array );
  68         }
  69         $hasItem->execute( $id );
  70         unless( $hasItem->fetchrow_array ) {
  71                 tlog( "mailbot: Item created (empty) $id" );
  72                 my $parent = $id;
  73                 $parent =~ s/\/[^\/]*$//;
  74                 $addItem->execute( $id, $parent );
  75                 $created = 1;
  76         }
  77         $addComment->execute( $author, $id, $text, $name, $description );
  78         my $hid = $tables->last();
  79         tlog( "mailbot: History created $hid $id ".logEscape( $name )." ".logEscape( $description )." ".logEscape( $text ) );
  80         notify( $tables, $id, $hid, $created ? 2 : 1, $created ? 0 : 1 );
  81 }
  82
  83 if (!$patch) {
  84         $hdr = new Mail::Header;
  85         $hdr->modify(1);
  86         $hdr->mail_from(COERCE);
  87         $hdr->read(*STDIN{IO});
  88         $hdr->unfold();
  89         $mfrom = $hdr->get('Mail-From');
  90         chomp $mfrom;
  91         ($mfrom =~ /^MAILER-DAEMON@/i) && blackhole("From mailer daemon");
  92         $mfrom =~ s/  .*// or blackhole("Malformed envelope sender");
  93         ($reply = $hdr->get('Reply-To')) || ($reply = $hdr->get('From')) ||
  94                 blackhole("Don't know who should I reply to");
  95         chomp $reply;
  96         if ($reply =~ /<(\S*)>/) {
  97                 $reply_plain = $1;
  98         } elsif ($reply =~ /^\S+$/) {
  99                 $reply_plain = $reply;
 100         } else {
 101                 $reply_plain = $mfrom;
 102         }
 103         $reply_plain =~ tr/\n'"\\//d;
 104         $msgid = $hdr->get('Message-Id');
 105         chomp $msgid;
 106         my $subj = $hdr->get('Subject');
 107         chomp $subj;
 108         if ($subj =~ /^IDS: (.*)/) {
 109                 $subject = $1;
 110         }
 111         $author = $reply_plain;
 112 }
 113
 114 $tprefix = "tmp/mbot-$$";
 115 $home = "~/";
 116 mkdir("tmp", 0777);
 117 mkdir($tprefix, 0777) || error("Cannot create tmpdir");
 118 chdir($tprefix) || error("Cannot chdir to tmpdir");
 119
 120 open(TEMP, ">patch") || error("Cannot create tmpfile");
 121 if ($debug || $reply eq "") {
 122         open(LOG, ">&STDOUT") || error ("Cannot create outfile");
 123 } else {
 124         open(LOG, ">log") || error ("Cannot create outfile");
 125         LOG->autoflush(1);
 126 }
 127 if ($reply) {
 128         print LOG "Got mail from $reply, will reply to $reply_plain.\n";
 129         print LOG "Scanning mail for patch.\n";
 130 } else {
 131         print LOG "Scanning STDIN for patch.\n";
 132 }
 133 while (<STDIN>) {
 134         while (/^--- /) {
 135                 $l0 = $_;
 136                 $_ = <STDIN>;
 137                 if (/^\+\+\+ /) {
 138                         print TEMP $l0;
 139                         print TEMP $_;
 140                         while (1) {
 141                                 $_ = <STDIN>;
 142                                 chomp;
 143                                 if (/^\s*$/ || !/^[ +\@-]/) {
 144                                         close TEMP;
 145                                         process();
 146                                         exit 0;
 147                                 }
 148                                 print TEMP "$_\n";
 149                                 /^@@ -\d+,(\d+) \+\d+,(\d+) @@/ || error("Malformed patch");
 150                                 $old = $1;
 151                                 $new = $2;
 152                                 while ($old || $new) {
 153                                         $_ = <STDIN>;
 154                                         print TEMP $_;
 155                                         if (/^ /) { $old--; $new--; }
 156                                         elsif (/^-/) { $old--; }
 157                                         elsif (/^\+/) { $new--; }
 158                                         else { error("Malformed patch"); }
 159                                         if ($old<0 || $new<0) { error("Malformed patch"); }
 160                                 }
 161                         }
 162                 }
 163         }
 164 }
 165 error("No patch found");
 166
 167 sub cleanup
 168 {
 169         chdir($home);
 170         `rm -rf $tprefix` unless $debug;
 171         exit 0;
 172 }
 173
 174 sub blackhole
 175 {
 176         my $reason = shift @_;
 177         print STDERR "Blackholed: $reason\n";
 178         cleanup();
 179 }
 180
 181 sub error
 182 {
 183         my $reason = shift @_;
 184         print LOG "$reason\n";
 185         mail_reply($reason);
 186         cleanup();
 187 }
 188
 189 sub process
 190 {
 191         print LOG "Patch found.\n";
 192         print LOG "Searching for original pci.ids version.\n";
 193         foreach $orig (($original eq "") ? glob("$home/origs/*") : ("../../$original")) {
 194                 print LOG "Trying $orig\n";
 195                 unlink "pci.ids";
 196                 unlink "pci.rej";
 197                 print LOG `/usr/bin/patch <patch --no-backup -o pci.ids -r pci.rej $orig`;
 198                 if ($?) {
 199                         print LOG "Failed.\n";
 200                 } else {
 201                         print LOG "Patch succeeded.\n";
 202                         print LOG "Parsing patched file.\n";
 203                         print LOG `$home/bin/ids_to_dbdump <$orig 2>&1 >orig.db.unsorted`;
 204                         $? && error("Error parsing original ID database");
 205                         print LOG `sort +1 <orig.db.unsorted >orig.db`;
 206                         $? && error("Error sorting original ID database");
 207                         print LOG `$home/bin/ids_to_dbdump <pci.ids 2>&1 >new.db.unsorted`;
 208                         $? && error("Error parsing the patched pci.ids file");
 209                         print LOG `sort +1 <new.db.unsorted >new.db`;
 210                         $? && error("Error sorting the patched pci.ids file");
 211                         print LOG "Finding ID differences.\n";
 212                         `diff -U0 new.db orig.db >diffs`;
 213                         if ($? > 256) { error("Diff failed. Why?"); }
 214                         elsif (!$?) { error("No ID changes encountered."); }
 215                         open(DIFF, "diffs") || error("Cannot open the diff");
 216                         $subject = undef if $subject eq '';
 217                         my $authorId = getAuthor( $author );
 218                         my $live = (!$emulate && !$debug);
 219                         while (<DIFF>) {
 220                                 chomp;
 221                                 /^(\+\+\+|---)/ && next;
 222                                 /^[+-]/ || next;
 223                                 ($tt,$id,$name,$stat,$cmt) = split /\t/;
 224                                 if ($tt =~ /^\+(.*)/) {
 225                                         defined $seen{$id} && next;
 226                                         $name = $cmt = "";
 227                                 } elsif ($tt =~ /^-(.*)/) {
 228                                         $seen{$id} = 1;
 229                                 } else { error("Internal bug #23"); }
 230                                 print LOG "$id\t$name\t$cmt\n";
 231                                 submitItem( $id, $name, $cmt, $subject, $authorId ) if $live;
 232                         }
 233                         $tables->dbh->commit();
 234                         close DIFF;
 235                         $time = localtime;
 236                         `echo >>$home/mailbot.log "## $time $reply"`;
 237                         `cat result >>$home/mailbot.log`;
 238                         print LOG "Done.\n";
 239                         mail_reply("OK");
 240                         cleanup();
 241                 }
 242         }
 243         error("Unable to find any version of pci.ids the patch applies to.");
 244 }
 245
 246 sub mail_reply
 247 {
 248         my $reason = shift @_;
 249         my $sendmail_opts = "-fvorner+iderr\@ucw.cz '$reply_plain' vorner+idecho\@ucw.cz";
 250         if ($debug || $reply eq "") {
 251                 print "$reason\n";
 252                 return;
 253         } elsif ($emulate) {
 254                 open(MAIL, ">&STDOUT") || die;
 255                 print MAIL "SENDMAIL $sendmail_opts\n";
 256         } elsif (!open MAIL, "|/usr/sbin/sendmail $sendmail_opts") {
 257                 print STDERR "Unable to ask mailer for replying!!!\n";
 258                 print LOG "Unable to ask mailer for replying!!!\n";
 259                 exit 1;
 260         }
 261         print MAIL "From: The PCI ID Robot <vorner+iderr\@ucw.cz>\n";
 262         print MAIL "To: $reply\n";
 263         print MAIL "Subject: IDbot: $reason\n";
 264         print MAIL "In-Reply-To: $msgid\n" if $msgid ne "";
 265         print MAIL "\n";
 266         print MAIL <<EOF
 267 This is an automatic reply from the PCI ID Mail Robot. If you want to contact
 268 the administrator of the robot, please write to pciids-devel\@lists.sourceforge.net.
 269
 270 EOF
 271 ;
 272         if ($reason eq "OK") {
 273                 print MAIL "Your submission has been accepted.\n\n";
 274         } else {
 275                 print MAIL <<EOF
 276 Your submission has been rejected. Please make sure that the mail you've sent
 277 is a unified diff (output of diff -u) against the latest pci.ids file, that
 278 the diff is not reversed and that your mailer doesn't damage long lines
 279 and doesn't change tabs to spaces or vice versa. Also, we don't accept MIME
 280 attachments in base64 encoding yet. If you are unable to fix your problems,
 281 just use the Web interface at http://pciids.sf.net/ or submit the patch
 282 to pciids-devel\@lists.sourceforge.net where it will be processed manually.
 283 See the log below for additional information.
 284
 285 EOF
 286 ;
 287         }
 288         print MAIL "--- Processing Log ---\n\n";
 289         if (open L, "<log") {
 290                 while (<L>) { print MAIL "$_"; }
 291                 close L;
 292         }
 293         print MAIL "\n--- End ---\n";
 294         close MAIL;
 295 }
 296
 297 sub url_encode
 298 {
 299         $_ = shift @_;
 300         s/([^a-zA-Z0-9.!*,_-])/'%'.unpack('H2',$1)/ge;
 301         s/%20/+/g;
 302         $_;
 303 }