#!/usr/bin/env perl

use strict;
use Fcntl qw(:DEFAULT :flock);
use Net::DNS;
use Net::SMTP;
use POSIX;

my ($proc,$vers,$date) =
  '$Id: fwdmail 18657 2007-08-12 23:48:53Z lefevre $'
  =~ /^.Id: (\S+) (\d+) (\d{4}-\d\d-\d\d \d\d:\d\d:\d\d)Z/ or die;

@ARGV >= 2 && @ARGV <= 4 or die <<EOF;
Usage: $proc <from_address> <to_address> [ <queue_directory> [ daemon ] ]
EOF

my ($from,$rcpt,$dir,$daemon) = @ARGV;
my $lock = "$dir/$proc.lock";
my $logf = "$dir/$proc.log";

if (defined $dir)
  {
    if ($daemon)
      {
        POSIX::setsid;
        my $pid = fork;
        defined $pid or die "$proc: can't fork: $!\n";
        exit if $pid;  # parent
        sysopen STDERR, $logf, O_CREAT|O_WRONLY|O_APPEND|O_SYNC, 0600
          or die "$proc: can't open log file in append mode\n$!\n";
        STDERR->autoflush(1);
        open STDOUT, '>&STDERR' or die "$proc: can't dup STDERR\n$!\n";
        STDOUT->autoflush(1);
      }
    open LOCK, '>', $lock or die "$proc: can't create lock file\n$!\n";
    flock LOCK, LOCK_EX | LOCK_NB or $daemon ? exit :
      die "$proc: can't lock process file - already running?\n$!\n";
  }

print "This is $proc $vers ($date)\n";

sub getconnect
  {
    my ($domain) = $rcpt =~ /@(.+)/ or die "$proc: bad address <$rcpt>\n";
    my $res = Net::DNS::Resolver->new;
    my @mx = mx($res, $domain) or die
      "$proc: can't find MX records for $domain: ", $res->errorstring, "\n";

    foreach my $rr (@mx)
      { print "$proc: MX ", $rr->preference, " ", $rr->exchange, "\n" }

    my $nodename = (POSIX::uname)[1];
    my $fqdn = (gethostbyname $nodename)[0];
    my @cmx;

    return sub
      {
        @cmx or @cmx = @mx;  # re-init the MX list if necessary.
        while (@cmx)
          {
            my $i = int rand @cmx;
            my $mx = $cmx[$i]->exchange;
            print "$proc: to $mx\n";
            my $smtp = Net::SMTP->new($mx, Hello => $fqdn);
            return $smtp if defined $smtp;
            warn "$proc: connection to $mx failed\n";
            splice @cmx, $i, 1;  # disable the MX.
          }
        return;
      }
  }

my $connect = getconnect;

my %err;

sub badfmt ($)
  {
    warn "$proc: bad mail format ($_[0])\n";
    return 2;
  }

sub fwd ($)
  {
    # See "How can I use a filehandle indirectly?" in perlfaq5(1).
    local *FH = shift;
    my ($bf,@contents);
    while (<FH>)
      {
        $. == 1 && /^From / and next;  # discard the "From " line.
        push @contents, $_;
        $bf and next;
        /^\S+:/ and $bf = 0, next;
        defined $bf or return badfmt "first line";
        /^$/ and $bf = 1, next;
        /^[ \t]/ or return badfmt "message header";
      }
    $bf or return badfmt "no message body";
    my $smtp = &$connect or return 3;
    print "$proc: connected\n";
    $smtp->mail($from);
    $smtp->recipient($rcpt);
    my $date = strftime("%d %b %Y %H:%M:%S %z", localtime);
    my $ok = $smtp->data("Received: ($proc $vers invoked by uid $<); $date\n",
                         @contents) or warn "$proc: failed!\n";
    $smtp->quit;
    print "$proc: connection closed\n";
    return !$ok;
  }

if (defined $dir)
  {
    while (1)
      {
        opendir DIR, "$dir"
          or die "$proc: can't open directory '$dir'\n$!\n";
        my @d = grep /^mail\./, readdir DIR;
        closedir DIR;
        foreach my $file (@d)
          {
            $file = "$dir/$file";
            -f $file or next;
            my $mtime = (stat $file)[9];
            my $incr = 60;  # time increment for retries.
            if ($err{$file} =~ /^(\d+):(\d+):(\d+)$/)
              {
                # If the file has been modified, reset $incr to its
                # first value.
                next if $mtime == $1 &&
                  ($incr = $3, time < $2 || $3 > 864000);
                delete $err{$file};
              }
            open FILE, '+<', $file
              or warn("$proc: can't open file '$file'\n$!\n"), next;
            flock FILE, LOCK_EX | LOCK_NB
              or warn("$proc: can't lock file '$file'\n$!\n"), next;
            print "$proc: sending '$file'\n";
            if (fwd *FILE)
              {
                my $rtime = time + $incr;
                warn "$proc: retry at ".
                  strftime("%Y-%m-%d %T", gmtime($rtime))." (UTC)\n";
                # But one will retry before this time if file is modified.
                $err{$file} = join ':', $mtime, $rtime, 5 * $incr;
              }
            else
              {
                unlink $file;
              }
            close FILE;
          }
        sleep 20;
      }
  }

print "$proc: sending the contents of standard input\n";
exit fwd *STDIN;

__END__

=head1 NAME

fwdmail - simple mail forwarder, bypassing the local queue

=head1 SYNOPSIS

fwdmail I<from_address> I<to_address> [ I<queue_directory> [ daemon ] ]

=head1 DESCRIPTION

This program allows you to forward mail messages by SMTP to some given
address. It does not use the local SMTP client (generally invoked as
I<sendmail>), so that the local queue can be bypassed (this is useful
if it is full of mailer-daemons due to some spam attacks).

There are 3 modes, depending on the arguments:

=over 4

=item *

C<STDIN> mode (2 arguments). The mail message is obtained from
the standard input. In case of failure, B<fwdmail> exits with
a non-zero status, and the mail data are lost (you should do a
copy before executing B<fwdmail>, if need be).

=item *

Queue mode: B<fwdmail> loops forever and looks for messages in
some queue directory (the filenames must start with "mail.").
Once a message has successfully been sent, it is removed from
the queue. In case of failure, B<fwdmail> leaves the message
in the queue; it will retry a few times later (check the queue
from time to time: B<fwdmail> will never bounce the message).

=item *

Daemon mode (4 arguments, the 4th one must evaluate to I<true>):
It is like the queue mode, with the following changes. First,
B<fwdmail> forks itself (the parent quits) and runs in a new
session. The standard output and error streams are redirected
to the log file F<fwdmail.log> inside the queue directory.
This mode avoids any output or error if a B<fwdmail> process is
already running (so that one can unconditionally start B<fwdmail>
from a I<procmailrc>).

=back

For more information, please look at the source.

This program can be invoked from a script that receives the message
on its standard input, like the following one:

  #!/bin/sh
  set -e
  umask 077
  export TMPDIR="$HOME/Mail/queue"
  file=`mktemp -p "$TMPDIR" mail.XXXXXXXX 2> /dev/null || \
        mktemp -t mail 2> /dev/null`
  # Let's prevent fwdmail from reading the message file
  # until it is complete.
  chmod 200 "$file"
  cat >> "$file"
  chmod 600 "$file"
  fwdmail user@src-domain user@dst-domain "$TMPDIR" daemon

and a I<procmail> rule can run this script with something like:

  :0
  | $HOME/bin/fwdmail-wrapper

=head1 AUTHOR

Vincent Lefèvre <vincent@vinc17.org>

=head1 COPYRIGHT

Copyright (c) 2007 Vincent Lefèvre.

This program is free software; you may redistribute it
and/or modify it under the same terms as Perl itself.

=head1 REFERENCES

I used the following documentation to write this script:

=over 4

=item *

Man pages: L<Net::SMTP>, L<Net::DNS>.

=item *

L<http://articles.mongueurs.net/magazines/linuxmag59.html>.

=back

=cut