# SPDX-License-Identifier: GPL-2.0-or-later

package Amavis::Out::SMTP::Protocol;
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);
}

use Errno qw(EIO EINTR EAGAIN ECONNRESET);
use Encode ();
use Time::HiRes ();

use Amavis::Conf qw(:platform);
use Amavis::IO::RW;
use Amavis::Util qw(ll do_log min max minmax);

sub init {
  my $self = $_[0];
  delete $self->{domain};  delete $self->{supports};
  $self->{pipelining} = 0;
}

sub new {
  my($class,$socket_specs,%arg) = @_;
  my $self = bless {}, $class;
  $self->{at_line_boundary} = 1;
  $self->{dotstuffing}  = 1;  # defaults to on
  $self->{dotstuffing}  = 0 if defined $arg{DotStuffing} && !$arg{DotStuffing};
  $self->{strip_cr}     = 1;  # sanitizing bare CR enabled by default
  $self->{strip_cr}     = 0 if defined $arg{StripCR} && !$arg{StripCR};
  $self->{sanitize_nul} = 1;  # sanitizing NUL bytes enabled by default
  $self->{sanitize_nul} = 0 if defined $arg{SanitizeNUL} && !$arg{SanitizeNUL};
  $self->{null_cnt} = 0;
  $self->{io} = Amavis::IO::RW->new($socket_specs, Eol => "\015\012", %arg);
  $self->init;
  $self;
}

sub close {
  my $self = $_[0];
  $self->{io}->close;
}

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  eval { $self->close } or 1;  # ignore failure, make perlcritic happy
}

sub ehlo_response_parse {
  my($self,$smtp_resp) = @_;
  delete $self->{domain};  delete $self->{supports};
  my(@ehlo_lines) = split(/\n/,$smtp_resp,-1);
  my $bad; my $first = 1; local($1,$2);
  for my $el (@ehlo_lines) {
    if ($first) {
      if ($el =~ /^(\d{3})(?:[ \t]+(.*))?\z/s) { $self->{domain} = $2 }
      elsif (!defined($bad)) { $bad = $el }
      $first = 0;
    } elsif ($el =~ /^([A-Z0-9][A-Z0-9-]*)(?:[ =](.*))?\z/si) {
      $self->{supports}{uc($1)} = defined $2 ? $2 : '';
    } elsif ($el =~ /^[ \t]*\z/s) {
      # don't bother (e.g. smtp-sink)
    } elsif (!defined($bad)) {
      $bad = $el;
    }
  }
  $self->{pipelining} = defined $self->{supports}{'PIPELINING'} ? 1 : 0;
  do_log(0, "Bad EHLO kw %s ignored in %s, socket %s",
            $bad, $smtp_resp, $self->socketname)  if defined $bad;
  1;
}

sub domain
  { my $self = $_[0]; $self->{domain} }

sub supports
  { my($self,$keyword) = @_; $self->{supports}{uc($keyword)} }

*print = \&datasend;  # alias name for datasend
sub datasend {
  my $self = shift;
  my $buff = @_ == 1 ? $_[0] : join('',@_);
  do_log(-1,"WARN: Unicode string passed to datasend: %s", $buff)
    if utf8::is_utf8($buff);  # always false on tainted, Perl 5.8 bug #32687
# ll(5) && do_log(5, 'smtp print %d bytes>', length($buff));
  $buff =~ tr/\015//d  if $self->{strip_cr};  # sanitize bare CR if necessary
  if ($self->{sanitize_nul}) {
    my $cnt = $buff =~ tr/\x00//;  # quick triage
    if ($cnt) {
      # this will break DKIM signatures, but IMAP (cyrus) hates NULs in mail
      $self->{null_cnt} += $cnt;
      $buff =~ s{\x00}{\xC0\x80}gs;  # turn to "Modified UTF-8" encoding of NUL
    }
  }
  # CR/LF are never split across a buffer boundary
  $buff =~ s{\n}{\015\012}gs;  # quite fast, but still a bottleneck
  if ($self->{dotstuffing}) {
    $buff =~ s{\015\012\.}{\015\012..}gs;  # dot stuffing
    $self->{io}->print('.')  if substr($buff,0,1) eq '.' &&
                             $self->{at_line_boundary};
  }
  $self->{io}->print($buff);
  $self->{at_line_boundary} = $self->{io}->at_line_boundary;
  $self->{io}->out_buff_large ? $self->flush : 1;
}

sub socketname
  { my $self = shift; $self->{io}->socketname(@_) }

sub protocol
  { my $self = shift; $self->{io}->protocol(@_) }

sub timeout
  { my $self = shift; $self->{io}->timeout(@_) }

sub ssl_active
  { my $self = shift; $self->{io}->ssl_active(@_) }

sub ssl_upgrade
  { my $self = shift; $self->{io}->ssl_upgrade(@_) }

sub last_io_event_timestamp
  { my $self = shift; $self->{io}->last_io_event_timestamp(@_) }

sub last_io_event_tx_timestamp
  { my $self = shift; $self->{io}->last_io_event_tx_timestamp(@_) }

sub eof
  { my $self = shift; $self->{io}->eof(@_) }

sub flush
  { my $self = shift; $self->{io}->flush(@_) }

sub dataend {
  my $self = $_[0];
  if (!$self->{at_line_boundary}) {
    $self->datasend("\n");
  }
  if ($self->{dotstuffing}) {
    $self->{dotstuffing} = 0;
    $self->datasend(".\n");
    $self->{dotstuffing} = 1;
  }
  if ($self->{null_cnt}) {
    do_log(0, 'smtp forwarding: SANITIZED %d NULL byte(s)', $self->{null_cnt});
    $self->{null_cnt} = 0;
  }
  $self->{io}->out_buff_large ? $self->flush : 1;
}

sub command {
  my($self,$command,@args) = @_;
  my $line = $command =~ /:\z/ ? $command.join(' ',@args)
                               : join(' ',$command,@args);
  ll(3) && do_log(3, 'smtp cmd> %s', $line);
  $self->datasend($line."\n"); $self->{at_line_boundary} = 1;
  # RFC 2920: commands that can appear anywhere in a pipelined command group
  #   RSET, MAIL FROM, SEND FROM, SOML FROM, SAML FROM, RCPT TO, (data)
  if (!$self->{pipelining} || $self->{io}->out_buff_large ||
      $command !~ /^(?:RSET|MAIL|SEND|SOML|SAML|RCPT)\b/is) {
    return $self->flush;
  }
  1;
}

sub smtp_response {
  my $self = $_[0];
  my $resp = ''; my($line,$code,$enh); my $first = 1;
  for (;;) {
    $line = $self->{io}->get_response_line;
    last  if !defined $line;  # eof, error, timeout
    my $line_complete = $line =~ s/\015\012\z//s;
    $line .= ' INCOMPLETE'  if !$line_complete;
    my $more; local($1,$2,$3);
    $line =~ s/^(\d{3}) (-|\ |\z)
                (?: ([245] \. \d{1,3} \. \d{1,3}) (\ |\z) )?//xs;
    if ($first) { $code = $1; $enh = $3; $first = 0 } else { $resp .= "\n" }
    $resp .= $line; $more = $2 eq '-';
    last  if !$more || !$line_complete;
  }
  !defined $code ? undef : $code . (defined $enh ? " $enh" : '') . ' '. $resp;
}

sub helo { my $self = shift; $self->init; $self->command("HELO",@_) }
sub ehlo { my $self = shift; $self->init; $self->command("EHLO",@_) }
sub lhlo { my $self = shift; $self->init; $self->command("LHLO",@_) }
sub noop { my $self = shift; $self->command("NOOP",@_) }
sub rset { my $self = shift; $self->command("RSET",@_) }
sub auth { my $self = shift; $self->command("AUTH",@_) }
sub data { my $self = shift; $self->command("DATA",@_) }
sub quit { my $self = shift; $self->command("QUIT",@_) }

sub mail {
  my($self,$reverse_path,%params) = @_;
  my(@mail_parameters) =
    map { my $v = $params{$_}; defined($v) ? "$_=$v" : "$_" } (keys %params);
  $self->command("MAIL FROM:", $reverse_path, @mail_parameters);
}

sub recipient {
  my($self,$forward_path,%params) = @_;
  my(@rcpt_parameters) =
    map { my $v = $params{$_}; defined($v) ? "$_=$v" : "$_" } (keys %params);
  $self->command("RCPT TO:", $forward_path, @rcpt_parameters);
}

1;