File: //usr/share/perl5/vendor_perl/Amavis/Out/SMTP/Session.pm
# SPDX-License-Identifier: GPL-2.0-or-later
package Amavis::Out::SMTP::Session;
# provides a mechanism for SMTP session caching
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(&rundown_stale_sessions);
}
use subs @EXPORT_OK;
use vars qw(%sessions_cache);
use Time::HiRes qw(time);
use Amavis::Conf qw(:platform c cr ca $smtp_connection_cache_enable
%smtp_tls_client_options);
use Amavis::Util qw(min max minmax ll do_log snmp_count idn_to_ascii);
sub new {
my($class, $socket_specs, $deadline,
$wildcard_implied_host, $wildcard_implied_port) = @_;
my $self; my $cache_key; my $found_cached = 0;
for my $proto_sockname (ref $socket_specs ? @$socket_specs : $socket_specs) {
$cache_key = $proto_sockname;
local($1,$2,$3,$4);
if ($proto_sockname =~ # deal with dynamic destinations (wildcards)
/^([a-z][a-z0-9.+-]*) : (?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*)/xsi) {
my $peeraddress = defined $2 ? $2 : $3; my $peerport = $4;
$peeraddress = $wildcard_implied_host if $peeraddress eq '*';
$peerport = $wildcard_implied_port if $peerport eq '*';
$cache_key = sprintf("%s:[%s]:%s", $1, $peeraddress, $peerport);
}
if (exists $sessions_cache{$cache_key}) { $found_cached = 1; last }
}
if ($found_cached) {
$self = $sessions_cache{$cache_key};
$self->{deadline} = $deadline;
do_log(3, "smtp session reuse (%s), %d transactions so far",
$cache_key, $self->{transaction_count});
} else {
do_log(3, "smtp session: setting up a new session");
$cache_key = undef;
$self = bless {
socket_specs => $socket_specs,
socketname => undef, protocol => undef, smtp_handle => undef,
deadline => $deadline, timeout => undef, in_xactn => 0,
transaction_count => 0, state => 'down', established_at_time => undef,
wildcard_implied_host => $wildcard_implied_host,
wildcard_implied_port => $wildcard_implied_port,
}, $class;
}
$self->establish_or_refresh;
if (!defined $cache_key) { # newly established session
$cache_key = sprintf("%s:%s", $self->protocol, $self->socketname);
$sessions_cache{$cache_key} = $self;
}
$self;
}
sub smtp_handle
{ @_<2 ? $_[0]->{handle} : ($_[0]->{handle} = $_[1]) }
sub socketname
{ @_<2 ? shift->{socketname} : ($_[0]->{socketname} = $_[1]) }
sub protocol
{ @_<2 ? shift->{protocol} : ($_[0]->{protocol} = $_[1]) }
sub session_state
{ @_<2 ? shift->{state} : ($_[0]->{state} = $_[1]) }
sub in_smtp_transaction
{ @_<2 ? shift->{in_xactn} : ($_[0]->{in_xactn} = $_[1]) }
sub established_at_time
{ @_<2 ? shift->{established_at_time} : ($_[0]->{established_at_time}=$_[1])}
sub transaction_begins {
my $self = $_[0];
!$self->in_smtp_transaction
or die "smtp session: transaction_begins, but already active";
$self->in_smtp_transaction(1);
}
sub transaction_begins_unconfirmed {
my $self = $_[0];
snmp_count('OutConnTransact'); $self->{transaction_count}++;
!$self->in_smtp_transaction
or die "smtp session: transaction_begins_unconfirmed, but already active";
$self->in_smtp_transaction(undef);
}
sub transaction_ends {
my $self = $_[0];
$self->in_smtp_transaction(0);
}
sub transaction_ends_unconfirmed {
my $self = $_[0];
# if already 0 then keep it, otherwise undefine
$self->in_smtp_transaction(undef) if $self->in_smtp_transaction;
}
sub timeout {
my $self = shift;
if (@_) {
my $timeout = shift;
$self->{timeout} = $timeout;
$self->{handle}->timeout($timeout) if defined $self->{handle};
# do_log(5, "smtp session, timeout set to %s", $timeout);
}
$self->{timeout};
}
sub supports {
my($self,$keyword) = @_;
$self->{handle} ? $self->{handle}->supports($keyword) : undef;
}
sub smtp_response {
my $self = $_[0];
$self->{handle} ? $self->{handle}->smtp_response : undef;
}
sub quit {
my $self = $_[0];
my $smtp_handle = $self->smtp_handle;
if (defined $smtp_handle) {
$self->session_state('quitsent');
snmp_count('OutConnQuit');
$smtp_handle->quit; #flush! QUIT
}
}
sub close {
my($self,$keep_connected) = @_;
my $msg; my $smtp_handle = $self->smtp_handle;
if (defined($smtp_handle) && $smtp_handle->eof) {
$msg = 'already disconnected'; $keep_connected = 0;
} else {
$msg = $keep_connected ? 'keeping connection' : 'disconnecting';
}
do_log(3, "Amavis::Out::SMTP::Session close, %s", $msg);
if (!$keep_connected) {
if (defined $smtp_handle) {
$smtp_handle->close
or do_log(1, "Error closing Amavis::Out::SMTP::Protocol obj");
$self->in_smtp_transaction(0); $self->established_at_time(undef);
$self->smtp_handle(undef); $self->session_state('down');
}
if (defined $self->socketname) {
my $cache_key = sprintf("%s:%s", $self->protocol, $self->socketname);
delete $sessions_cache{$cache_key} if exists $sessions_cache{$cache_key};
}
}
1;
}
sub rundown_stale_sessions($) {
my $close_all = $_[0];
my $num_sessions_closed = 0;
for my $cache_key (keys %sessions_cache) {
my $smtp_session = $sessions_cache{$cache_key};
my $smtp_handle = $smtp_session->smtp_handle;
my $established_at_time = $smtp_session->established_at_time;
my $last_event_time;
$last_event_time = $smtp_handle->last_io_event_timestamp if $smtp_handle;
my $now = Time::HiRes::time;
if ($close_all || !$smtp_connection_cache_enable ||
!defined($last_event_time) || $now - $last_event_time >= 30 ||
!defined($established_at_time) || $now - $established_at_time >= 60) {
ll(3) && do_log(3,"smtp session rundown%s%s%s, %s, state %s",
$close_all ? ' all sessions'
: $smtp_connection_cache_enable ? ' stale sessions'
: ', cache off',
!defined($last_event_time) ? ''
: sprintf(", idle %.1f s", $now - $last_event_time),
!defined($established_at_time) ? ''
: sprintf(", since %.1f s ago",
$now - $established_at_time),
$cache_key, $smtp_session->session_state);
if ($smtp_session->session_state ne 'down' &&
$smtp_session->session_state ne 'quitsent' &&
(!defined($last_event_time) || $now - $last_event_time <= 55)) {
do_log(3,"smtp session rundown, sending QUIT");
eval { $smtp_session->quit } or 1; #flush! QUIT (ignoring failures)
}
if ($smtp_session->session_state eq 'quitsent') { # collect response
$smtp_session->timeout(5);
my $smtp_resp = eval { $smtp_session->smtp_response };
if (!defined $smtp_resp) {
do_log(3,"No SMTP resp. to QUIT");
} elsif ($smtp_resp eq '') {
do_log(3,"Empty SMTP resp. to QUIT");
} elsif ($smtp_resp !~ /^2/) {
do_log(3,"Negative SMTP resp. to QUIT: %s", $smtp_resp);
} else { # success, $smtp_resp =~ /^2/
do_log(3,"smtp resp to QUIT: %s", $smtp_resp);
}
}
if ($smtp_session->session_state ne 'down') {
do_log(3,"smtp session rundown, closing session %s", $cache_key);
$smtp_session->close(0)
or do_log(-2, "Error closing smtp session %s", $cache_key);
$num_sessions_closed++;
}
}
}
$num_sessions_closed;
}
sub establish_or_refresh {
my $self = $_[0];
# Timeout should be more than MTA normally takes to check DNS and RBL,
# which may take a minute or more in case of unreachable DNS server.
# Specifying shorter timeout will cause alarm to terminate the wait
# for SMTP status line prematurely, resulting in status code 000.
# RFC 5321 (ex RFC 2821) section 4.5.3.2 requires timeout to be
# at least 5 minutes
my $smtp_connect_timeout = 35; # seconds
my $smtp_helo_timeout = 300;
my $smtp_starttls_timeout = 300;
my $smtp_handle = $self->smtp_handle;
my $smtp_resp; my $last_event_time;
$last_event_time = $smtp_handle->last_io_event_timestamp if $smtp_handle;
my $now = Time::HiRes::time;
do_log(5,"establish_or_refresh, state: %s", $self->session_state);
die "panic, still in SMTP transaction" if $self->in_smtp_transaction;
if (defined($smtp_handle) &&
$self->session_state ne 'down' && $self->session_state ne 'quitsent') {
# if session has been idling for some time, check with a low-cost NOOP
# whether the session is still alive - reconnecting at this time is cheap;
# note that NOOP is non-pipelinable, MTA must respond immediately
if (defined($last_event_time) && $now - $last_event_time <= 18) {
snmp_count('OutConnReuseRecent');
do_log(3,"smtp session most likely still valid (short idle %.1f s)",
$now - $last_event_time);
} else { # Postfix default smtpd idle timeout is 60 s
eval {
$self->timeout(15);
$smtp_handle->noop; #flush!
$smtp_resp = $self->smtp_response; # fetch response to NOOP
do_log(3,"smtp resp to NOOP (idle %.1f s): %s",
$now - $last_event_time, $smtp_resp);
1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(3,"smtp NOOP failed (idle %.1f s): %s",
$now - $last_event_time, $eval_stat);
$smtp_resp = '';
};
if ($smtp_resp =~ /^2/) {
snmp_count('OutConnReuseRefreshed');
} else {
snmp_count('OutConnReuseFail');
$self->close(0) or do_log(-1, "Error closing smtp session");
}
}
}
if ($self->session_state eq 'down' || $self->session_state eq 'quitsent') {
if (defined $smtp_handle) {
$smtp_handle->close
or do_log(-2, "Error closing Amavis::Out::SMTP::Protocol obj");
undef $smtp_handle;
}
my $localaddr = c('local_client_bind_address'); # IP assigned to socket
snmp_count('OutConnNew');
require Amavis::Out::SMTP::Protocol;
$smtp_handle = Amavis::Out::SMTP::Protocol->new(
$self->{socket_specs}, LocalAddr => $localaddr, Timeout => 35,
WildcardImpliedHost => $self->{wildcard_implied_host},
WildcardImpliedPort => $self->{wildcard_implied_port});
$self->smtp_handle($smtp_handle);
defined $smtp_handle # don't change die text, it is referred to elsewhere
or die sprintf("Can't connect to %s",
!ref $self->{socket_specs} ? $self->{socket_specs}
: join(", ",@$self->{socket_specs}) );
$self->socketname($smtp_handle->socketname);
$self->protocol($smtp_handle->protocol);
$self->session_state('connected');
$self->established_at_time(time);
$self->timeout($smtp_connect_timeout);
$smtp_resp = $self->smtp_response; # fetch greeting
if (!defined $smtp_resp || $smtp_resp eq '') {
die sprintf("%s greeting, dt: %.3f s\n",
!defined $smtp_resp ? 'No' : 'Empty',
time - $smtp_handle->last_io_event_tx_timestamp);
} elsif ($smtp_resp !~ /^2/) {
die "Negative greeting: $smtp_resp\n";
} else { # success, $smtp_resp =~ /^2/
do_log(3,"smtp greeting: %s, dt: %.1f ms", $smtp_resp,
1000*(time-$smtp_handle->last_io_event_tx_timestamp));
}
}
if ($self->session_state eq 'connected') {
my $lmtp = lc($self->protocol) eq 'lmtp' ? 1 : 0; # RFC 2033
my $deadline = $self->{deadline};
my $tls_security_level = c('tls_security_level_out');
$tls_security_level = 0 if !defined($tls_security_level) ||
lc($tls_security_level) eq 'none';
my $myheloname = c('localhost_name'); # host name used in EHLO/HELO/LHLO
$myheloname = 'localhost' if $myheloname eq '';
$myheloname = idn_to_ascii($myheloname);
for (1..2) {
# send EHLO/LHLO/HELO
$self->timeout(max(60,min($smtp_helo_timeout,
$deadline - time)));
if ($lmtp) { $smtp_handle->lhlo($myheloname) } #flush!
else { $smtp_handle->ehlo($myheloname) } #flush!
$smtp_resp = $self->smtp_response; # fetch response to EHLO/LHLO
if (!defined $smtp_resp || $smtp_resp eq '') {
die sprintf("%s response to %s, dt: %.3f s\n",
!defined $smtp_resp ? 'No' : 'Empty',
$lmtp ? 'LHLO' : 'EHLO',
time - $smtp_handle->last_io_event_tx_timestamp);
} elsif ($smtp_resp =~ /^2/) { # success
do_log(3,"smtp resp to %s: %s", $lmtp?'LHLO':'EHLO', $smtp_resp);
} elsif ($lmtp) { # failure, no fallback possible
die "Negative SMTP resp. to LHLO: $smtp_resp\n";
} else { # failure, SMTP fallback to HELO
do_log(3,"Negative SMTP resp. to EHLO, will try HELO: %s", $smtp_resp);
$smtp_handle->helo($myheloname); #flush!
$smtp_resp = $self->smtp_response; # fetch response to HELO
if (!defined $smtp_resp || $smtp_resp eq '') {
die sprintf("%s response to HELO, dt: %.3f s\n",
!defined $smtp_resp ? 'No' : 'Empty',
time - $smtp_handle->last_io_event_tx_timestamp);
} elsif ($smtp_resp !~ /^2/) {
die "Negative response to HELO: $smtp_resp\n";
} else { # success, $smtp_resp =~ /^2/
do_log(3,"smtp resp to HELO: %s", $smtp_resp);
}
}
$self->session_state('ehlo');
$smtp_handle->ehlo_response_parse($smtp_resp);
my $tls_capable = defined $self->supports('STARTTLS'); # RFC 3207
ll(5) && do_log(5, "tls active=%d, capable=%s, sec_level=%s",
$smtp_handle->ssl_active, $tls_capable, $tls_security_level);
if ($smtp_handle->ssl_active) {
last; # done
} elsif (!$tls_capable &&
$tls_security_level && lc($tls_security_level) ne 'may') {
die "MTA does not offer STARTTLS, ".
"but TLS is required: \"$tls_security_level\"";
} elsif (!$tls_capable || !$tls_security_level) {
last; # not offered and not mandated
} else {
$self->timeout(max(60,min($smtp_starttls_timeout,
$deadline - time)));
$smtp_handle->command('STARTTLS'); #flush!
$smtp_resp = $self->smtp_response; # fetch response to STARTTLS
$smtp_resp = '' if !defined $smtp_resp;
do_log(3,"smtp resp to STARTTLS: %s", $smtp_resp);
if ($smtp_resp !~ /^2/) {
(!$tls_security_level || lc($tls_security_level) eq 'may')
or die "Negative SMTP resp. to STARTTLS: $smtp_resp\n";
} else {
$smtp_handle->ssl_upgrade(%smtp_tls_client_options)
or die "Error upgrading socket to SSL";
$self->session_state('connected');
}
}
}
}
$self;
}
1;