File: //usr/share/perl5/vendor_perl/Amavis/Out/Local.pm
# SPDX-License-Identifier: GPL-2.0-or-later
package Amavis::Out::Local;
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_OK = qw(&mail_to_local_mailbox);
}
use Errno qw(ENOENT EACCES);
use Fcntl qw(:flock);
#use File::Spec;
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use Amavis::Conf qw(:platform c cr ca
$QUARANTINEDIR $quarantine_subdir_levels);
use Amavis::Out::EditHeader;
use Amavis::rfc2821_2822_Tools;
use Amavis::Timing qw(section_time);
use Amavis::Util qw(snmp_count ll do_log untaint unique_list
collect_equal_delivery_recips);
use subs @EXPORT_OK;
# Deliver to local mailboxes only, ignore the rest: either to directory
# (maildir style), or file (Unix mbox). (normally used as a quarantine method)
#
sub mail_to_local_mailbox(@) {
my($msginfo, $initial_submission, $dsn_per_recip_capable, $filter) = @_;
# note that recipients of a message being delivered to a quarantine
# are typically not the original envelope recipients, but are pseudo
# address provided to do_quarantine() based on @quarantine_to_maps;
# nevertheless, we do the usual collect_equal_delivery_recips() ritual
# here too for consistency
#
my $logmsg = sprintf("%s via LOCAL: %s", ($initial_submission?'SEND':'FWD'),
$msginfo->sender_smtp);
my($per_recip_data_ref, $proto_sockname) =
collect_equal_delivery_recips($msginfo, $filter, qr/^local:/i);
if (!$per_recip_data_ref || !@$per_recip_data_ref) {
do_log(5, "%s, nothing to do", $logmsg); return 1;
}
my(@per_recip_data) = @$per_recip_data_ref; undef $per_recip_data_ref;
$proto_sockname = $proto_sockname->[0] if ref $proto_sockname;
ll(4) && do_log(4, "delivering to %s, %s -> %s",
$proto_sockname, $logmsg,
join(',', qquote_rfc2821_local(
map($_->recip_final_addr, @per_recip_data)) ));
# just use the first one, ignoring failover alternatives
local($1);
$proto_sockname =~ /^local:(.*)\z/si
or die "Bad local method syntax: ".$proto_sockname;
my $via_arg = $1;
my(@snmp_vars) = !$initial_submission ?
('', 'Relay', 'ProtoLocal', 'ProtoLocalRelay')
: ('', 'Submit','ProtoLocal', 'ProtoLocalSubmit',
'Submit'.$initial_submission);
snmp_count('OutMsgs'.$_) for @snmp_vars;
my $sender = $msginfo->sender;
for my $r (@per_recip_data) { # determine a mailbox file for each recipient
# each recipient gets his own copy; these are not the original message's
# recipients but are mailbox addresses, typically telling where a message
# to be quarantined is to be stored
my $recip = $r->recip_final_addr;
# %local_delivery_aliases emulates aliases map - this would otherwise
# be done by MTA's local delivery agent if we gave the message to MTA.
# This way we keep interface compatible with other mail delivery
# methods. The hash value may be a ref to a pair of fixed strings,
# or a subroutine ref (which must return such pair) to allow delayed
# (lazy) evaluation when some part of the pair is not yet known
# at initialization time.
# If no matching entry is found quarantining is skipped.
my($mbxname, $suggested_filename);
my($localpart,$domain) = split_address($recip);
my $ldar = cr('local_delivery_aliases'); # a ref to a hash
my $alias = $ldar->{$localpart};
if (ref($alias) eq 'ARRAY') {
($mbxname, $suggested_filename) = @$alias;
} elsif (ref($alias) eq 'CODE') { # lazy (delayed) evaluation
($mbxname, $suggested_filename) = &$alias;
} elsif ($alias ne '') {
($mbxname, $suggested_filename) = ($alias, undef);
} elsif (!exists $ldar->{$localpart}) {
do_log(3, "no key '%s' in %s, using a default",
$localpart, '%local_delivery_aliases');
($mbxname, $suggested_filename) = ($QUARANTINEDIR, undef);
}
if (!defined($mbxname) || $mbxname eq '' || $recip eq '') {
my $why = !exists $ldar->{$localpart} ? 1 : $alias eq '' ? 2 : 3;
do_log(2, "skip local delivery(%s): <%s> -> <%s>", $why,$sender,$recip);
my $smtp_response = "250 2.6.0 Ok, skip local delivery($why)";
$smtp_response .= ", id=" . $msginfo->log_id;
$r->recip_smtp_response($smtp_response); $r->recip_done(2);
next;
}
my $ux; # is it a UNIX-style mailbox?
my $errn = stat($mbxname) ? 0 : 0+$!;
if ($errn == ENOENT) {
$ux = 1; # $mbxname is a UNIX-style mailbox (new file)
} elsif ($errn != 0) {
die "Can't access a mailbox file or directory $mbxname: $!";
} elsif (-f _) {
$ux = 1; # $mbxname is a UNIX-style mailbox (existing file)
} elsif (!-d _) {
die "Mailbox is neither a file nor a directory: $mbxname";
} else { # a directory
$ux = 0; # $mbxname is a directory (amavis/maildir style mailbox)
my $explicitly_suggested_filename = $suggested_filename ne '';
if ($suggested_filename eq '')
{ $suggested_filename = $via_arg ne '' ? $via_arg : '%m' }
my $mail_id = $msginfo->mail_id;
if (!defined($mail_id)) {
do_log(-1, "mail_to_local_mailbox: mail_id still undefined!?");
$mail_id = '';
}
$suggested_filename =~ s{%(.)}
{ $1 eq 'b' ? $msginfo->body_digest
: $1 eq 'P' ? $msginfo->partition_tag
: $1 eq 'm' ? $mail_id
: $1 eq 'n' ? $msginfo->log_id
: $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1) #,'-')
: $1 eq '%' ? '%' : '%'.$1 }gse;
# $mbxname = File::Spec->catfile($mbxname, $suggested_filename);
$mbxname = "$mbxname/$suggested_filename";
if ($quarantine_subdir_levels>=1 && !$explicitly_suggested_filename) {
# using a subdirectory structure to disperse quarantine files
local($1,$2); my $subdir = substr($mail_id, 0, 1);
$subdir=~/^[A-Z0-9]\z/i or die "Unexpected first char: $subdir";
$mbxname =~ m{^ (.*/)? ([^/]+) \z}xs; my($path,$fname) = ($1,$2);
# $mbxname = File::Spec->catfile($path, $subdir, $fname);
$mbxname = "$path$subdir/$fname"; # resulting full filename
my $errn = stat("$path$subdir") ? 0 : 0+$!;
# only test for ENOENT, other errors will be detected later on access
if ($errn == ENOENT) { # check/prepare a set of subdirectories
do_log(2, "checking/creating quarantine subdirs under %s", $path);
for my $d ('A'..'Z','a'..'z','0'..'9') {
$errn = stat("$path$d") ? 0 : 0+$!;
if ($errn == ENOENT) {
mkdir("$path$d", 0750) or die "Can't create dir $path$d: $!";
}
}
}
}
}
# save location where mail should be stored, prepend a mailbox style
$r->recip_mbxname(($ux ? 'mbox' : 'maildir') . ':' . $mbxname);
}
#
# now go ahead and store a message to predetermined files in recip_mbxname;
# iterate by groups of recipients with the same mailbox name
#
@per_recip_data = grep(!$_->recip_done, @per_recip_data);
while (@per_recip_data) {
my $mbxname = $per_recip_data[0]->recip_mbxname; # first mailbox name
# collect all recipient which have the same mailbox file as the first one
my(@recips_with_same_mbx) =
grep($_->recip_mbxname eq $mbxname, @per_recip_data);
@per_recip_data = grep($_->recip_mbxname ne $mbxname, @per_recip_data);
# retrieve mailbox style and a filename
local($1,$2); $mbxname =~ /^([^:]*):(.*)\z/;
my $ux = $1 eq 'mbox' ? 1 : 0; $mbxname = $2;
my(@recips) = map($_->recip_final_addr, @recips_with_same_mbx);
@recips = unique_list(\@recips);
my $smtp_response;
{ # a block is used as a 'switch' statement - 'last' will exit from it
do_log(1,"local delivery: %s -> %s, mbx=%s",
$msginfo->sender_smtp, join(", ",@recips), $mbxname);
my $eval_stat; my($mp,$pos);
my $errn = stat($mbxname) ? 0 : 0+$!;
section_time('stat-mbx');
local $SIG{CHLD} = 'DEFAULT';
local $SIG{PIPE} = 'IGNORE'; # don't signal on a write to a widowed pipe
eval { # try to open the mailbox file for writing
if (!$ux) { # one mail per file, will create specified file
if ($errn == ENOENT) {
# good, no file, as expected
} elsif ($errn != 0) {
die "File $mbxname not accessible, refuse to write: $!";
} elsif (!-f _) {
die "File $mbxname is not a regular file, refuse to write";
} else {
die "File $mbxname already exists, refuse to overwrite";
}
if ($mbxname =~ /\.gz\z/) {
$mp = Amavis::IO::Zlib->new; # ?how to request an exclusive access?
$mp->open($mbxname,'wb')
or die "Can't create gzip file $mbxname: $!";
} else {
$mp = IO::File->new;
# O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
$mp->open($mbxname, untaint(O_CREAT|O_EXCL|O_WRONLY), 0640)
or die "Can't create file $mbxname: $!";
binmode($mp,':bytes') or die "Can't cancel :utf8 mode: $!";
}
} else { # append to a UNIX-style mailbox
# deliver only to non-executable regular files
if ($errn == ENOENT) {
# if two processes try creating the same new UNIX-style mailbox
# file at the same time, one will tempfail at this point, with
# its mail delivery to be retried later by MTA
$mp = IO::File->new;
# O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
$mp->open($mbxname, untaint(O_CREAT|O_EXCL|O_APPEND|O_WRONLY),0640)
or die "Can't create file $mbxname: $!";
} elsif ($errn==0 && !-f _) {
die "Mailbox $mbxname is not a regular file, refuse to deliver";
} elsif (-x _ || -X _) {
die "Mailbox file $mbxname is executable, refuse to deliver";
} else {
$mp = IO::File->new;
# O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
$mp->open($mbxname, untaint(O_APPEND|O_WRONLY), 0640)
or die "Can't append to $mbxname: $!";
}
binmode($mp,':bytes') or die "Can't cancel :utf8 mode: $!";
flock($mp,LOCK_EX) or die "Can't lock mailbox file $mbxname: $!";
$mp->seek(0,2) or die "Can't position mailbox file to its tail: $!";
$pos = $mp->tell; # remember where we started
}
section_time('open-mbx');
1;
} or do {
$eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
$smtp_response =
$eval_stat =~ /^timed out\b/ ? "450 4.4.2" : "451 4.5.0";
$smtp_response .= " Local delivery(1) to $mbxname failed: $eval_stat";
die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout
};
last if defined $eval_stat; # exit block, not the loop
my $failed = 0; $eval_stat = undef;
eval { # if things fail from here on, try to restore mailbox state
if ($ux) {
# a null return path may not appear in the 'From ' delimiter line
my $snd = $sender eq '' ? 'MAILER-DAEMON' # as in sendmail & Postfix
: $msginfo->sender_smtp;
# if the envelope sender contains spaces, tabs, or newlines,
# the program (like qmail-local) replaces them with hyphens
$snd =~ s/[ \t\n]/-/sg;
# date/time in asctime (ctime) format, English month names!
# RFC 4155 and qmail-local require UTC time, no timezone name
$mp->printf("From %s %s\n", $snd, scalar gmtime($msginfo->rx_time) )
or die "Can't write mbox separator line to $mbxname: $!";
}
my $hdr_edits = $msginfo->header_edits;
if (!$hdr_edits) {
$hdr_edits = Amavis::Out::EditHeader->new;
$msginfo->header_edits($hdr_edits);
}
$hdr_edits->delete_header('Return-Path');
$hdr_edits->prepend_header('Delivered-To', join(', ',@recips));
$hdr_edits->prepend_header('Return-Path', $msginfo->sender_smtp);
my($received_cnt,$file_position) =
$hdr_edits->write_header($msginfo,$mp,!$initial_submission);
if ($received_cnt > 110) {
# loop detection required by RFC 5321 (ex RFC 2821) section 6.3
# Do not modify the signal text, it gets matched elsewhere!
die "Too many hops: $received_cnt 'Received:' header fields\n";
}
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 (!$ux) { # do it in blocks for speed if we can
if (!defined $msg) {
# empty mail
} elsif (ref $msg eq 'SCALAR') {
$mp->print(substr($$msg,$file_position))
or die "Can't write to $mbxname: $!";
} elsif ($msg->isa('MIME::Entity')) {
die "quarantining a MIME::Entity object is not implemented";
} else {
my($nbytes,$buff);
while (($nbytes = $msg->read($buff,32768)) > 0) {
$mp->print($buff) or die "Can't write to $mbxname: $!";
}
defined $nbytes or die "Error reading: $!";
}
} else { # for UNIX-style mailbox file delivery: escape 'From '
# mail(1) and elm(1) recognize /^From / as a message delimiter
# only after a blank line, which is correct. Other MUAs like mutt,
# thunderbird, kmail and pine need all /^From / lines escaped.
# See also http://en.wikipedia.org/wiki/Mbox and RFC 4155.
if (!defined $msg) {
# empty mail
} elsif (ref $msg eq 'SCALAR') {
my $buff = substr($$msg,$file_position);
# $buff =~ s/^From />From /gm; # mboxo format
$buff =~ s/^(?=\>*From )/>/gm; # mboxrd format
$mp->print($buff) or die "Can't write to $mbxname: $!";
} elsif ($msg->isa('MIME::Entity')) {
die "quarantining a MIME::Entity object is not implemented";
} else {
my $ln; my $blank_line = 1;
# need to copy line-by-line, slow
for ($! = 0; defined($ln=$msg->getline); $! = 0) {
# see wikipedia and RFC 4155 for "From " escaping conventions
$mp->print('>') or die "Can't write to $mbxname: $!"
if $ln =~ /^(?:>*)From /; # escape all "From " lines
# if $blank_line && $ln =~ /^(?:>*)From /; # only after blankline
$mp->print($ln) or die "Can't write to $mbxname: $!";
$blank_line = $ln eq "\n";
}
defined $ln || $! == 0 or die "Error reading: $!";
}
}
# must append an empty line for a Unix mailbox format
$mp->print("\n") or die "Can't write to $mbxname: $!" if $ux;
1;
} or do { # trouble
$eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
if ($ux && defined($pos)) {
$mp->flush or die "Can't flush file $mbxname: $!";
$can_truncate or
do_log(-1, "Truncating a mailbox file will most likely fail");
# try to restore UNIX-style mailbox to previous size;
# Produces a fatal error if truncate isn't implemented on the system
$mp->truncate($pos) or die "Can't truncate file $mbxname: $!";
}
$failed = 1;
die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout
};
# if ($ux) {
# # explicit unlocking is unnecessary, close will do a flush & unlock
# $mp->flush or die "Can't flush mailbox file $mbxname: $!";
# flock($mp,LOCK_UN) or die "Can't unlock mailbox $mbxname: $!";
# }
$mp->close or die "Error closing $mbxname: $!";
undef $mp;
if (!$failed) {
$smtp_response = "250 2.6.0 Ok, delivered to $mbxname";
snmp_count('OutMsgsDelivers');
my $size = $msginfo->msg_size;
snmp_count( ['OutMsgsSize'.$_, $size, 'C64'] ) for @snmp_vars;
} elsif ($@ =~ /^timed out\b/) {
$smtp_response = "450 4.4.2 Local delivery to $mbxname timed out";
snmp_count('OutMsgsAttemptFails');
} elsif ($@ =~ /too many hops\b/i) {
$smtp_response = "554 5.4.6 Rejected delivery to mailbox $mbxname: $@";
snmp_count('OutMsgsRejects');
} else {
$smtp_response = "451 4.5.0 Local delivery to mailbox $mbxname ".
"failed: $@";
snmp_count('OutMsgsAttemptFails');
}
} # end of block, 'last' within the block brings us here
do_log(-1, "%s", $smtp_response) if $smtp_response !~ /^2/;
$smtp_response .= ", id=" . $msginfo->log_id;
for my $r (@recips_with_same_mbx) {
$r->recip_smtp_response($smtp_response); $r->recip_done(2);
$r->recip_mbxname($smtp_response =~ /^2/ ? $mbxname : undef);
}
}
section_time('save-to-local-mailbox');
}
1;