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