/[qa]/trunk/pts/bin/dispatch.pl
ViewVC logotype

Diff of /trunk/pts/bin/dispatch.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 283 by hertzog, Fri Feb 1 07:00:57 2002 UTC revision 590 by hertzog, Tue Jun 10 21:36:23 2003 UTC
# Line 5  Line 5 
5  # or (at your option) any later version  # or (at your option) any later version
6    
7  use lib '/org/packages.qa.debian.org/perl';  use lib '/org/packages.qa.debian.org/perl';
8    use lib '/home/rhertzog/cvs/pts/perl';
9    
10  use Mail::Internet;  use Mail::Internet;
11  use Mail::Address;  use Mail::Address;
12  use DB_File;  use DB_File;
13    
14  use strict;  use strict;
15    use vars qw($db $sendmail);
16    
17  =head1 Script for *@packages.qa.debian.org  =head1 Script for *@packages.qa.debian.org
18    
# Line 20  This script needs libmailtools-perl. Line 22  This script needs libmailtools-perl.
22    
23  =cut  =cut
24    
25  # Configuration variables  require "common.pl";
26  my $db_filename = "/org/packages.qa.debian.org/db/subscription.db";  
27    # Local configuration variables
28  my $nb_by_group = 20; # Number of emails sent together (in the same sendmail)  my $nb_by_group = 20; # Number of emails sent together (in the same sendmail)
 my $sendmail = '/usr/sbin/sendmail -f owner@packages.qa.debian.org';  
29  my $debug = 0;  my $debug = 0;
30    my $spamc = '';
31  # Global variables  my $needs_approval = 1;
 my %db_content;  
 my $db;  
32    
33  # Get the package name  # Get the package name
34  my $package = lc($ENV{'LOCAL_PART'}); # Exim sets that ...  my $package = lc($ENV{'LOCAL_PART'}); # Exim sets that ...
35  $package = lc(shift @ARGV) if ($debug && defined($ARGV[0]) && $ARGV[0]); #  $package = lc(shift @ARGV) if ($debug && defined($ARGV[0]) && $ARGV[0]); #
36  die "Aren't you exim ?" if (! (defined($package) && $package));  die "Aren't you exim ?" if (! (defined($package) && $package));
37    
38    # Get the keyword name
39    my $keyword = '';
40    if ($package =~ /(\S+)_(\S+)/) {
41        $package = $1;
42        $keyword = $2;
43    }
44    
45  # Get the list of subscribers  # Get the list of subscribers
46  open_db();  open_db_read();
47  my @emails = $db->get_dup($package);  my @emails = $db->get_dup($package);
48  exit 0 if (! scalar(@emails)); # Don't parse anything if nobody is subscribed  exit 0 if (! scalar(@emails)); # Don't parse anything if nobody is subscribed
 close_db();  
49    
50  # Parse the mail  # Parse the mail
51  my $mail = Mail::Internet->new(\*STDIN) or die "Parse failed !\n";  my $mail = Mail::Internet->new(\*STDIN) or die "Parse failed !\n";
# Line 51  if (scalar(@xloop)) { Line 57  if (scalar(@xloop)) {
57      exit 0;      exit 0;
58  }  }
59    
60    # Find the real keyword
61    if (! $keyword) {
62        $keyword = 'default';
63        if (scalar(grep { m/owner\@bugs\.debian\.org/ }
64                        ($mail->head()->get('X-Loop'))
65                  )
66            and $mail->head()->get('X-Debian-PR-Message')
67           )
68        {
69            $keyword = 'bts';
70        } elsif (scalar(grep { m/debbugs\@master\.debian\.org/ }
71                        ($mail->head()->get('Sender'))
72                       )
73                 and ($mail->head()->get('Subject') =~ /^Processed:/)
74                )
75        {
76            $keyword = 'bts-control';
77        } elsif (($mail->head()->get('X-Katie') or $mail->head()->get('X-Lisa'))
78                 and
79                 ($mail->head()->get('Subject') =~ /^Accepted|INSTALLED|ACCEPTED/) and
80                 (scalar(grep { /\.dsc\s*$/ } @{$mail->body()}))
81                )
82        {
83            exit(0) if ($mail->head()->get('Subject') =~ /INSTALLED|ACCEPTED/);
84            $keyword = 'upload-source';
85        } elsif (($mail->head()->get('X-Katie') or $mail->head()->get('X-Lisa'))
86                 and
87                 ($mail->head()->get('Subject') =~ /^Accepted|INSTALLED|ACCEPTED/)
88                )
89        {
90            #exit(0) if ($mail->head()->get('Subject') =~ /INSTALLED|ACCEPTED/);
91            $keyword = 'upload-binary';
92        } elsif ($mail->head()->get('X-Katie') or $mail->head()->get('X-Lisa'))
93        {
94            $keyword = 'katie-other';
95        }
96    }
97    
98    # Build the real list of interested people
99    my $wantmail = sub {
100        my $address = shift;
101        foreach (get_tags($address, $package)) {
102            return 1 if ($_ eq $keyword);
103        }
104        return 0;
105    };
106    @emails = grep { &$wantmail($_) } @emails;
107    exit 0 if (! scalar(@emails));
108    close_db();
109    
110    # If default keyword, it may be spam ... check with spamassassin
111    # before approving
112    if ($keyword eq "default") {
113        # Some mails comes from trusted sources
114        # which do not need auto-approval
115        if ($mail->head()->get('X-Bugzilla-Product')) {
116            # Bugzilla(s) are trusted sources
117            $needs_approval = 0;
118        }
119        # Check for spam
120        if (defined($spamc) && $spamc) {
121            open(SPAMC, "| $spamc -c >/dev/null") || die "Can't fork spamc: $!\n";
122            $mail->print(\*SPAMC);
123            my $res = close(SPAMC);
124            if (!$res and !$!) {
125                # Looks like it's spam
126                print STDERR "Your message appears to be spam (according to spamassassin).\n";
127                print STDERR "If it wasn't please retry by writing simple plain text mails.\n";
128                exit 2;
129            }
130        }
131        # Check for approval
132        if (defined($needs_approval) && $needs_approval) {
133            if (! $mail->head()->get('X-PTS-Approved')) {
134                print STDERR "The mail isn't auto-approved as it should be. Please include\n";
135                print STDERR "an 'X-PTS-Approved' (non-empty) header if you want to mail \n";
136                print STDERR "directly the Package Tracking System. This is made to avoid spam.\n";
137                exit 2;
138            }
139        }
140    }
141    
142  # Modify the mail  # Modify the mail
143    $mail->head()->add("Precedence", "list");
144  $mail->head()->add("X-Loop", "$package\@packages.qa.debian.org");  $mail->head()->add("X-Loop", "$package\@packages.qa.debian.org");
145    $mail->head()->add("X-PTS-Package", $package);
146    $mail->head()->add("X-PTS-Keyword", $keyword);
147  $mail->head()->add("X-Unsubscribe",  $mail->head()->add("X-Unsubscribe",
148          "echo 'unsubscribe $package' | mail pts\@qa.debian.org");          "echo 'unsubscribe $package' | mail pts\@qa.debian.org");
149    
# Line 72  sub send_mail { Line 163  sub send_mail {
163      $mail->print(\*MAIL);      $mail->print(\*MAIL);
164      close MAIL or warn "Problem happened with sendmail: $!\n";      close MAIL or warn "Problem happened with sendmail: $!\n";
165  }  }
 sub open_db {  
     $DB_BTREE->{'flags'} = R_DUP;  
     $db = tie %db_content, "DB_File", $db_filename, O_RDONLY,  
                   0660, $DB_BTREE  
         or die "Can't open database $db_filename : $!\n";  
 }  
 sub close_db {  
     undef $db;  
     untie %db_content;  
 }  
Legend:
Removed from v.283  
changed lines
  Added in v.590
  ViewVC Help
Powered by ViewVC 1.1.5