X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lib%2FDebbugs%2FMail.pm;fp=lib%2FDebbugs%2FMail.pm;h=e4c8bf7da825e53ce64b3f0849079237e07745fa;hb=1e6633a3780f4fd53fc4303852e84d13cdad2dc6;hp=0000000000000000000000000000000000000000;hpb=466f7faff129a5699c7674f59900a92aa256175d;p=debbugs.git diff --git a/lib/Debbugs/Mail.pm b/lib/Debbugs/Mail.pm new file mode 100644 index 0000000..e4c8bf7 --- /dev/null +++ b/lib/Debbugs/Mail.pm @@ -0,0 +1,552 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later +# version at your option. +# See the file README and COPYING for more information. +# +# Copyright 2004-7 by Don Armstrong . + +package Debbugs::Mail; + +=head1 NAME + +Debbugs::Mail -- Outgoing Mail Handling + +=head1 SYNOPSIS + +use Debbugs::Mail qw(send_mail_message get_addresses); + +my @addresses = get_addresses('blah blah blah foo@bar.com') +send_mail_message(message => <[@addresses]); +To: $addresses[0] +Subject: Testing + +Testing 1 2 3 +END + +=head1 EXPORT TAGS + +=over + +=item :all -- all functions that can be exported + +=back + +=head1 FUNCTIONS + + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +use IPC::Open3; +use POSIX qw(:sys_wait_h strftime); +use Time::HiRes qw(usleep gettimeofday); +use Mail::Address (); +use Debbugs::MIME qw(encode_rfc1522); +use Debbugs::Config qw(:config); +use Params::Validate qw(:types validate_with); +use Encode qw(encode is_utf8); +use Debbugs::UTF8 qw(encode_utf8_safely convert_to_utf8); + +use Debbugs::Packages; + +BEGIN{ + ($VERSION) = q$Revision: 1.1 $ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (addresses => [qw(get_addresses)], + misc => [qw(rfc822_date)], + mail => [qw(send_mail_message encode_headers default_headers)], + reply => [qw(reply_headers)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +# We set this here so it can be overridden for testing purposes +our $SENDMAIL = $config{sendmail}; + +=head2 get_addresses + + my @addresses = get_addresses('don@debian.org blars@debian.org + kamion@debian.org ajt@debian.org'); + +Given a string containing some e-mail addresses, parses the string +using Mail::Address->parse and returns a list of the addresses. + +=cut + +sub get_addresses { + return map { $_->address() } map { Mail::Address->parse($_) } @_; +} + + +=head2 default_headers + + my @head = default_headers(queue_file => 'foo', + data => $data, + msgid => $header{'message-id'}, + msgtype => 'error', + headers => [...], + ); + create_mime_message(\@headers, + ... + ); + +This function is generally called to generate the headers for +create_mime_message (and anything else that needs a set of default +headers.) + +In list context, returns an array of headers. In scalar context, +returns headers for shoving in a mail message after encoding using +encode_headers. + +=head3 options + +=over + +=item queue_file -- the queue file which will generate this set of +headers (refered to as $nn in lots of the code) + +=item data -- the data of the bug which this message involves; can be +undefined if there is no bug involved. + +=item msgid -- the Message-ID: of the message which will generate this +set of headers + +=item msgtype -- the type of message that this is. + +=item pr_msg -- the pr message field + +=item headers -- a set of headers which will override the default +headers; these headers will be passed through (and may be reordered.) +If a particular header is undef, it overrides the default, but isn't +passed through. + +=back + +=head3 default headers + +=over + +=item X-Loop -- set to the maintainer e-mail + +=item From -- set to the maintainer e-mail + +=item To -- set to Unknown recipients + +=item Subject -- set to Unknown subject + +=item Message-ID -- set appropriately (see code) + +=item Precedence -- set to bulk + +=item References -- set to the full set of message ids that are known +(from data and the msgid option) + +=item In-Reply-To -- set to msg id or the msgid from data + +=item X-Project-PR-Message -- set to pr_msg with the bug number appended + +=item X-Project-PR-Package -- set to the package of the bug + +=item X-Project-PR-Keywords -- set to the keywords of the bug + +=item X-Project-PR-Source -- set to the source of the bug + +=back + +=cut + +sub default_headers { + my %param = validate_with(params => \@_, + spec => {queue_file => {type => SCALAR|UNDEF, + optional => 1, + }, + data => {type => HASHREF, + optional => 1, + }, + msgid => {type => SCALAR|UNDEF, + optional => 1, + }, + msgtype => {type => SCALAR|UNDEF, + default => 'misc', + }, + pr_msg => {type => SCALAR|UNDEF, + default => 'misc', + }, + headers => {type => ARRAYREF, + default => [], + }, + }, + ); + my @header_order = (qw(X-Loop From To subject), + qw(Message-ID In-Reply-To References)); + # handle various things being undefined + if (not exists $param{queue_file} or + not defined $param{queue_file}) { + $param{queue_file} = join('',gettimeofday()) + } + for (qw(msgtype pr_msg)) { + if (not exists $param{$_} or + not defined $param{$_}) { + $param{$_} = 'misc'; + } + } + my %header_order; + @header_order{map {lc $_} @header_order} = 0..$#header_order; + my %set_headers; + my @ordered_headers; + my @temp = @{$param{headers}}; + my @other_headers; + while (my ($header,$value) = splice @temp,0,2) { + if (exists $header_order{lc($header)}) { + push @{$ordered_headers[$header_order{lc($header)}]}, + ($header,$value); + } + else { + push @other_headers,($header,$value); + } + $set_headers{lc($header)} = 1; + } + + # calculate our headers + my $bug_num = exists $param{data} ? $param{data}{bug_num} : 'x'; + my $nn = $param{queue_file}; + # handle the user giving the actual queue filename instead of nn + $nn =~ s/^[a-zA-Z]([a-zA-Z])/$1/; + $nn = lc($nn); + my @msgids; + if (exists $param{msgid} and defined $param{msgid}) { + push @msgids, $param{msgid} + } + elsif (exists $param{data} and defined $param{data}{msgid}) { + push @msgids, $param{data}{msgid} + } + my %default_header; + $default_header{'X-Loop'} = $config{maintainer_email}; + $default_header{From} = "$config{maintainer_email} ($config{project} $config{ubug} Tracking System)"; + $default_header{To} = "Unknown recipients"; + $default_header{Subject} = "Unknown subject"; + $default_header{'Message-ID'} = ""; + if (@msgids) { + $default_header{'In-Reply-To'} = $msgids[0]; + $default_header{'References'} = join(' ',@msgids); + } + $default_header{Precedence} = 'bulk'; + $default_header{"X-$config{project}-PR-Message"} = $param{pr_msg} . (exists $param{data} ? ' '.$param{data}{bug_num}:''); + $default_header{Date} = rfc822_date(); + if (exists $param{data}) { + if (defined $param{data}{keywords}) { + $default_header{"X-$config{project}-PR-Keywords"} = $param{data}{keywords}; + } + if (defined $param{data}{package}) { + $default_header{"X-$config{project}-PR-Package"} = $param{data}{package}; + if ($param{data}{package} =~ /^src:(.+)$/) { + $default_header{"X-$config{project}-PR-Source"} = $1; + } + else { + my $pkg_src = Debbugs::Packages::getpkgsrc(); + $default_header{"X-$config{project}-PR-Source"} = $pkg_src->{$param{data}{package}}; + } + } + } + for my $header (sort keys %default_header) { + next if $set_headers{lc($header)}; + if (exists $header_order{lc($header)}) { + push @{$ordered_headers[$header_order{lc($header)}]}, + ($header,$default_header{$header}); + } + else { + push @other_headers,($header,$default_header{$header}); + } + } + my @headers; + for my $hdr1 (@ordered_headers) { + next if not defined $hdr1; + my @temp = @{$hdr1}; + while (my ($header,$value) = splice @temp,0,2) { + next if not defined $value; + push @headers,($header,$value); + } + } + push @headers,@other_headers; + if (wantarray) { + return @headers; + } + else { + my $headers = ''; + while (my ($header,$value) = splice @headers,0,2) { + $headers .= "${header}: $value\n"; + } + return $headers; + } +} + + + +=head2 send_mail_message + + send_mail_message(message => $message, + recipients => [@recipients], + envelope_from => 'don@debian.org', + ); + + +=over + +=item message -- message to send out + +=item recipients -- recipients to send the message to. If undefed or +an empty arrayref, will use '-t' to parse the message for recipients. + +=item envelope_from -- envelope_from for outgoing messages + +=item encode_headers -- encode headers using RFC1522 (default) + +=item parse_for_recipients -- use -t to parse the message for +recipients in addition to those specified. [Can be used to set Bcc +recipients, for example.] + +=back + +Returns true on success, false on failures. All errors are indicated +using warn. + +=cut + +sub send_mail_message{ + my %param = validate_with(params => \@_, + spec => {sendmail_arguments => {type => ARRAYREF, + default => $config{sendmail_arguments}, + }, + parse_for_recipients => {type => BOOLEAN, + default => 0, + }, + encode_headers => {type => BOOLEAN, + default => 1, + }, + message => {type => SCALAR, + }, + envelope_from => {type => SCALAR, + default => $config{envelope_from}, + }, + recipients => {type => ARRAYREF|UNDEF, + optional => 1, + }, + }, + ); + my @sendmail_arguments = @{$param{sendmail_arguments}}; + push @sendmail_arguments, '-f', $param{envelope_from} if + exists $param{envelope_from} and + defined $param{envelope_from} and + length $param{envelope_from}; + + my @recipients; + @recipients = @{$param{recipients}} if defined $param{recipients} and + ref($param{recipients}) eq 'ARRAY'; + my %recipients; + @recipients{@recipients} = (1) x @recipients; + @recipients = keys %recipients; + # If there are no recipients, use -t to parse the message + if (@recipients == 0) { + $param{parse_for_recipients} = 1 unless exists $param{parse_for_recipients}; + } + # Encode headers if necessary + $param{encode_headers} = 1 if not exists $param{encode_headers}; + if ($param{encode_headers}) { + $param{message} = encode_headers($param{message}); + } + + # First, try to send the message as is. + eval { + _send_message($param{message}, + @sendmail_arguments, + $param{parse_for_recipients}?q(-t):(), + @recipients); + }; + return 1 unless $@; + # If there's only one recipient, there's nothing more we can do, + # so bail out. + warn $@ and return 0 if $@ and @recipients == 0; + # If that fails, try to send the message to each of the + # recipients separately. We also send the -t option separately in + # case one of the @recipients is ok, but the addresses in the + # mail message itself are malformed. + my @errors; + for my $recipient ($param{parse_for_recipients}?q(-t):(),@recipients) { + eval { + _send_message($param{message},@sendmail_arguments,$recipient); + }; + push @errors, "Sending to $recipient failed with $@" if $@; + } + # If it still fails, complain bitterly but don't die. + warn join(qq(\n),@errors) and return 0 if @errors; + return 1; +} + +=head2 encode_headers + + $message = encode_heeaders($message); + +RFC 1522 encodes the headers of a message + +=cut + +sub encode_headers{ + my ($message) = @_; + + my ($header,$body) = split /\n\n/, $message, 2; + $header = encode_rfc1522($header); + return $header . qq(\n\n). encode_utf8_safely($body); +} + +=head2 rfc822_date + + rfc822_date + +Return the current date in RFC822 format in the UTC timezone + +=cut + +sub rfc822_date{ + return scalar strftime "%a, %d %h %Y %T +0000", gmtime; +} + +=head2 reply_headers + + reply_headers(MIME::Parser->new()->parse_data(\$data)); + +Generates suggested headers and a body for replies. Primarily useful +for use in RFC2368 mailto: entries. + +=cut + +sub reply_headers{ + my ($entity) = @_; + + my $head = $entity->head; + # build reply link + my %r_l; + $r_l{subject} = $head->get('Subject'); + $r_l{subject} //= 'Your mail'; + $r_l{subject} = 'Re: '. $r_l{subject} unless $r_l{subject} =~ /(?:^|\s)Re:\s+/; + $r_l{subject} =~ s/(?:^\s*|\s*$)//g; + $r_l{'In-Reply-To'} = $head->get('Message-Id'); + $r_l{'In-Reply-To'} =~ s/(?:^\s*|\s*$)//g if defined $r_l{'In-Reply-To'}; + delete $r_l{'In-Reply-To'} unless defined $r_l{'In-Reply-To'}; + $r_l{References} = ($head->get('References')//''). ' '.($head->get('Message-Id')//''); + $r_l{References} =~ s/(?:^\s*|\s*$)//g; + my $date = $head->get('Date') // 'some date'; + $date =~ s/(?:^\s*|\s*$)//g; + my $who = $head->get('From') // $head->get('Reply-To') // 'someone'; + $who =~ s/(?:^\s*|\s*$)//g; + + my $body = "On $date $who wrote:\n"; + my $i = 60; + my $b_h; + # Default to UTF-8. + my $charset="utf-8"; + ## find the first part which has a defined body handle and appears + ## to be text + if (defined $entity->bodyhandle) { + my $this_charset = + $entity->head->mime_attr("content-type.charset"); + $charset = $this_charset if + defined $this_charset and + length $this_charset; + $b_h = $entity->bodyhandle; + } elsif ($entity->parts) { + my @parts = $entity->parts; + while (defined(my $part = shift @parts)) { + if ($part->parts) { + push @parts,$part->parts; + } + if (defined $part->bodyhandle and + $part->effective_type =~ /text/) { + my $this_charset = + $part->head->mime_attr("content-type.charset"); + $charset = $this_charset if + defined $this_charset and + length $this_charset; + $b_h = $part->bodyhandle; + last; + } + } + } + if (defined $b_h) { + eval { + my $IO = $b_h->open("r"); + while (defined($_ = $IO->getline)) { + $i--; + last if $i < 0; + $body .= '> '. convert_to_utf8($_,$charset); + } + $IO->close(); + }; + } + $r_l{body} = $body; + return \%r_l; +} + +=head1 PRIVATE FUNCTIONS + +=head2 _send_message + + _send_message($message,@sendmail_args); + +Private function that actually calls sendmail with @sendmail_args and +sends message $message. + +dies with errors, so calls to this function in send_mail_message +should be wrapped in eval. + +=cut + +sub _send_message{ + my ($message,@sendmail_args) = @_; + + my ($wfh,$rfh); + my $pid = open3($wfh,$rfh,$rfh,$SENDMAIL,@sendmail_args) + or die "Unable to fork off $SENDMAIL: $!"; + local $SIG{PIPE} = 'IGNORE'; + eval { + print {$wfh} $message or die "Unable to write to $SENDMAIL: $!"; + close $wfh or die "$SENDMAIL exited with $?"; + }; + if ($@) { + local $\; + # Reap the zombie + waitpid($pid,WNOHANG); + # This shouldn't block because the pipe closing is the only + # way this should be triggered. + my $message = <$rfh>; + die "$@$message"; + } + # Wait for sendmail to exit for at most 30 seconds. + my $loop = 0; + while (waitpid($pid, WNOHANG) == 0 or $loop++ >= 600){ + # sleep for a 20th of a second + usleep(50_000); + } + if ($loop >= 600) { + warn "$SENDMAIL didn't exit within 30 seconds"; + } +} + + +1; + + +__END__ + + + + + +