#! /usr/bin/perl

# Copyright (c) The Exim Maintainers 2023 - 2025
# SPDX-License-Identifier: GPL-2.0-or-later
# See the file NOTICE for conditions of use and distribution.

# Utility for one-time upgrage/downgrade between exim message-id formats,
# around the 4.97 transition


use strict;
use warnings;
use Fcntl qw(:DEFAULT :seek);
use File::Basename;
use File::Find;
use Getopt::Long;
use IO::Handle;

# Insert MSGID_RE
# Start msgid.frag
# Copyright (c) The Exim Maintainers 2025
# SPDX-License-Identifier: GPL-2.0-or-later
#
# Regex patterns for exim message-id

# Simple matching

my $b62 = "[[:alnum:]]";

my $msgid_sec_re = "${b62}{6}";
my $msgid_pid_new_re = "${b62}{11}";
my $msgid_pid_old_re = "${b62}{6}";
my $msgid_frc_new_re = "${b62}{4}";
my $msgid_frc_old_re = "${b62}{2}";

my $msgid_new_re = "$msgid_sec_re-$msgid_pid_new_re-$msgid_frc_new_re";
my $msgid_old_re = "$msgid_sec_re-$msgid_pid_old_re-$msgid_frc_old_re";
my $msgid_re =     "(?:$msgid_new_re|$msgid_old_re)";


# Match with content submatches
# - requires variables seconds, pid, fractions

my $msgid_sec_cap_re = "(?<seconds>$msgid_sec_re)";
my $msgid_pid_cap_re = "(?<pid>(?:$msgid_pid_new_re|$msgid_pid_old_re))";
my $msgid_frc_cap_re = "(?<fractions>(?:$msgid_frc_new_re|$msgid_frc_old_re))";

my $msgid_cap_re = "(?:$msgid_sec_cap_re-$msgid_pid_cap_re-$msgid_frc_cap_re)";

# End msgid.frag

my $ME = basename($0);
my $help = <<"EOF";
Utility for one-time down/upgrade of Exim message-id formats
in spool files.  Only the filenames and first-line ID tag values
are affected; not message content such as Message-ID fields.
Only -H, -D and -J files are handled.

Usage: $ME [-d | -u | -h | -v] [spooldir]

	-d --downgrade downgrade mode
	-h --help      help message
	-u --upgrade   upgrade mode
	-v --version   show version and exit cleanly
	--verbose      more output about what's going on
	--force        force overwriting (may be required after failure)
	--dry          dry run (do file operations, but cleanup and keep the old files)

Exactly one of -d|--downgrade or -u|--upgrade must be given.
The spool directory defaults to the build-time value,
or can be given as a command-line argument.
EOF

GetOptions(\my %opt,
        'help|h!',
        'version|v!',
        'upgrade|u!',
        'downgrade|d!',
        'force!',
        'verbose!',
        'dry!',
) or print STDERR $help and exit(1);

if ($opt{version}) {
    print "exim_id_update:\n",
          "build: 4.99.3\n",
          "perl(runtime): $]\n";
    exit 0;
}

print $help and exit 0 if $opt{help};

# No help requested, do further option processing
my $spool = $ARGV[0] // '/var/spool/exim'; # This variable should be set by the building process

die "$ME: --upgrade and --downgrade are mutually exclusive\n" if $opt{upgrade} && $opt{downgrade};
die "$ME: one of --upgrade or --downgrade is required\n" if !$opt{upgrade} && !$opt{downgrade};

require File::FcntlLock;
File::FcntlLock->import;

# For downgrade mode:
# - Check exim not running
# - Wipe any wait-hints DBs, buy just removing the files.
# For all queue (main and named), with split-spool if needed, for each file identifiable
# as a spoolfile (name starts with an ID, ends with -H -D -J -K)
#  XXX are there only subsets we can handle - eg. a -H + a -D ?
#    mainline code sequence is -D (locks msg) -H ?-J
#    mainline locking sequence (spool_open_datafile()) is
#	- open -D
#	- fnctl F_LOCK  (amount = first line of file)

# The -H and -D files contain the ID as their initial line.
# The -J file
# - records successful deliveries, as insurance vs. crashes
# - has lines with mail addresses
# The -K file
# - is a temp for DKIM'd delivery when a transport-filter is in use
# - contains the message that would have been put on the wire (except for encryption)
#  - the transport, with tpt-filter, writes the file - and then reads it
#    so as to generate the DKIM signature.  Then it sends the message, with
#    generated headers and reading the file again, down the wire.
#    And then it deletes it.
# - unclear if we really want to rewrite these files, if we do see then
#   Probably not.

# - if old-format name:
#   - lock old message
#   - generate new files, in safe sequence
#   - remove old files	(do we need to archive?)
#

# loop for default Q, named Qs
#  loop for plain, split-spool
#   loop over files
#    if is -H, and -D exists
#
#     create new ID string from old
#     lock the old -D
#     create new -D
#     lock new -D
#     create new -H
#
#     if -J exists
#      rename old -J to new -J
#
#     remove old -H
#     remove old -D
#     unlock new -D
#
#
my $id;
my $pattern = do {
        # setup the pattern, creating match groups already

        $opt{upgrade} ? qr/^(?<prefix>(${b62}{6})-(${b62}{6})-(${b62}{2}))-D$/ : qr/^(?<prefix>(${b62}{6})-${b62}{5}(${b62}{6})-(${b62}{2})${b62}{2})-D$/;
};

chdir $spool or die "chdir to $spool: $!\n";
find( sub { do_file($_) if -f }, '.');
exit 0;


sub do_file {
  (my $old_dfile = shift) =~ /$pattern/ or return;

  # $1…$4 are set by the regexp match
  my $old_prefix = $+{prefix};
  my $new_prefix = $opt{upgrade}
        ? "$2-00000$3-${4}00"
        : "$2-$3-$4";

  my $old_hfile = "$old_prefix-H";

  # The -H file must also exist, otherwise something is broken
  return if not -e $old_hfile;

  my $old_jfile = "$old_prefix-J";
  my $new_dfile = "$new_prefix-D";
  my $new_hfile = "$new_prefix-H";
  my $new_jfile = "$new_prefix-J";

  print "$old_prefix -> $new_prefix\n" if $opt{verbose};

  ####### create the new -D file
  open my $d_old, '+<', $old_dfile or die "Can't open file: $!\n";

  # lock the old -D file and seek past the first line
  lock_range($d_old, 2 + length($old_prefix)); # 2 for -D
  <$d_old>;

  # create and lock the new -D file
  my $d_new = f_create($new_dfile, $old_dfile);
  lock_range($d_new, 2 + length($new_prefix)); # 2 for -D

  # write the new message-id to the first line
  # and copy the rest of the -D file
  print $d_new "$new_prefix-D\n";
  print $d_new $_ while <$d_old>;

  ####### create the new -H file
  open my $h_old, '<', $old_hfile or die "Can't open file: $!\n";
  <$h_old>;

  my $h_new = f_create($new_hfile, $old_hfile);
  print $h_new "$new_prefix-H\n";
  print $h_new $_ while <$h_old>;

  if ($opt{dry}) {
        unlink $new_hfile, $new_dfile; # make sure they're removed, even if we die during close
        close $h_new or die "close $new_hfile: $!\n";
        close $d_new or die "close $new_dfile: $!\n";
        return; # this will close the all file handles that are still open (and release their locks)
  }

  ###### rename a journal file if it exists
  rename $old_jfile => $new_jfile
        or $!{ENOENT}
        or die "Can't rename $old_jfile to $new_jfile: $!\n";

  ###### tidy up
  # close the files we wrote, to be sure that there's nothing wrong
  # the locks are released implicitly by closing the file handles.
  close $h_new or die "$h_new: $!\n";
  close $d_new or die "$d_new: $!\n";

  unlink $old_hfile or die "failed to remove $old_hfile: $!\n";
  unlink $old_dfile or die "failed to remove $old_dfile: $!\n";

  # no need to explicitly close the $d_old, $h_old, they're closed
  # automatically when they go out of scope. And the locks are released
  # by the OS after closing the files.
}

sub lock_range {
  my $fh = shift;
  my $nbytes = shift;
  my $fs = new File::FcntlLock;

  $fs->l_type( F_WRLCK );
  $fs->l_whence( SEEK_CUR );
  $fs->l_start( 0 );
  $fs->l_len( $nbytes );

  $fs->lock( $fh, F_SETLK )
      or die "Locking failed: " . $fs->error . "\n";
}

sub f_create {
  my ($filename, $reference) = @_;
  sysopen(my $fh, $filename, O_RDWR|O_CREAT| ($opt{force} ? 0 : O_EXCL))
      or die "Can't create $filename: $!";
  my ($perms, $uid, $gid) = (stat $reference)[2,4,5] or die "Can't stat reference $reference: $!\n";
  chown $uid, $gid => $fh or die "chown $filename: $!\n";
  chmod $perms & 07777 => $fh or die "chmod $filename: $!\n";
  return $fh;
}

# vim:ft=perl: