Fix broken-in-queue messages predating CHUNKING fix

util/chunking_fixqueue_finalnewlines.pl walks the queue, fixing any
affected messages; see README.UPDATING.

We're extremely cautious about operation failure.

We do one check without locking messages, so that we can quickly skip
past before trying to lock and contending with an actual delivery.  Then
we lock and do another fix.

Note that we use flock, not fcntl, because that's what Perl makes
readily available; we use an OS-guard to barf if the OS is not handled.

2 files changed, 169 insertions, 0 deletions

diff --git a/src/README.UPDATING b/src/README.UPDATING
index 5dbc8afb4..05b3d9d97 100644
--- a/src/README.UPDATING
+++ b/src/README.UPDATING
@@ -29,6 +29,15 @@ that might affect a running system.
 Exim version 4.89
 -----------------
 
+ * SMTP CHUNKING in Exim 4.88 did not ensure that received mails had a final
+   newline; attempts to deliver such messages onwards to non-chunking hosts
+   would probably hang, as Exim does not insert the newline before a ".".
+   In 4.89, the newline is added upon receipt.  For already-received messages
+   in your queue, try util/chunking_fixqueue_finalnewlines.pl
+   to walk the queue, fixing any affected messages.  Note that because a
+   delivery attempt will be hanging, attempts to lock the messages for fixing
+   them will stall; stopping all queue-runners temporarily is recommended.
+
  * OpenSSL: oldest supported release series is now 1.0.2, which is the oldest
    supported by the OpenSSL project.  If you can build Exim with an older
    release series, congratulations.  If you can't, then upgrade.
diff --git a/src/util/chunking_fixqueue_finalnewlines.pl b/src/util/chunking_fixqueue_finalnewlines.pl
new file mode 100755
index 000000000..5dddfa505
--- /dev/null
+++ b/src/util/chunking_fixqueue_finalnewlines.pl
@@ -0,0 +1,160 @@
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+BEGIN { pop @INC if $INC[-1] eq '.' };
+
+use Fcntl qw(:DEFAULT :flock :seek);
+use File::Find;
+use File::Spec;
+
+use constant MIN_AGE => 60; # seconds
+my $exim = exists $ENV{'EXIM_BINARY'} ? $ENV{'EXIM_BINARY'} : 'exim';
+
+my %known_okay = map {$_=>1} qw( linux darwin freebsd );
+unless (exists $known_okay{$^O}) {
+  warn "for ease, this perl uses flock, not fcntl, assuming they're the same\n";
+  warn "this is not known by this author to be the case on $^O\n";
+  warn "please investigate and either add to allowed-list in script, or rewrite\n";
+  die "bailing out";
+
+  # Another approach to rewriting script: stop all exim receivers and
+  # queue-runners, prevent them from starting, then add your OS to the list and
+  # run, even though the locking type is wrong, relying upon not actually
+  # contending.
+}
+
+my $spool_dir = `$exim -n -bP spool_directory`;
+chomp $spool_dir;
+
+chdir(File::Spec->catfile($spool_dir, 'input'))
+    or die "chdir($spool_dir/input) failed: $!\n";
+
+my $exim_msgid_r = qr/(?:[0-9A-Za-z]{6}-[0-9A-Za-z]{6}-[0-9A-Za-z]{2})/;
+my $spool_dfile_r = qr/^(($exim_msgid_r)-D)\z/o;
+
+sub fh_ends_newline {
+  my ($fh, $dfn, $verbose) = @_;
+  seek($fh, -1, 2) or do { warn "seek(file($dfn)) failed: $!\n"; return -1 };
+  my $count = read $fh, my $ch, 1;
+  if ($count == -1) { warn "failed to read last byte of $dfn\n"; return -1 };
+  if ($count == 0) { warn "file shrunk by one??  problem with $dfn\n"; return -1 };
+  if ($ch eq "\n") { print "okay!\n" if $verbose; return 1 }
+  print "PROBLEM: $dfn missing final newline (got $ch)\n" if $verbose;
+  return 0;
+}
+
+
+sub each_found_file {
+  return unless $_ =~ $spool_dfile_r;
+  my ($msgid, $dfn) = ($2, $1);
+
+  # We should have already upgraded Exim before invoking us, thus any spool
+  # files will be old and we can reduce spending time trying to lock files
+  # still being written to, etc.
+  my @st = lstat($dfn) or return;
+  if ($^T - $st[9] < MIN_AGE) { return };
+  -f "./${msgid}-H" || return;
+
+  print "consider: $dfn\n";
+  open(my $fh, '+<:raw', $dfn) or do {
+    warn "open($dfn) failed: $!\n";
+    return;
+  };
+  # return with a lexical FH in modern Perl should guarantee close, AIUI
+
+  # we do our first check without a lock, so that we can scan past messages
+  # being handled by Exim quickly, and only lock up on those which Exim is
+  # trying and failing to deliver.  However, since Exim will be hung on remote
+  # hosts, this is likely.  Thus best to kill queue-runners first.
+
+  return if fh_ends_newline($fh, $dfn, 0); # also returns on error
+  print "Problem? $msgid probably missing newline, locking to be sure ...\n";
+  flock($fh, LOCK_EX) or do { warn "flock(file($dfn)) failed: $!\n"; return };
+  return if fh_ends_newline($fh, $dfn, 1); # also returns on error
+
+  fixup_message($msgid, $dfn, $fh);
+
+  close($fh) or warn "close($dfn) failed: $!\n";
+};
+
+sub fixup_message {
+  my ($msgid, $dfn, $fh) = @_;
+  # we can't freeze the message, our lock stops that, which is good!
+
+  seek($fh, 0, 2) or do { warn "seek(file($dfn)) failed: $!\n"; return -1 };
+
+  my $r = inc_message_header_linecount($msgid);
+  if ($r < 0) {
+    warn "failed to fix message headers in ${msgid}-H so not editing message\n";
+    return;
+  }
+
+  print {$fh} "\n";
+
+  print "${msgid}: added newline\n";
+};
+
+sub inc_message_header_linecount {
+  my ($msgid) = @_;
+  my $name_in = "${msgid}-H";
+  my $name_out = "${msgid}-chunkfix";
+
+  open(my $in, '<:perlio', $name_in) or do { warn "open(${name_in}) failed: $!\n"; return -1 };
+  open(my $out, '>:perlio', $name_out) or do { warn "write-open(${name_out}) failed: $!\n"; return -1 };
+  my $seen = 0;
+  my $lc;
+  foreach (<$in>) {
+    if ($seen) {
+      print {$out} $_;
+      next;
+    }
+    if (/^(-body_linecount\s+)(\d+)(\s*)$/) {
+      $lc = $2 + 1;
+      print {$out} "${1}${lc}${3}";
+      $seen = 1;
+      next;
+    }
+    print {$out} $_;
+  }
+  close($in) or do {
+    warn "read-close(${msgid}-H) failed, assuming incomplete: $!\n";
+    close($out);
+    unlink $name_out;
+    return -1;
+  };
+  close($out) or do {
+    warn "write-close(${msgid}-chunkfix) failed, aborting: $!\n";
+    unlink $name_out;
+    return -1;
+  };
+
+  my @target = stat($name_in) or do { warn "stat($name_in) failed: $!\n"; unlink $name_out; return -1 };
+  my @created = stat($name_out) or do { warn "stat($name_out) failed: $!\n"; unlink $name_out; return -1 };
+  # 4=uid, 5=gid, 2=mode
+  if (($created[5] != $target[5]) or ($created[4] != $target[4])) {
+    chown $target[4], $target[5], $name_out or do {
+      warn "chown($name_out) failed: $!\n";
+      unlink $name_out;
+      return -1;
+    };
+  }
+  if (($created[2]&07777) != ($target[2]&0x7777)) {
+    chmod $target[2]&0x7777, $name_out or do {
+      warn "chmod($name_out) failed: $!\n";
+      unlink $name_out;
+      return -1;
+    };
+  }
+
+  rename $name_out, $name_in or do {
+    warn "rename '${msgid}-chunkfix' -> '${msgid}-H' failed: $!\n";
+    unlink $name_out;
+    return -1;
+  };
+
+  print "${msgid}: linecount set to $lc\n";
+  return 1;
+}
+
+find({wanted => \&each_found_file}, '.');