File: //usr/share/perl5/vendor_perl/Amavis/Out/BSMTP.pm
# SPDX-License-Identifier: GPL-2.0-or-later
package Amavis::Out::BSMTP;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
$VERSION = '2.412';
@ISA = qw(Exporter);
@EXPORT = qw(&mail_via_bsmtp);
}
use Errno qw(ENOENT EACCES);
use IO::File qw(O_CREAT O_EXCL O_WRONLY);
use Amavis::Conf qw(:platform $QUARANTINEDIR c cr ca);
use Amavis::Out::EditHeader;
use Amavis::rfc2821_2822_Tools;
use Amavis::Timing qw(section_time);
use Amavis::Util qw(untaint min max minmax ll do_log snmp_count
idn_to_ascii collect_equal_delivery_recips);
# store message in a BSMTP format
#
# RFC 2442: Application/batch-SMTP material is generated by a specially
# modified SMTP client operating without a corresponding SMTP server.
# The client simply assumes a successful response to all commands it issues.
# The resulting content then consists of the collected output from the SMTP
# client.
#
sub mail_via_bsmtp(@) {
my($msginfo, $initial_submission, $dsn_per_recip_capable, $filter) = @_;
my(@snmp_vars) = !$initial_submission ?
('', 'Relay', 'ProtoBSMTP', 'ProtoBSMTPRelay')
: ('', 'Submit', 'ProtoBSMTP', 'ProtoBSMTPSubmit',
'Submit'.$initial_submission);
snmp_count('OutMsgs'.$_) for @snmp_vars;
my $logmsg = sprintf("%s via BSMTP: %s", ($initial_submission?'SEND':'FWD'),
$msginfo->sender_smtp);
my($per_recip_data_ref, $proto_sockname) =
collect_equal_delivery_recips($msginfo, $filter, qr/^bsmtp:/i);
if (!$per_recip_data_ref || !@$per_recip_data_ref) {
do_log(5, "%s, nothing to do", $logmsg); return 1;
}
$proto_sockname = $proto_sockname->[0] if ref $proto_sockname;
ll(1) && do_log(1, "delivering to %s, %s -> %s",
$proto_sockname, $logmsg,
join(',', qquote_rfc2821_local(
map($_->recip_final_addr, @$per_recip_data_ref)) ));
# just use the first one, ignoring failover alternatives
local($1);
$proto_sockname =~ /^bsmtp:(.*)\z/si
or die "Bad fwd method syntax: ".$proto_sockname;
my $bsmtp_file_final = $1; my $mbxname;
my $s = $msginfo->sender; # sanitized sender name for use in a filename
$s =~ tr/a-zA-Z0-9@._+-/=/c;
substr($s,100) = '...' if length($s) > 100+3;
$s =~ s/\@/_at_/g; $s =~ s/^(\.{0,2})\z/_$1/;
$bsmtp_file_final =~ s{%(.)}
{ $1 eq 'b' ? $msginfo->body_digest
: $1 eq 'P' ? $msginfo->partition_tag
: $1 eq 'm' ? $msginfo->mail_id||''
: $1 eq 'n' ? $msginfo->log_id
: $1 eq 's' ? untaint($s) # a hack, avoid using %s
: $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1) #,'-')
: $1 eq '%' ? '%' : '%'.$1 }gse;
# prepend directory if not specified
my $bsmtp_file_final_to_show = $bsmtp_file_final;
$bsmtp_file_final = $QUARANTINEDIR."/".$bsmtp_file_final
if $QUARANTINEDIR ne '' && $bsmtp_file_final !~ m{^/};
my $bsmtp_file_tmp = $bsmtp_file_final . ".tmp";
my $mp; my $err;
eval {
my $errn = lstat($bsmtp_file_tmp) ? 0 : 0+$!;
if ($errn == ENOENT) {} # good, no file, as expected
elsif ($errn==0 && (-f _ || -l _))
{ die "File $bsmtp_file_tmp already exists, refuse to overwrite" }
else
{ die "File $bsmtp_file_tmp exists??? Refuse to overwrite it, $!" }
$mp = IO::File->new;
# O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
$mp->open($bsmtp_file_tmp, untaint(O_CREAT|O_EXCL|O_WRONLY), 0640)
or die "Can't create BSMTP file $bsmtp_file_tmp: $!";
binmode($mp,':bytes') or die "Can't set :bytes, $!";
# RFC 2442: Since no SMTP server is present the client must be prepared
# to make certain assumptions about which SMTP extensions can be used.
# The generator MAY assume that ESMTP [RFC 1869 (obsoleted by RFC 5321)]
# facilities are available, that is, it is acceptable to use the EHLO
# command and additional parameters on MAIL FROM and RCPT TO. If EHLO
# is used MAY assume that the 8bitMIME [RFC 6152], SIZE [RFC 1870], and
# NOTARY [RFC 1891] extensions are available. In particular, NOTARY
# SHOULD be used. (nowadays called DSN)
my $myheloname = c('localhost_name'); # host name used in EHLO/HELO/LHLO
$myheloname = 'localhost' if $myheloname eq '';
$myheloname = idn_to_ascii($myheloname);
$mp->printf("EHLO %s\n", $myheloname) or die "print failed (EHLO): $!";
my $btype = $msginfo->body_type; # RFC 6152: need "8bit Data"? (RFC 2045)
$btype = '' if !defined $btype;
my $dsn_envid = $msginfo->dsn_envid; my $dsn_ret = $msginfo->dsn_ret;
$mp->printf("MAIL FROM:%s\n", join(' ',
$msginfo->sender_smtp,
$btype ne '' ? ('BODY='.uc($btype)) : (),
defined $dsn_ret ? ('RET='.$dsn_ret) : (),
defined $dsn_envid ? ('ENVID='.$dsn_envid) : () ),
) or die "print failed (MAIL FROM): $!";
for my $r (@$per_recip_data_ref) {
my(@dsn_notify); # implies a default when the list is empty
my $dn = $r->dsn_notify;
@dsn_notify = @$dn if $dn && $msginfo->sender ne ''; # if nondefault
if (@dsn_notify && c('terminate_dsn_on_notify_success')) {
# we want to handle option SUCCESS locally
if (grep($_ eq 'SUCCESS', @dsn_notify)) { # strip out SUCCESS
@dsn_notify = grep($_ ne 'SUCCESS', @dsn_notify);
@dsn_notify = ('NEVER') if !@dsn_notify;
do_log(3,"stripped out SUCCESS, result: NOTIFY=%s",
join(',',@dsn_notify));
}
}
$mp->printf("RCPT TO:%s\n", join(' ',
qquote_rfc2821_local($r->recip_final_addr),
@dsn_notify ? ('NOTIFY='.join(',',@dsn_notify)) : (),
defined $r->dsn_orcpt ? ('ORCPT='.$r->dsn_orcpt) : () ),
) or die "print failed (RCPT TO): $!";
}
$mp->print("DATA\n") or die "print failed (DATA): $!";
my $hdr_edits = $msginfo->header_edits;
$hdr_edits = Amavis::Out::EditHeader->new if !$hdr_edits;
my($received_cnt,$file_position) =
$hdr_edits->write_header($msginfo,$mp,!$initial_submission);
my $msg = $msginfo->mail_text;
my $msg_str_ref = $msginfo->mail_text_str; # have an in-memory copy?
$msg = $msg_str_ref if ref $msg_str_ref;
if ($received_cnt > 100) { # loop detection required by RFC 5321 sect. 6.3
die "Too many hops: $received_cnt 'Received:' header fields";
} elsif (!defined $msg) {
# empty mail
} elsif (ref $msg eq 'SCALAR') {
my $buff = substr($$msg,$file_position);
$buff =~ s/^\./../gm;
$mp->print($buff) or die "print failed - data: $!";
} elsif ($msg->isa('MIME::Entity')) {
$msg->print_body($mp);
} else {
my $ln;
for ($! = 0; defined($ln=$msg->getline); $! = 0) {
$mp->print($ln=~/^\./ ? (".",$ln) : $ln)
or die "print failed - data: $!";
}
defined $ln || $! == 0 or die "Error reading: $!";
}
$mp->print(".\n") or die "print failed (final dot): $!";
# $mp->print("QUIT\n") or die "print failed (QUIT): $!";
$mp->close or die "Error closing BSMTP file $bsmtp_file_tmp: $!";
undef $mp;
rename($bsmtp_file_tmp, $bsmtp_file_final)
or die "Can't rename BSMTP file to $bsmtp_file_final: $!";
$mbxname = $bsmtp_file_final;
1;
} or do { $err = $@ ne '' ? $@ : "errno=$!" };
my $smtp_response;
if ($err eq '') {
$smtp_response = "250 2.6.0 Ok, queued as BSMTP $bsmtp_file_final_to_show";
snmp_count('OutMsgsDelivers');
my $size = $msginfo->msg_size;
snmp_count( ['OutMsgsSize'.$_, $size, 'C64'] ) for @snmp_vars;
} else {
chomp $err;
unlink($bsmtp_file_tmp)
or do_log(-2,"Can't delete half-finished BSMTP file %s: %s",
$bsmtp_file_tmp, $!);
$mp->close if defined $mp; # ignore status
if ($err =~ /too many hops\b/i) {
$smtp_response = "554 5.4.6 Reject: $err";
snmp_count('OutMsgsRejects');
} else {
$smtp_response = "451 4.5.0 Writing $bsmtp_file_tmp failed: $err";
snmp_count('OutMsgsAttemptFails');
}
die $err if $err =~ /^timed out\b/; # resignal timeout
}
$smtp_response .= ", id=" . $msginfo->log_id;
$msginfo->dsn_passed_on($smtp_response=~/^2/ &&
!c('terminate_dsn_on_notify_success') ? 1 : 0);
for my $r (@$per_recip_data_ref) {
next if $r->recip_done;
$r->recip_smtp_response($smtp_response); $r->recip_done(2);
$r->recip_mbxname($mbxname) if $mbxname ne '' && $smtp_response =~ /^2/;
}
section_time('fwd-bsmtp');
1;
}
1;