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

package Amavis::Out::EditHeader;

# Accumulates instructions on what header fields need to be added
# to a header section, which deleted, or how to change existing ones.
# A call to write_header() then performs these edits on the fly.

use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&hdr);
}
use Errno qw(EBADF);
use Encode ();
use MIME::Words;

use Amavis::Conf qw(:platform c cr ca);
use Amavis::rfc2821_2822_Tools qw(wrap_string);
use Amavis::Timing qw(section_time);
use Amavis::Util qw(ll do_log min max q_encode
                    safe_encode safe_encode_utf8_inplace);

sub new {
  my $class = $_[0];
  bless { prepend=>[], append=>[], addrcvd=>[], edit=>{} }, $class;
}

sub prepend_header {
  my $self = shift;
  unshift(@{$self->{prepend}}, hdr(@_));
}

sub append_header {
  my $self = shift;
  push(@{$self->{append}}, hdr(@_));
}

sub append_header_above_received {
  my $self = shift;
  push(@{$self->{addrcvd}}, hdr(@_));
}

# now a synonym for append_header_above_received()  (old semantics: prepend
# or append, depending on setting of $append_header_fields_to_bottom)
#
sub add_header {
  my $self = shift;
  push(@{$self->{addrcvd}}, hdr(@_));
}

# delete all header fields with a $field_name
#
sub delete_header {
  my($self, $field_name) = @_;
  $self->{edit}{lc $field_name} = [undef];
}

# all header fields with $field_name will be edited by a supplied subroutine
#
sub edit_header {
  my($self, $field_name, $field_edit_sub) = @_;
  # $field_edit_sub will be called with 2 args: a field name and a field body;
  # It should return a pair consisting of a replacement field body (no field
  # name and no colon, with or without a trailing NL), and a boolean 'verbatim'
  # (false in its absence). An undefined replacement field body indicates a
  # deletion of the entire header field. A value true in the second returned
  # element indicates that a verbatim replacement is desired (i.e. no other
  # changes are allowed on a replacement body such as folding or encoding).
  !defined($field_edit_sub) || ref($field_edit_sub) eq 'CODE'
    or die "edit_header: arg#3 must be undef or a subroutine ref";
  $field_name = lc $field_name;
  if (!exists($self->{edit}{$field_name})) {
    $self->{edit}{$field_name} = [$field_edit_sub];
  } else {
    do_log(5, "INFO: multiple header edits: %s", $field_name);
    push(@{$self->{edit}{$field_name}}, $field_edit_sub);
  }
}

# copy all header edits from another header-edits object into this one
#
sub inherit_header_edits($$) {
  my($self, $other_edits) = @_;
  if (defined $other_edits) {
    for (qw(prepend addrcvd append)) {
      unshift(@{$self->{$_}}, @{$other_edits->{$_}})  if $other_edits->{$_};
    }
    my $o_edit = $other_edits->{edit};
    if ($o_edit) {
      for my $fn (keys %$o_edit) {
        if (!exists($self->{edit}{$fn})) {
          $self->{edit}{$fn} = [ @{$o_edit->{$fn}} ];  # copy list
        } else {
          unshift(@{$self->{edit}{$fn}}, @{$o_edit->{$fn}});
        }
      }
    }
  }
}

# Conditioning of a header field to be added.
# Insert space after colon if not present, RFC 2047 -encode if field body
# contains non-ASCII characters, fold long lines if needed, prepend space
# before each NL if missing, append NL if missing. Header lines with only
# spaces are not allowed. (RFC 5322: Each line of characters MUST be no more
# than 998 octets(!) (RFC 6532), and SHOULD be no more than 78 characters(!)
# (RFC 6532), excluding the CRLF). $structured==0 indicates an unstructured
# header field, folding may be inserted at any existing whitespace character
# position; $structured==1 indicates that folding is only allowed at positions
# indicated by \n in the provided header body, original \n will be removed.
# With $structured==2 folding is preserved, wrapping step is skipped.
#
sub hdr {
  my($field_name, $field_body, $structured, $wrap_char, $smtputf8) = @_;
  safe_encode_utf8_inplace($field_name);  # to octets (if not already)
  $field_name =~ tr/\x21-\x39\x3B-\x7E/?/c;  # printable ASCII except ':'
  my $field_body_is_utf8 = utf8::is_utf8($field_body);
  local($1);
  if ($field_body !~ tr/\x00-\x7F//c) {  # is all-ASCII
    # no encoding necessary, just clear the utf8 flag if set
    if ($field_body_is_utf8) {
      do_log(5,'header encoded (utf8:Y) (all-ASCII): %s: %s',
               $field_name, $field_body);
      safe_encode_utf8_inplace($field_body);  # to octets (if not already)
    } else {
      do_log(5,'header encoded (all-ASCII): %s: %s', $field_name, $field_body);
    }
  } elsif ($smtputf8) {  # UTF-8 in header field bodies is allowed
    safe_encode_utf8_inplace($field_body)  if $field_body_is_utf8;
    ll(5) && do_log(5,'header encoded (utf8:%s) to UTF-8 (SMTPUTF8): %s: %s',
                      $field_body_is_utf8?'Y':'N', $field_name, $field_body);
  } elsif ($field_name =~ /^(?: Subject | Comments |
                            (?:Resent-)? (?: From|Sender|To|Cc ) )\z/six &&
           $field_body !~ /^[\t\n\x20-\x7F]*\z/  # but printable or HT or LF
       # consider also:  | X- (?! Envelope- (?:From|To)\z )
  ) {  # encode according to RFC 2047
    # actually RFC 2047 also allows encoded-words in rfc822 extension
    # message header fields (now: optional header fields), within comments
    # in structured header fields, or within 'phrase' (e.g. in From, To, Cc);
    # we are being sloppy here!
    $field_body =~ s/\n(?=[ \t])//gs;  # unfold
    chomp($field_body);
    my $chset = c('hdr_encoding');
    my $field_body_octets = safe_encode($chset, $field_body);
    ll(5) && do_log(5,'header encoded (utf8:%s) to %s, %s: %s -> %s',
                      $field_body_is_utf8?'Y':'N', $chset,
                      $field_name, $field_body, $field_body_octets);
    my $qb = c('hdr_encoding_qb');
    my $encoder_func = uc $qb eq 'Q' ? \&q_encode
                                     : \&MIME::Words::encode_mimeword;
    $field_body = join("\n", map { /^[\001-\011\013\014\016-\177]*\z/ ? $_
                                     : &$encoder_func($_,$qb,$chset) }
                                 split(/\n/, $field_body_octets, -1));
  } else {  # should have been all-ASCII, or UTF-8 with SMTPUTF8 - but anyway:
    safe_encode_utf8_inplace($field_body)  if $field_body_is_utf8;
    ll(5) && do_log(5,'header encoded (utf8:%s) to UTF-8: %s: %s',
                      $field_body_is_utf8?'Y':'N', $field_name, $field_body);
  }
  my $str = $field_name . ':';
  $str .= ' '  if $field_body =~ /^[^ \t]/;  # insert space, looks nicer
  $str .= $field_body;
  if ($structured == 2) {  # already folded, keep it that way, sanitize
    1 while $str =~ s/^([ \t]*)\n/$1/;  # prefixed by whitespace lines?
    $str =~ s/\n(?=[ \t]*(\n|\z))//g;   # whitespace lines within or at end
    $str =~ s/\n(?![ \t])/\n /g;  # insert a space at line folds if missing
  } else {
    $str = wrap_string($str, 78, '', $wrap_char, $structured
                      )  if $structured==1 || length($str) > 78;
  }
  if (length($str) > 998) {
    my(@lines) = split(/\n/,$str);  my $trunc = 0;
    for (@lines) {
      if (length($_) > 998) { substr($_,998-3) = '...'; $trunc = 1 }
    }
    if ($trunc) {
      do_log(0, "INFO: truncating long header field (len=%d): %s[...]",
             length($str), substr($str,0,100) );
      $str = join("\n",@lines);
    }
  }
  $str =~ s{\n*\z}{\n}s;  # ensure a single final NL
  ll(5) && do_log(5, 'header: %s', $str);
  $str;
}

# Copy mail header section to the supplied method while adding, removing,
# or changing certain header fields as required, and append an empty line
# (header/body separator). Returns a number of original 'Received:'
# header fields to make a simple loop detection possible (as required
# by RFC 5321 (ex RFC 2821) section 6.3).
# Leaves input file positioned at the beginning of a body.
#
sub write_header($$$$) {
  my($self, $msginfo, $out_fh, $noninitial_submission) = @_;
  my $received_cnt = 0;
  my($fix_whitespace_lines, $fix_long_header_lines, $fix_bare_cr) = (0,0,0);
  if ($noninitial_submission && c('allow_fixing_improper_header')) {
    $fix_bare_cr = 1;
    $fix_long_header_lines = 1  if c('allow_fixing_long_header_lines');
    $fix_whitespace_lines  = 1  if c('allow_fixing_improper_header_folding');
  }
  my(@header); my $pos = 0; my $header_in_array = 0;
  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 (!defined $msg) {
    # empty mail
    $header_in_array = 1;
  } elsif (ref $msg eq 'SCALAR') {
    $header_in_array = 1;
    $pos = min($msginfo->skip_bytes, length($$msg));
    if ($pos >= length($$msg)) {  # empty message
      $pos = length($$msg);
    } elsif (substr($$msg,$pos,1) eq "\n") {  # empty header section
      $pos++;
    } else {
      my $ind = index($$msg, "\n\n", $pos);  # find header/body separator
      if ($ind < 0) {  # no body
        @header = split(/^/m, substr($$msg, $pos));
        $pos = length($$msg);
      } else {  # normal, nonempty header section and nonempty body
        @header = split(/^/m, substr($$msg, $pos, $ind+1-$pos));
        $pos = $ind+2;
      }
    }
    # $pos now points to the first byte of a body
  } elsif ($msg->isa('MIME::Entity')) {
    $header_in_array = 1;
    $fix_whitespace_lines = 1;  # fix MIME::Entity artifacts
    @header = @{$msg->header};
  } else {  # a file handle assumed
    $pos = $msginfo->skip_bytes;
    $msg->seek($pos,0)  or die "Can't rewind mail file: $!";
  }
  ll(5) && do_log(5, 'write_header: %s, %s', $header_in_array, $out_fh);
  # preallocate some storage
  my $str = ''; vec($str,8192,8) = 0; $str = '';
  $str .= $_  for @{$self->{prepend}};
  $str .= $_  for @{$self->{addrcvd}};
  my($ill_white_cnt, $ill_long_cnt, $ill_bare_cr) = (0,0,0);
  local($1,$2); my $curr_head; my $next_head; my $eof = 0;
  for (;;) {
    if ($eof) {
      $next_head = "\n";  # fake a missing header/body separator line
    } elsif ($header_in_array) {
      for (;;) {  # get next nonempty line or eof
        if (!@header) { $eof = 1; $next_head = "\n"; last }
        $next_head = shift @header;
        # ensure NL at end, faster than m/\n\z/
        $next_head .= "\n"  if substr($next_head,-1,1) ne "\n";
        last  if !$fix_whitespace_lines || $next_head !~ /^[ \t]*\n\z/s;
        $ill_white_cnt++;
      }
    } else {
      $! = 0; $next_head = $msg->getline;
      if (defined $next_head) {
        $pos += length($next_head);
      } else {
        $eof = 1; $next_head = "\n";
        $! == 0  or                # returning EBADF at EOF is a perl bug
          $! == EBADF ? do_log(0,"Error reading mail header section: $!")
                      : die "Error reading mail header section: $!";
      }
    }
    if ($next_head =~ /^[ \t]/) {
      $curr_head .= $next_head;  # folded
    } else {  # new header field
      if (!defined($curr_head)) {
        # no previous complete header field (we are at the first hdr field)
      } elsif ($curr_head !~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s) {  # parse
        # invalid header field, but we'll write it anyway
      } else {  # count, edit, or delete
        # obsolete RFC 822 syntax allowed whitespace before colon
        my($field_name, $field_body) = ($1, $2);
        my $field_name_lc = lc $field_name;
        $received_cnt++  if $field_name_lc eq 'received';
        if (exists($self->{edit}{$field_name_lc})) {
          chomp($field_body);
          ### $field_body =~ s/\n(?=[ \t])//gs;  # unfold
          my $edit = $self->{edit}{$field_name_lc};  # listref of edits
          for my $e (@$edit) {  # possibly multiple (iterative) edits
            my($new_fbody,$verbatim);
            ($new_fbody,$verbatim) =
              &$e($field_name,$field_body)  if defined $e;
            if (!defined($new_fbody)) {
              ll(5) && do_log(5, 'deleted: %s:%s', $field_name, $field_body);
              $curr_head = undef; last;
            }
            $curr_head = $verbatim ? ($field_name . ':' . $new_fbody)
                                   : hdr($field_name, $new_fbody, 0, undef,
                                         $msginfo->smtputf8);
            chomp($curr_head); $curr_head .= "\n";
            $curr_head =~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s;
            $field_body = $2; chomp($field_body);  # carry to next iteration
          }
        }
      }
      if (defined $curr_head) {
        if ($fix_bare_cr) { # sanitize header sect. by removing CR characters
          $curr_head =~ tr/\r//d  and $ill_bare_cr++;
        }
        if ($fix_whitespace_lines) {  # unfold illegal all-whitespace lines
          $curr_head =~ s/\n(?=[ \t]*\n)//g  and $ill_white_cnt++;
        }
        if ($fix_long_header_lines) {  # truncate long header lines to 998 ch
          $curr_head =~ s{^(.{995}).{4,}$}{$1...}gm  and $ill_long_cnt++;
        }
        # use buffering to reduce number of calls to datasend()
        if (length($str) > 16384) {
          $out_fh->print($str) or die "sending mail header: $!";
          $str = '';
        }
        $str .= $curr_head;
      }
      last  if $next_head eq "\n";   # header/body separator
      last  if substr($next_head,0,2) eq '--';  # mime sep. (missing h/b sep.)
      $curr_head = $next_head;
    }
  }
  do_log(0, "INFO: unfolded %d illegal all-whitespace ".
            "continuation lines", $ill_white_cnt)  if $ill_white_cnt;
  do_log(0, "INFO: truncated %d header line(s) longer than 998 characters",
            $ill_long_cnt)  if $ill_long_cnt;
  do_log(0, "INFO: removed bare CR from %d header line(s)",
            $ill_bare_cr)  if $ill_bare_cr;
  $str .= $_  for @{$self->{append}};
  $str .= "\n";  # end of header section - a separator line
  $out_fh->print($str) or die "sending mail header final: $!";
  section_time('write-header');
  ($received_cnt, $pos);
}
1;