#!/usr/bin/env perl

# Note: if the domain part of the "to" address has no MX records, then
# assume that it is the server name and that mail delivery is local.

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

my ($proc,$vers,$date) =
  '$Id: fwdmail 46237 2011-09-11 21:55:56Z vinc17/xvii $'
  =~ /^.Id: (\S+) (\d+) (\d{4}-\d\d-\d\d \d\d:\d\d:\d\d)Z/ or die;

my ($daemon,$dir);
my $port = 25;
GetOptions('daemon' => \$daemon,
           'port=i' => \$port,
           'queue=s' => \$dir)
  && @ARGV == 2 or die <<EOF;
Usage: $proc [ options ] <from_address> <to_address>
Options:
  --daemon      daemon mode (needs the --queue option)
  --port=PORT   remote SMTP port
  --queue=DIR   queue directory
EOF

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

sub msg ($)
  { print strftime("[%Y-%m-%d %T]", gmtime), " $proc: $_[0]\n" }

sub daemon_exit
  {
    msg "SIG$_[0] received, exiting." if $daemon;
    unlink $lock;
    exit;
  }

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";
    LOCK->autoflush(1);
    seek LOCK, 0, 0 or die "$proc: seek failed on the lock file\n$!\n";
    truncate LOCK, 0 or die "$proc: truncate failed on the lock file\n$!\n";
    print LOCK "$$\n" or die "$proc: print failed on the lock file\n$!\n";
    $SIG{HUP}  = \&daemon_exit;
    $SIG{INT}  = \&daemon_exit;
    $SIG{QUIT} = \&daemon_exit;
    $SIG{TERM} = \&daemon_exit;
  }

print "This is $proc $vers ($date)\n";
msg "using FROM $from";

$SIG{USR1} = 'IGNORE';

sub min ($$)
  {
    return $_[0] < $_[1] ? $_[0] : $_[1];
  }

sub getconnect
  {
    $gctime = time;
    my ($domain) = $rcpt =~ /@(\S+)$/ or die "$proc: bad address <$rcpt>\n";
    $domain =~ s/:(\d+)$// and $port = $1;
    my $res = Net::DNS::Resolver->new;
    my @mx = mx($res, $domain)
      or undef $gctime, $rcpt =~ s/@.*//,
        msg "can't find MX records for $domain";

    foreach my $rr (@mx)
      { msg "MX ".$rr->preference." ".$rr->exchange }

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

    return sub
      {
        # Order the MX servers by priority, and randomize the servers
        # with the same priority. See
        #   http://en.wikipedia.org/wiki/MX_record
        my %cmx;
        foreach my $rr (@mx)
          { $cmx{$rr->exchange} = $rr->preference + rand }
        foreach my $mx (@mx ? sort { $cmx{$a} <=> $cmx{$b} } keys %cmx :
                        ($domain))
          {
            msg "to $mx";
            my $smtp = Net::SMTP->new($mx, Hello => $fqdn, Port => $port);
            return $smtp if defined $smtp;
            msg "connection to $mx:$port failed";
          }
        return;
      }
  }

my $connect = getconnect;

my %err;

sub badfmt ($)
  {
    msg "bad mail format ($_[0])";
    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 $retry = 10;
    my $smtp;
    until ($smtp = &$connect)
      {
        # A USR1 signal can be used to interrupt the sleep.
        $SIG{USR1} = sub { };
        my $rtime = time + $retry;
        msg "connection retry at ".
          strftime("%Y-%m-%d %T", gmtime($rtime))." (UTC)";
        sleep $retry;
        $SIG{USR1} = 'IGNORE';
        $retry *= 2;
      }
    msg "connected";
    $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);
    if (!$ok)
      {
        my $code = $smtp->code();
        msg "failed ($code)!";
        # A permanent rejection should never happen here. This may indicate
        # a bad configuration. So, in order to avoid a bad use of the MX or
        # lost mail, let's temporarily stop the e-mail forwarder until the
        # problem is dealt with in a better way (if I no loger receive any
        # mail, I'll notice that).
        kill 'STOP', $$ if $code =~ /^5\d\d$/;
      }
    $smtp->quit;
    msg "connection closed";
    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 && ($2 == 0 || ($incr = $3, time < $2));
                delete $err{$file};
              }
            # Perform a DNS request for the MX every day.
            defined $gctime && time - $gctime > 86400
              and $connect = getconnect;
            open FILE, '+<', $file
              or msg "can't open file '$file'\n$!", next;
            flock FILE, LOCK_EX | LOCK_NB
              or msg "can't lock file '$file'\n$!", next;
            msg "sending '$file'";
            my $ret = fwd *FILE;
            if ($ret == 2)
              {
                msg "will not retry until the file is modified";
                $err{$file} = "$mtime:0:0";
              }
            elsif ($ret)
              {
                my $rtime = time + $incr;
                msg "retry at ".
                  strftime("%Y-%m-%d %T", gmtime($rtime))." (UTC)";
                # But one will retry before this time if file is modified.
                $err{$file} = join ':', $mtime, $rtime,
                  min(5 * $incr, 864000);
              }
            else
              {
                unlink $file;
              }
            close FILE;
            sleep 1;
          }
        sleep 20;
      }
  }

msg "sending the contents of standard input";
exit fwd *STDIN;

__END__

=encoding utf8

=head1 NAME

fwdmail - simple mail forwarder, bypassing the local queue

=head1 SYNOPSIS

fwdmail [ options ] I<from_address> I<to_address>

=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 (no queue directory).  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 some time later (check the queue
from time to time: B<fwdmail> will never bounce the message),
except in case of bad format (the message will be ignored until
it is modified).

=item *

Daemon mode (--daemon option):
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

In queue/daemon mode, if B<fwdmail> cannot connect to any SMTP server,
it will sleep and retry from time to time (twice longer each time).
To interrupt the sleep, you can send the USR1 signal.

For more information, please look at the source.

This program can be invoked from a script B<fwdmail-wrapper> 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 --daemon --queue "$TMPDIR" user@src-domain user@dst-domain

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

  :0
  | $HOME/bin/fwdmail-wrapper

or in a F<.forward> file:

  | $HOME/bin/fwdmail-wrapper

=head1 AUTHOR

Vincent Lefèvre <vincent@vinc17.net>

=head1 COPYRIGHT

Copyright (c) 2007, 2008, 2009, 2010, 2011 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