# 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;