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

package Amavis::Out::Pipe;
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_pipe);
}

use Errno qw(ENOENT EACCES ESRCH);
use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED
             WEXITSTATUS WTERMSIG WSTOPSIG);

use Amavis::Conf qw(:platform c cr ca);
use Amavis::Out::EditHeader;
use Amavis::ProcControl qw(exit_status_str proc_status_ok kill_proc
                           run_command_consumer);
use Amavis::rfc2821_2822_Tools;
use Amavis::Timing qw(section_time);
use Amavis::Util qw(untaint min max minmax ll do_log snmp_count
                    collect_equal_delivery_recips);

# Send mail using external mail submission program 'sendmail' or its lookalike
# (also available with Postfix and Exim) - used for forwarding original mail
# or sending notifications or quarantining. May throw exception (die) on
# temporary failure (4xx) or other problem.
#
sub mail_via_pipe(@) {
  my($msginfo, $initial_submission, $dsn_per_recip_capable, $filter) = @_;
  my(@snmp_vars) = !$initial_submission ?
    ('', 'Relay',  'ProtoPipe', 'ProtoPipeRelay')
  : ('', 'Submit', 'ProtoPipe', 'ProtoPipeSubmit',
     'Submit'.$initial_submission);
  snmp_count('OutMsgs'.$_)  for @snmp_vars;
  my $id = $msginfo->parent_mail_id;
  $id = $msginfo->mail_id . (defined $id ? "($id)" : "");
  my $logmsg = sprintf("%s %s via PIPE from %s", $id,
                       ($initial_submission ? 'SEND' : 'FWD'),
                       $msginfo->sender_smtp);
  my($per_recip_data_ref, $proto_sockname) =
    collect_equal_delivery_recips($msginfo, $filter, qr/^pipe:/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 =~ /^pipe:(.*)\z/si
    or die "Bad fwd method syntax: ".$proto_sockname;
  my $pipe_args = $1;
  $pipe_args =~ s/^flags=\S*\s*//i;  # flags are currently ignored, q implied
  $pipe_args =~ s/^argv=//i;
  my(@pipe_args) = split(' ',$pipe_args);  my(@command) = shift(@pipe_args);
  my $dsn_capable = c('propagate_dsn_if_possible');  # assume, unless disabled
  $dsn_capable = 0  if $command[0] !~ /sendmail/;  # a hack, don't use -N or -V
  if ($dsn_capable) {    # DSN is supported since Postfix 2.3
    # notify options are per-recipient, yet a command option -N applies to all
    my $common_list; my $not_all_the_same = 0;
    for my $r (@{$msginfo->per_recip_data}) {
      my $dsn_notify = $r->dsn_notify;
      my $d;
      if ($msginfo->sender eq '') {
        $d = 'NEVER';
      } elsif (!$dsn_notify) {
        $d = 'DELAY,FAILURE';  # sorted
      } else {
        $d = uc(join(',', sort @$dsn_notify));  # normalize order
      }
      if (!defined($common_list)) { $common_list = $d }
      elsif ($d ne $common_list) { $not_all_the_same = 1 }
    }
    if ($common_list=~/\bSUCCESS\b/ && c('terminate_dsn_on_notify_success')) {
      # strip out option SUCCESS, we want to handle it locally
      my(@dsn_notify) = grep($_ ne 'SUCCESS', split(/,/,$common_list));
      @dsn_notify = ('NEVER')  if !@dsn_notify;
      $common_list = join(',',@dsn_notify);
      do_log(3,"stripped out SUCCESS, result: NOTIFY=%s", $common_list);
    }
    if ($not_all_the_same || $msginfo->sender eq '') {}  # leave at default
    elsif ($common_list eq 'DELAY,FAILURE') {}           # leave at default
    else { unshift(@pipe_args, '-N', $common_list) }
    unshift(@pipe_args,
            '-V', $msginfo->dsn_envid)  if defined $msginfo->dsn_envid;
    # but there is no mechanism to specify ORCPT or RET
  }
  for (@pipe_args) {
    # The sendmail command line expects addresses quoted as per RFC 822.
    #   "funny user"@some.domain
    # For compatibility with Sendmail, the Postfix sendmail command line also
    # accepts address formats that are legal in RFC 822 mail header section:
    #   Funny Dude <"funny user"@some.domain>
    # Although addresses passed as args to sendmail submission program
    # should not be <...> bracketed, for some reason original sendmail
    # issues a warning on null reverse-path, but gladly accepts <>.
    # As this is not strictly wrong, we comply to make it happy.
    # NOTE: the -fsender is not allowed, -f and sender must be separate args!
    my $null_ret_path = '<>';  # some sendmail lookalikes want '<>', others ''
    # Courier sendmail accepts '' but not '<>' for null reverse path
    if (/^\$\{sender\}\z/i) {
      push(@command, $msginfo->sender eq '' ? $null_ret_path
       : do { my $s = $msginfo->sender_smtp;
              $s =~ s/^<//; $s =~ s/>\z//; untaint($s) });
    } elsif (/^\$\{recipient\}\z/i) {
      push(@command,
           map { $_ eq '' ? $null_ret_path : untaint(quote_rfc2821_local($_)) }
           map($_->recip_final_addr, @$per_recip_data_ref));
    } else {
      push(@command, $_);
    }
  }
  ll(5) && do_log(5, "mail_via_pipe running command: %s", join(' ',@command));
  local $SIG{CHLD} = 'DEFAULT';
  local $SIG{PIPE} = 'IGNORE';  # don't signal on a write to a widowed pipe
  my($proc_fh,$pid) = run_command_consumer(undef,undef,@command);
  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,$proc_fh,!$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 section 6.3
                              # deal with it later, for now just skip the body
  } elsif (!defined $msg) {
    # empty mail
  } elsif (ref $msg eq 'SCALAR') {
    # do it in chunks, saves memory, cache friendly
    while ($file_position < length($$msg)) {
      $proc_fh->print(substr($$msg,$file_position,16384))
        or die "writing mail text to a pipe failed: $!";
      $file_position += 16384;  # may overshoot, no problem
    }
  } elsif ($msg->isa('MIME::Entity')) {
    $msg->print_body($proc_fh);
  } else {
    my($nbytes,$buff);
    while (($nbytes = $msg->read($buff,32768)) > 0) {
      $proc_fh->print($buff)
        or die "writing mail text to a pipe failed: $!";
    }
    defined $nbytes or die "Error reading: $!";
  }
  $proc_fh->flush or die "Can't flush pipe to a mail submission program: $!";
  my $smtp_response;
  if ($received_cnt > 100) { # loop detection required by RFC 5321 section 6.3
    do_log(-2, "Too many hops: %d 'Received:' header fields", $received_cnt);
    kill_proc($pid,$command[0],10,$proc_fh,'too many hops')  if defined $pid;
    $proc_fh->close; undef $proc_fh; undef $pid;  # and ignore status
    $smtp_response = "554 5.4.6 Reject: " .
                     "Too many hops: $received_cnt 'Received:' header fields";
  } else {
    my $err = 0; $proc_fh->close or $err=$!;
    my $child_stat = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;
    # sendmail program (Postfix variant) can return the following exit codes:
    # EX_OK(0), EX_DATAERR, EX_SOFTWARE, EX_TEMPFAIL, EX_NOUSER, EX_UNAVAILABLE
    if (proc_status_ok($child_stat,$err, EX_OK)) {
      $smtp_response = "250 2.6.0 Ok";  # submitted to MTA
      snmp_count('OutMsgsDelivers');
      my $size = $msginfo->msg_size;
      snmp_count( ['OutMsgsSize'.$_, $size, 'C64'] )  for @snmp_vars;
    } elsif (proc_status_ok($child_stat,$err, EX_TEMPFAIL)) {
      $smtp_response = "450 4.5.0 Temporary failure submitting message";
      snmp_count('OutMsgsAttemptFails');
    } elsif (proc_status_ok($child_stat,$err, EX_NOUSER)) {
      $smtp_response = "554 5.1.1 Recipient unknown";
      snmp_count('OutMsgsRejects');
    } elsif (proc_status_ok($child_stat,$err, EX_UNAVAILABLE)) {
      $smtp_response = "554 5.5.0 Mail submission service unavailable";
      snmp_count('OutMsgsRejects');
    } else {
      $smtp_response = "451 4.5.0 Failed to submit a message: ".
                       exit_status_str($child_stat,$err);
      snmp_count('OutMsgsAttemptFails');
    }
    ll(3) && do_log(3,"mail_via_pipe %s, %s, %s", $command[0],
                      exit_status_str($child_stat,$err), $smtp_response);
  }
  $smtp_response .= ", id=" . $msginfo->log_id;
  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($r->recip_final_addr)  if $smtp_response =~ /^2/;
  }
  $msginfo->dsn_passed_on($dsn_capable && $smtp_response=~/^2/ &&
                          !c('terminate_dsn_on_notify_success') ? 1 : 0);
  section_time('fwd-pipe');
  1;
}

1;