Bivio::Mail::Outgoing
# Copyright (c) 1999-2023 bivio Software, Inc. All rights reserved.
package Bivio::Mail::Outgoing;
use strict;
use Bivio::Base 'Mail.Common';
use MIME::Base64 ();
use MIME::QuotedPrint ();
# prints messages which can be ignored at startup.
Bivio::Die->eval(q{use Net::DNS ();});
Bivio::Die->eval(q{use Mail::SPF ();});
# C<Bivio::Mail::Outgoing> is used to create and send mail messages.
# One can resend an existing mail message or simply create one from
# scratch.
my($_T) = b_use('MIME.Type');
my($_R) = b_use('Biz.Random');
my($_FP) = b_use('Type.FilePath');
my($_I) = b_use('Mail.Incoming');
my($_A) = b_use('Mail.Address');
my($_IOT) = b_use('IO.Template');
my($_DT) = b_use('Type.DateTime');
my($_E) = b_use('Type.Email');
my($_RFC) = b_use('Mail.RFC822');
my($_KEEP_HEADERS_LIST_SEND_RE) = qr{
^(?:
@{[join(
'|',
qw(
bcc
cc
comments
content-.+
date
from
in-reply-to
keywords
message-id
mime-version
references
reply-to
subject
to
),
)]}
)$
}six;
# 822:
# Due to an artifact of the notational conventions, the syn-
# tax indicates that, when present, some fields, must be in
# a particular order. Header fields are NOT required to
# occur in any particular order, except that the message
# body must occur AFTER the headers. It is recommended
# that, if present, headers be sent in the order "Return-
# Path", "Received", "Date", "From", "Subject", "Sender",
# "To", "cc", etc.
#
# This specification permits multiple occurrences of most
# fields. Except as noted, their interpretation is not
# specified here, and their use is discouraged.
#
# NOTE: This is list is sorted as described above!
my($_FIRST_HEADERS) = [qw(
return-path
received
message-id
date
from
subject
sender
to
cc
bcc
reply-to
mime-version
content-type
content-transfer-encoding
content-length
)];
sub add_missing_headers {
my($self, $req, $from_email) = @_;
# Sets Date, Message-ID, From and Return-Path if not set.
$from_email ||= $self->get_from_email($req);
my($now) = $_DT->now;
foreach my $x (
[Date => $_DT->rfc822($now)],
['Message-ID' => $self->generate_message_id($req)],
[From => "<$from_email>"],
['Return-Path' => "<$from_email>"],
) {
$self->set_header(@$x)
unless $self->unsafe_get_header($x->[0]);
}
return $self;
}
sub as_string {
my($self) = @_;
# Returns string representation of the mail message, suitable for sending.
my($headers) = {%{$self->get('headers')}};
my($res) = join(
'',
map(
delete($headers->{$_}) || '',
@$_FIRST_HEADERS,
sort(keys(%$headers)),
),
);
my($body, $ct, $parts) = $self->unsafe_get(qw(body content_type parts));
if ($parts) {
die("'content_type' must be set for attachments")
unless $ct;
Bivio::IO::Alert->warn("ignoring body, have attachments")
if $body;
_encapsulate_parts(\$res, $ct, $parts);
}
elsif ($body) {
$res .= "Content-Type: $ct\n"
if $ct;
$res .= "\n" . $$body;
}
return $res;
}
sub attach {
sub ATTACH {[qw(content content_type ?filename ?binary)]};
my($self, $bp) = shift->parameters(\@_);
Bivio::IO::Alert->warn('binary is supplanted by suggest_encoding')
if defined($bp->{binary});
push(@{$self->get_if_exists_else_put('parts', [])}, $bp);
return;
}
sub edit_body {
my($self, $vars) = @_;
my($body) = ${$self->get_body};
# fix vars cut-off by quoted printable formatting
my($count) = 0;
while ($body =~ s/( quoted-printable.*?\$\w*)\=\n(\w+)/$1$2/s) {
b_die('too many vars replaced')
if ++$count > 10;
}
$self->set_body($_IOT->replace_in_string(\$body, $vars));
return;
}
sub generate_addr_spec {
my(undef, $req) = @_;
return $req->format_email(
$_DT->to_file_name($_DT->now) . '.' . $_R->string(16)
);
}
sub generate_message_id {
return '<'
. shift->generate_addr_spec(@_)
. '>';
}
sub get_body {
# Returns the receiver's body.
return shift->get('body');
}
sub get_from_email {
my($self, $req) = @_;
return ($_A->parse(
$self->unsafe_get_header('from')
|| $self->unsafe_get_header('Apparently-From')
|| ($self->user_email($req))[0],
))[0];
}
sub new {
my($proto, $msg) = @_;
# Creates a new outgoing mail message. If I<incoming> is supplied,
# uses as the basis for the message.
my($attrs) = {};
$msg = $_I->new($msg)
if ref($msg) eq 'SCALAR';
if (UNIVERSAL::isa($msg, $_I)) {
my($body);
$msg->get_body(\$body);
$attrs->{body} = \$body;
$attrs->{headers} = $msg->get_headers;
$attrs->{envelope_from} = $msg->get_from;
}
elsif (UNIVERSAL::isa($msg, __PACKAGE__)) {
# NOTE: This shares \$body if it exists, which neither class nor
# its parents modify. Action.RealmMailReflector depends on this
# so that the server doesn't grow too large.
my($c) = $msg->get_shallow_copy;
while (my($k, $v) = each(%$c)) {
$attrs->{$k} = ref($v) eq 'ARRAY' ? [@$v]
: ref($v) eq 'HASH' ? {%$v}
: $v;
}
}
elsif (defined($msg)) {
Bivio::Die->die('invalid message type');
}
$attrs->{headers} ||= {};
return $proto->SUPER::new($attrs);
}
sub remove_headers {
my($self, @names) = @_;
my($h) = $self->get('headers');
foreach my $name (@names) {
delete($h->{lc($name)});
}
return;
}
sub send {
my($self, $req) = shift->internal_req(@_);
return $self
unless _rewrite_from($self, $req);
return $self->SUPER::send(undef, undef, 0, $self->unsafe_get('envelope_from'), $req);
}
sub set_body {
my($self, $body) = @_;
# Sets the body of the message to I<body>, which may be C<undef>.
# If I<body> is a reference, it will be retained.
$self->put(body => ref($body) eq 'SCALAR' ? $body : \$body);
return;
}
sub set_content_type {
my($self, $value) = @_;
# Sets the Content-Type header field. Any previous setting is overridden.
# Remove possibly existing Content-Type setting from the headers
$self->remove_headers('content-type');
$self->put(content_type => $value);
return;
}
sub set_envelope_from {
return shift->put(envelope_from => shift);
}
sub set_from_with_user {
my($self, $req) = shift->internal_req(@_);
# Sets the from with the current user and host name. It uses the email
# address not the comment entry (/etc/passwd) for the name. If it can't get
# the user, it is does nothing. The MTA will add it.
#
# Returns the from email address or C<undef> if it couldn't set anything.
my($email, $name) = $self->user_email($req);
$self->set_envelope_from($email);
$self->set_header('From', qq{"$name" <$email>});
return $email
}
sub set_header {
my($self, $name, $value) = @_;
# Sets a particular header field. The previous value of the field is
# deleted. The newline will be appended to the value.
#
# ASSUMES: I<name> and I<value> conform to RFC 822.
my($n) = lc($name);
#TODO: Should assert header name is valid and quote value if need be
b_warn('stripped trailing newline from header value: ', $name, ' ', $value)
if $value =~ s/\n+$//g;
$self->set_envelope_from(($_A->parse($value))[0])
if $n eq 'return-path';
$self->get('headers')->{$n} = $name . ': ' . $value . "\n";
return $self;
}
sub set_headers_for_forward {
my($self, $sender, $req) = @_;
_inc_forward_header($self);
$self->set_header('Sender', $sender)
if $sender;
return $self;
}
sub set_headers_for_list_send {
sub SET_HEADERS_FOR_LIST_SEND {[
[qw(req Agent.Request)],
[qw(list_email Email)],
[qw(?reply_to Email)],
[qw(?reply_to_list Boolean)],
[qw(?return_path Email)],
[qw(?sender Email)],
[qw(?subject_prefix Line)],
]};
my($self, $bp) = shift->parameters(\@_);
$bp->{sender} ||= $bp->{list_email};
$bp->{reply_to} ||= $bp->{list_email};
my($headers) = $self->get('headers');
$self->remove_headers(
grep($_ !~ $_KEEP_HEADERS_LIST_SEND_RE, keys(%$headers)));
$self->set_header(
To => $self->unsafe_get_header('cc') || $bp->{list_email},
) unless $self->unsafe_get_header('to');
$self->set_header('X-Mailer', "Bivio-Mail-Outgoing");
$self->set_header('Precedence', 'list');
$self->set_header('X-Auto-Response-Suppress', 'OOF');
$self->set_header('List-Id', _list_id($bp->{list_email}));
$self->set_header('Reply-To', $bp->{reply_to})
if $bp->{reply_to_list};
$self->set_header(From => $bp->{sender})
unless $headers->{from};
$self->set_header(
'Return-Path',
'<'
. ($bp->{return_path} || $self->get_from_email($bp->{req}))
. '>',
);
$self->set_headers_for_forward($bp->{sender}, $bp->{req});
return $self
unless $bp->{subject_prefix};
my($s) = $self->unsafe_get_header('subject');
if (defined($s)) {
$s =~ s/^(?!(Re:\s*)*\Q$bp->{subject_prefix}\E)/$bp->{subject_prefix} /is;
}
else {
$s = $bp->{subject_prefix};
}
$self->set_header(Subject => $s);
return $self;
}
sub unsafe_get_header {
# Returns header value or undef.
return [
((shift->get('headers')->{lc(shift)})[0] || '')
=~ /^(?:.*?):\s+(.*)\n$/s
]->[0];
}
sub _encapsulate_parts {
my($buf, $type, $parts) = @_;
my($boundary) = $_R->string(32);
$$buf .= <<"EOF";
MIME-Version: 1.0
Content-Type: $type; boundary="$boundary"
This is a multi-part message in MIME format.
EOF
my($p);
foreach $p (@$parts) {
$$buf .= "--$boundary\nContent-Type: $p->{content_type}";
my($n) = $_FP->get_clean_tail($p->{filename});
if ($n) {
$n =~ s/^\s+|\s+$|"//g;
$$buf .= qq{; name="$n"}
}
$$buf .= "\nContent-Disposition: inline";
$$buf .= qq{; filename="$n"}
if $n;
my($encoding)
= $_T->suggest_encoding($p->{content_type}, $p->{content});
$$buf .= "\nContent-Transfer-Encoding: $encoding\n\n";
if ($encoding eq 'quoted-printable' ) {
$$buf .= MIME::QuotedPrint::encode(${$p->{content}});
}
elsif ($encoding eq 'base64' ) {
$$buf .= MIME::Base64::encode(${$p->{content}});
}
else {
$$buf .= ${$p->{content}};
$$buf .= "\n"
unless $$buf =~ /\n$/s;
}
}
$$buf .= "--$boundary--\n";
return;
}
sub _inc_forward_header {
my($self) = @_;
return $self->set_header(
$self->FORWARDING_HDR,
($self->unsafe_get_header($self->FORWARDING_HDR) || 0) + 1,
);
}
sub _list_id {
my($list_email) = @_;
$list_email =~ s/[^-\w]+/./g;
return "<$list_email>";
}
sub _rewrite_from {
my($self, $req) = @_;
my($full_from) = $self->unsafe_get_header('from');
unless ($full_from) {
b_warn('missing from header, ignoring: ', $full_from);
return 0;
}
my($old_email, $old_name) = $_A->parse($full_from);
unless ($old_email) {
b_warn('from header missing email, ignoring: ', $full_from);
return 0;
}
my($cfg) = $self->internal_get_config;
if ($cfg->{in_btest}) {
return 1;
}
if ($cfg->{force_rewrite_from_re} && $old_email =~ $cfg->{force_rewrite_from_re}) {
# Fall through to rewrite below
}
elsif ($cfg->{allow_resend_from_re}) {
if ($old_email =~ $cfg->{allow_resend_from_re}) {
return 1;
}
}
else {
# POSIT: can always send from mail_host. We might be using a Postfix
# "Smart host" for this so we can't just use our own IP in the SPF
# tests. Also, this avoids multiple rewrites, since _rewrite_from_if_spf
# checks with 0.0.0.0 as the IP, which shouldn't match anything.
my($d) = lc($_E->get_domain_part($old_email));
# This probably only is not defined in bunits
my($f) = $req->unsafe_get('UI.Facade');
if (!$f || $d eq $f->get_value('mail_host')) {
return 1;
}
if (!_rewrite_from_if_dmarc($d) && !_rewrite_from_if_spf($old_email)) {
return 1;
}
}
my($new_email, $new_name) = _rewrite_from_generate(
$self, $old_email, $old_name, $req);
$self->set_header('Reply-To', $old_email)
unless $self->unsafe_get_header('reply-to');
my($rp) = $self->unsafe_get_header('return-path');
$self->set_header('Return-Path', $_RFC->format_angle_brackets($new_email))
if !$rp || $rp eq $old_email;
my($ef) = $self->unsafe_get('envelope_from');
$self->set_envelope_from($new_email)
if !$ef || $ef eq $old_email;
$self->set_header('From', $_RFC->format_mailbox($new_email, $new_name));
return 1;
}
sub _rewrite_from_generate {
my($self, $email, $name, $req) = @_;
my($ro) = b_use('Model.RealmOwner')->new($req);
if ($ro->unauth_load_by_email($email)) {
$email = b_use('Model.MailReceiveDispatchForm')->new($req)
->format_recipient(
$ro->get('realm_id'),
undef,
b_use('Action.MailForward')->REWRITE_FROM_DOMAIN_URI,
);
$name ||= $ro->get('display_name');
}
else {
$name ||= $_E->get_local_part($email);
$email = $_E->format_ignore($email, $req);
}
$name .= ' via ' . b_use('UI.Facade')->get_value('mail_host', $req);
return ($email, $name);
}
sub _rewrite_from_if_dmarc {
my($domain) = @_;
my($res) = undef;
my($die) = b_catch(sub {
my($r) = Net::DNS::Resolver->new;
while ($domain =~ m{\.}) {
my($q) = $r->query("_dmarc.$domain", 'txt');
if ($q) {
for my $r ($q->answer) {
my($t) = $r->txtdata;
# Only look at the first answer
$res = !$t || $t =~ /\bp=none/ ? 0 : 1;
return;
}
}
if (! ($domain =~ s{^[^\.]+\.}{})) {
b_warn("invalid domain=$domain");
return;
}
}
# No answer
$res = 0;
return;
});
if ($die) {
b_info($domain, ': error, leaving undef: ', $die);
}
return $res;
}
sub _rewrite_from_if_spf {
my($email) = @_;
# Avoid unnecessary messages output from Mail::SPF, e.g.
# Error::throw('Mail::SPF::ENoAcceptableRecord', 'No applicable sender policy available')
# called at /usr/share/perl5/vendor_perl/Mail/SPF/Server.pm line 478
my($r) = Bivio::Die->eval(
sub {
return Mail::SPF::Server->new->process(
Mail::SPF::Request->new(identity => $email, ip_address => '0.0.0.0'),
);
},
);
return $r && $r->code =~ m{^(?:pass|none|netural)$}i ? 0 : 1;
}
1;