src/util/chunking_fixqueue_finalnewlines.pl

   1 #!/usr/bin/env perl
   2 # Copyright (c) The Exim Maintainers 2022
   3 # SPDX-License-Identifier: GPL-2.0-or-later
   4
   5 use warnings;
   6 use strict;
   7 BEGIN { pop @INC if $INC[-1] eq '.' };
   8
   9 use Fcntl qw(:DEFAULT :flock :seek);
  10 use File::Find;
  11 use File::Spec;
  12
  13 use constant MIN_AGE => 60; # seconds
  14 my $exim = exists $ENV{'EXIM_BINARY'} ? $ENV{'EXIM_BINARY'} : 'exim';
  15
  16 my %known_okay = map {$_=>1} qw( linux darwin freebsd );
  17 unless (exists $known_okay{$^O}) {
  18   warn "for ease, this perl uses flock, not fcntl, assuming they're the same\n";
  19   warn "this is not known by this author to be the case on $^O\n";
  20   warn "please investigate and either add to allowed-list in script, or rewrite\n";
  21   die "bailing out";
  22
  23   # Another approach to rewriting script: stop all exim receivers and
  24   # queue-runners, prevent them from starting, then add your OS to the list and
  25   # run, even though the locking type is wrong, relying upon not actually
  26   # contending.
  27 }
  28
  29 my $spool_dir = `$exim -n -bP spool_directory`;
  30 chomp $spool_dir;
  31
  32 chdir(File::Spec->catfile($spool_dir, 'input'))
  33     or die "chdir($spool_dir/input) failed: $!\n";
  34
  35 my $exim_msgid_r = qr/(?:[0-9A-Za-z]{6}-[0-9A-Za-z]{6}-[0-9A-Za-z]{2})/;
  36 my $spool_dfile_r = qr/^(($exim_msgid_r)-D)\z/o;
  37
  38 sub fh_ends_newline {
  39   my ($fh, $dfn, $verbose) = @_;
  40   seek($fh, -1, 2) or do { warn "seek(file($dfn)) failed: $!\n"; return -1 };
  41   my $count = read $fh, my $ch, 1;
  42   if ($count == -1) { warn "failed to read last byte of $dfn\n"; return -1 };
  43   if ($count == 0) { warn "file shrunk by one??  problem with $dfn\n"; return -1 };
  44   if ($ch eq "\n") { print "okay!\n" if $verbose; return 1 }
  45   print "PROBLEM: $dfn missing final newline (got $ch)\n" if $verbose;
  46   return 0;
  47 }
  48
  49
  50 sub each_found_file {
  51   return unless $_ =~ $spool_dfile_r;
  52   my ($msgid, $dfn) = ($2, $1);
  53
  54   # We should have already upgraded Exim before invoking us, thus any spool
  55   # files will be old and we can reduce spending time trying to lock files
  56   # still being written to, etc.
  57   my @st = lstat($dfn) or return;
  58   if ($^T - $st[9] < MIN_AGE) { return };
  59   -f "./${msgid}-H" || return;
  60
  61   print "consider: $dfn\n";
  62   open(my $fh, '+<:raw', $dfn) or do {
  63     warn "open($dfn) failed: $!\n";
  64     return;
  65   };
  66   # return with a lexical FH in modern Perl should guarantee close, AIUI
  67
  68   # we do our first check without a lock, so that we can scan past messages
  69   # being handled by Exim quickly, and only lock up on those which Exim is
  70   # trying and failing to deliver.  However, since Exim will be hung on remote
  71   # hosts, this is likely.  Thus best to kill queue-runners first.
  72
  73   return if fh_ends_newline($fh, $dfn, 0); # also returns on error
  74   print "Problem? $msgid probably missing newline, locking to be sure ...\n";
  75   flock($fh, LOCK_EX) or do { warn "flock(file($dfn)) failed: $!\n"; return };
  76   return if fh_ends_newline($fh, $dfn, 1); # also returns on error
  77
  78   fixup_message($msgid, $dfn, $fh);
  79
  80   close($fh) or warn "close($dfn) failed: $!\n";
  81 };
  82
  83 sub fixup_message {
  84   my ($msgid, $dfn, $fh) = @_;
  85   # we can't freeze the message, our lock stops that, which is good!
  86
  87   seek($fh, 0, 2) or do { warn "seek(file($dfn)) failed: $!\n"; return -1 };
  88
  89   my $r = inc_message_header_linecount($msgid);
  90   if ($r < 0) {
  91     warn "failed to fix message headers in ${msgid}-H so not editing message\n";
  92     return;
  93   }
  94
  95   print {$fh} "\n";
  96
  97   print "${msgid}: added newline\n";
  98 };
  99
 100 sub inc_message_header_linecount {
 101   my ($msgid) = @_;
 102   my $name_in = "${msgid}-H";
 103   my $name_out = "${msgid}-chunkfix";
 104
 105   open(my $in, '<:perlio', $name_in) or do { warn "open(${name_in}) failed: $!\n"; return -1 };
 106   open(my $out, '>:perlio', $name_out) or do { warn "write-open(${name_out}) failed: $!\n"; return -1 };
 107   my $seen = 0;
 108   my $lc;
 109   foreach (<$in>) {
 110     if ($seen) {
 111       print {$out} $_;
 112       next;
 113     }
 114     if (/^(-body_linecount\s+)(\d+)(\s*)$/) {
 115       $lc = $2 + 1;
 116       print {$out} "${1}${lc}${3}";
 117       $seen = 1;
 118       next;
 119     }
 120     print {$out} $_;
 121   }
 122   close($in) or do {
 123     warn "read-close(${msgid}-H) failed, assuming incomplete: $!\n";
 124     close($out);
 125     unlink $name_out;
 126     return -1;
 127   };
 128   close($out) or do {
 129     warn "write-close(${msgid}-chunkfix) failed, aborting: $!\n";
 130     unlink $name_out;
 131     return -1;
 132   };
 133
 134   my @target = stat($name_in) or do { warn "stat($name_in) failed: $!\n"; unlink $name_out; return -1 };
 135   my @created = stat($name_out) or do { warn "stat($name_out) failed: $!\n"; unlink $name_out; return -1 };
 136   # 4=uid, 5=gid, 2=mode
 137   if (($created[5] != $target[5]) or ($created[4] != $target[4])) {
 138     chown $target[4], $target[5], $name_out or do {
 139       warn "chown($name_out) failed: $!\n";
 140       unlink $name_out;
 141       return -1;
 142     };
 143   }
 144   if (($created[2]&07777) != ($target[2]&0x7777)) {
 145     chmod $target[2]&0x7777, $name_out or do {
 146       warn "chmod($name_out) failed: $!\n";
 147       unlink $name_out;
 148       return -1;
 149     };
 150   }
 151
 152   rename $name_out, $name_in or do {
 153     warn "rename '${msgid}-chunkfix' -> '${msgid}-H' failed: $!\n";
 154     unlink $name_out;
 155     return -1;
 156   };
 157
 158   print "${msgid}: linecount set to $lc\n";
 159   return 1;
 160 }
 161
 162 find({wanted => \&each_found_file}, '.');