sendmail-milter   [plain text]

#!/usr/bin/perl
#
# Sendmail Milter to perform SPF lookups
#
# (If you use the shebang line, make sure it contains
# a thread-enabled Perl!)
#
# Code by Mark Kramer <admin@asarian-host.net> on December 3, 2003
#
# Version 1.30
#
# Last revision: January 30, 2004
#
# With thanks to Alain Knaff for adding improved "Getopt" functionality,
# waitpid stuff to ensure spf-milter parent does not exit until child
# is really up and running, a new option to kill the milter, and one to
# add local policy.

# Tested under Perl, v5.8.0 built for i386-freebsd-thread-multi,
# using the Sendmail::Milter 0.18 engine.
#
# Licensed under GPL
#
# see: http://spf.pobox.com/
#
# availability: bundled with Mail::SPF::Query on CPAN
#               or at http://spf.pobox.com/downloads.html
#
# this version is compatible with SPF draft 02.9.4.
#

# INSTALLATION:
# =============
#
# Basic INSTALL doc at http://spf.pobox.com/sendmail-milter-INSTALL.txt
#
# Adiitional install notes by Alain Knaff:
#
# The milter must be started/stopped explicitly before/after sendmail.
# Add the following to /etc/init.d/sendmail to start it (must be
# before starting sendmail):
#
#   $SPF_MILTER -l 'include:local-forwarders' mail
#
# where local-forwarders is the name of a pseudo-domain holding an SPF
# record describing all hosts allowed to bypass SPF checks (typically,
# foreign hosts on which your users have set up .forwards pointing
# towards addresses hosted by you). If none of your users have set up
# any forwarding, you can leave this away
#
# Add the following to stop it (must be after stopping sendmail):
#
#   $SPF_MILTER -k
#
# Note: This milter looks for the sendmail.cf file in /etc/mail. If
# your sendmail.cf lives elsewhere (SuSE), establish a symlink:
#   ln -s /etc/sendmail.cf /etc/mail/sendmail.cf
#
# ==============

# ----------------------------------------------------------
# 			   config
# ----------------------------------------------------------

# where do we store pid, sock, and logs? No trailing / please!
# Set it at will, like '/var/spool/spf-milter', as long as it
# ends in "spf-milter". Sanity check, further down the road,
# will ensure that it does!
#
# If you change $basedir, be sure to make the same change to
# INPUT_MAIL_FILTER in your mc file!

my $basedir = '/var/spf-milter';

# where do we log SPF activity?

my $SPF_LOG_FILENAME = POSIX::strftime ($basedir . "/spflog-%Y%m.log", localtime);

# do we feel a need to flock the SPF logfile?

use constant FLOCK_SPFLOG => 0;

# ----------------------------------------------------------
# 	 no user-serviceable parts below this line
# ----------------------------------------------------------

use POSIX qw (:sys_wait_h);
use Sendmail::Milter;
use Socket;
use Mail::SPF::Query;
use threads;
use threads::shared;
use strict;
use Getopt::Std;
use Errno qw (ESRCH EINTR);

use vars qw/$opt_k $opt_l $opt_t $opt_m $opt_h $opt_T/;

my $pidFile = $basedir . '/spf-milter.pid';
my $sock = $basedir . '/spf-milter.sock';

my @extraParams : shared = ();

my $mx_mode : shared = 0;
my $our_hostname : shared = 0;
my $trust : shared = 1;
my $tagOnly : shared = 0;

my ($conn, $user, $pid, $login, $pass, $uid, $gid);

# feel free to replace this with your preferred logging scheme, eg Sys::Syslog or Log::Dispatch

sub write_log : locked {
    open  (SPFLOG, "+>>".$SPF_LOG_FILENAME) || (warn "$0: unable to write to $SPF_LOG_FILENAME: $!" && return);
    if (FLOCK_SPFLOG) {
        flock (SPFLOG, 2);
        seek  (SPFLOG, 0, 2);
    }
    print  SPFLOG localtime () . ": @_\n";
    close (SPFLOG);
}

sub log_error_and_exit : locked {
    write_log (@_);
    print STDERR "spf-milter: @_\n";
    exit 1;
}

# To accomodate the thread-unsafe Socket package, the one
# "socket_call" provides an additional pseudo-lock mechanism for use
# within the same thread. Since socket_call has the 'locked' attribute,
# within a single thread only one call can be made to it at the time. The
# first parameter to the call is either 1 or 2. The former returns the IP
# address of sockaddr_in; the latter does SPF::Query. Thus providing
# exclusivity within the same thread.
#
# Though I know you will try anyway, do NOT remove the 'locked' attribute;
# spf-milter WILL crash, sooner rather than later. The serialization
# effect of the extra locking mechanism is negligible; it will only occur
# when connect_callback and envfrom_callback (from two different threads)
# should wish to access socket_call at the same time. At any rate, I
# designed spf-milter to run super-stable. Adjust the code if your
# priority lies elsewhere.

sub socket_call : locked {
    # usage:
    #  socket_call (0) => undef
    #  socket_call (1, sockaddr_in)
    #  socket_call (2, "1.2.3.4", 'sender@example.com', 'helohostname.example.com')

    my $choice = shift;

    return undef if not $choice;

    if ($choice == 1) {

    # connect_callback parses (defined $sockaddr_in) as first parameter, thus
    # forming choice 1, or none at all. As with all calls to external
    # packages, we run them within an eval {} clause to prevent spf-milter
    # from dying on us.

        my ($port, $iaddr);
        eval {
           ($port, $iaddr) = sockaddr_in (shift);
            $choice = inet_ntoa ($iaddr);
        };
        return ($choice);
    } elsif ($choice == 2) {

        # Here we do SPF::Query. We parse $priv_data along from envfrom_callback,
        # as we want to store $smtp_comment for later use in eom_callback.
        #
        # We will not use the alternate 'best_guess' method here. Risking a 'fail'
        # from best_guess, prior to "Sunrise Date", is too rich for my blood.

        my $priv_data = shift;

        if (my $query = eval {new Mail::SPF::Query (ip => shift, sender => shift, helo => shift, @extraParams)}) {
            my ($call_status, $result, $smtp_comment, $header_comment, $spf_record);

            # In "mx" mode, we make a call to result2 (), instead of to result (),
            # to which we parse an extra parameter, $priv_data->{'to'}, so
            # result2 () can check against secondaries for the recipent.

            if ($mx_mode) {
                $call_status = eval {($result, $smtp_comment, $header_comment, $spf_record) = $query->result2 (shift)};
            } else {
                $call_status = eval {($result, $smtp_comment, $header_comment, $spf_record) = $query->result ()};
            }

            if ($call_status) {

                # Return $smtp_comment, if defined, else the prefab $header_comment.

                $smtp_comment ||= $header_comment;

                # Need to escape unprotected % characters in spf_smtp_comment,
                # or sendmail will use the default "Command rejected" message instead.
                # Noted by Paul Howarth

                $smtp_comment =~ s/%/%%/g;

                # Since $smtp_comment can be whatever is returned, we consider it highly
                # tainted, and first run it through a 'garbage' filter, so as to clear it
                # of weird characters, newlines, etc., that could potentially crash your
                # mailer (possible exploits?).

               ($priv_data->{'spf_smtp_comment'}   = $smtp_comment)   =~ tr/\000-\010\012-\037\200-\377/ /s;
               ($priv_data->{'spf_header_comment'} = $header_comment) =~ tr/\000-\010\012-\037\200-\377/ /s;
                return ($result);
            } else {
                return undef;
            }
        } else {
            return undef;
        }
    } else {
        return undef;
    }
}

# For some reason, the widespread misconception seems to have crept in
# that Sendmail::Milter private data must somehow be "frozen/thawed"
# before processing (a.l.a the namesake FreezeThaw package). This is not
# the case. FreezeThaw, and similar functions, which freeze referenced
# Perl structures into serialized versions, and thaw these serialized
# structures back into references, are ONLY required should you wish to
# transport entire hashes and such. But there is no need to do that. On a
# per-connection basis, at connect_callback, we declare a private hash,
# and set use "$ctx->setpriv" to set the reference to that hash:
#
# my $priv_data = {};
# $ctx->setpriv($priv_data);
#

sub connect_callback : locked {
    my $ctx = shift;
    my $priv_data = {};
    $priv_data->{'hostname'} = shift;
    my $sockaddr_in = shift;
    $priv_data->{'ipaddr'} = socket_call ((defined $sockaddr_in), $sockaddr_in);

    # Our hostname can be extracted from the j macro; idea by Alain Knaff
    # There is no need to reset it on each connection, though. It is now
    # a global variable, and has been taken out of the per-connection hash.

    $our_hostname ||= $ctx -> getsymval ('j');
    $ctx->setpriv($priv_data);
    return SMFIS_CONTINUE;
}

sub helo_callback : locked {
    my $ctx = shift;
    my $priv_data = $ctx->getpriv();
    $priv_data->{'helo'} = shift;
    $ctx->setpriv($priv_data);
    return SMFIS_CONTINUE;
}

sub envfrom_callback : locked {
    my $ctx = shift;
    my $priv_data = $ctx->getpriv();
   ($priv_data->{'from'} = lc (shift)) =~ s/[<>]//g;

    # In case of a valid MAIL FROM: <>, SPF::Query checks against the HELO string,
    # with 'postmaster' as localpart, but will leave an empty $priv_data->{'from'}
    # variable (which, for instance, shows up in $header_comment as a double space
    # after "domain of"). Here we compensate for that.

    $priv_data->{'from'} ||= "postmaster\@$priv_data->{'helo'}";

    # Are we authenticated?

    $priv_data->{'is_authenticated'} = $ctx -> getsymval ('{auth_authen}');

    # envfrom_callback can be called more than once within the same connection;
    # delete $priv_data->{'spf_result'} on entry!

    delete $priv_data->{'spf_result'};

    # SASL authenticated IP addresses always pass!

    if ($priv_data->{'is_authenticated'}) {
	$priv_data->{'spf_result'} = "pass";
	$priv_data->{'spf_header_comment'} = "$our_hostname: domain of $priv_data->{'from'} designates $priv_data->{'ipaddr'} as SASL permitted sender";
	$ctx -> setpriv ($priv_data);
	return SMFIS_CONTINUE;
    }

    $ctx->setpriv($priv_data);

    # Do the Milter equivalent of "PrivacyOptions=needmailhelo". Needed for SPF.

    if (not $priv_data->{'helo'}) {
        $ctx->setreply('503', '5.0.0', "Need HELO before MAIL");
        return SMFIS_REJECT;
    }

    # Did we start in "mx" mode? If so, we will delay SPF checks until
    # envrcpt_callback.

    return SMFIS_CONTINUE if ($mx_mode);

    # Make the SPF query, and immediately store the result in our private hash;
    # we may also need it later, at eom_callback.

    if ($priv_data->{'spf_result'} = socket_call (2, $priv_data, $priv_data->{'ipaddr'}, $priv_data->{'from'}, $priv_data->{'helo'})) {
        if ($priv_data->{'spf_result'} eq 'fail') {
	    if ($tagOnly) {
		write_log ("SPF \"fail\" from ip=".$priv_data->{'ipaddr'}.
			   " helo=".$priv_data->{'helo'}.
			   " from=".$priv_data->{'from'});
	    } else {
		$ctx->setreply('550', '5.7.1', "$priv_data->{'spf_smtp_comment'}");
		return SMFIS_REJECT;
	    }
        } elsif ($priv_data->{'spf_result'} eq 'error') {
            $ctx->setreply('451', '4.7.1', "An error occurred during SPF processing of $priv_data->{'from'}. Please try again later");
            return SMFIS_TEMPFAIL;
        }
    }

    $ctx -> setpriv ($priv_data);
    return SMFIS_CONTINUE;
}

sub envrcpt_callback : locked {
    my $ctx = shift;
    my $priv_data = $ctx->getpriv();

    # After envrcpt_callback we no longer need the recipient names,
    # so we can 'close' our data-set immediately.

    $ctx->setpriv($priv_data);

    # Here we do the opposite check of envfrom_callback: if not "mx" mode,
    # we bale rightaway.

    return SMFIS_CONTINUE if (not $mx_mode);

    # Same deal if we were already authenticated.

    return SMFIS_CONTINUE if ($priv_data->{'is_authenticated'});

   ($priv_data->{'to'} = lc (shift)) =~ s/[<>]//g;

    # We also need to purge $priv_data->{'spf_result'} for each recipient!

    delete $priv_data->{'spf_result'};

    $ctx->setpriv($priv_data);

    if ($priv_data->{'spf_result'} = socket_call (2, $priv_data, $priv_data->{'ipaddr'}, $priv_data->{'from'}, $priv_data->{'helo'}, $priv_data->{'to'})) {
        if ($priv_data->{'spf_result'} eq 'fail') {
	    if ($tagOnly) {
		write_log ("SPF \"fail\" from ip=".$priv_data->{'ipaddr'}.
			   " helo=".$priv_data->{'helo'}.
			   " from=".$priv_data->{'from'}.
			   " to=".$priv_data->{'to'});
	    } else {
		$ctx->setreply('550', '5.7.1', "$priv_data->{'spf_smtp_comment'}");
		return SMFIS_REJECT;
	    }
        } elsif ($priv_data->{'spf_result'} eq 'error') {
            $ctx->setreply('451', '4.7.1', "An error occurred during SPF processing of $priv_data->{'from'}. Please try again later");
            return SMFIS_TEMPFAIL;
        }
    }

    $ctx -> setpriv ($priv_data);
    return SMFIS_CONTINUE;
}

sub eom_callback : locked {
    my $ctx = shift;
    my $priv_data = $ctx->getpriv();

    # Did we get an SPF result? If so, add the appropriate header. There is no
    # longer a need to use the "chgheader" method to replace the first
    # occurance of a Received-SPF header; "addheader" will automatically
    # prepend the new Received-SPF header.

    if ($priv_data->{'spf_result'}) {
        $ctx->addheader('Received-SPF', $priv_data->{'spf_result'} . ' (' . $priv_data->{'spf_header_comment'} . ')');
    }

    $ctx->setpriv($priv_data);

    return SMFIS_CONTINUE;
}

# On RSET, forget everything except the HELO name. Noted by Paul Howarth
#
# (note by me: we also need to preserve the hostname of the sender,
# our own hostname, and the IP address of the sender! Best, therefore, to
# use a negative logic, and just delete the things that need to go)

sub abort_callback : locked {
    my $ctx = shift;
    my $priv_data = $ctx->getpriv();
    delete $priv_data->{'spf_result'};
    delete $priv_data->{'from'};
    delete $priv_data->{'to'};
    delete $priv_data->{'is_authenticated'};
    $ctx->setpriv($priv_data);
    return SMFIS_CONTINUE;
}

sub close_callback {
    my $ctx = shift;
    $ctx->setpriv(undef);
    return SMFIS_CONTINUE;
}

my %my_callbacks =
(
    'connect' => \&connect_callback,
    'helo'    => \&helo_callback,
    'envfrom' => \&envfrom_callback,
    'envrcpt' => \&envrcpt_callback,
    'eom'     => \&eom_callback,
    'close'   => \&close_callback,
    'abort'   => \&abort_callback,
);

############################################################
# Main code

# We start spf-milter as root for the same reason we do NOT run spf-milter
# as root: security. And we start it with at least one parameter, the user
# to run as. Spf-milter expects to create/read/write its log, pid, and socket,
# all in /var/spf-milter/, and will itself create the directory, if need be,
# and set all appropriate permissions/ownerships.
#
# Add "mx" as second parameter to run spf-milter in "mx" mode. In "mx" mode
# spf-milter makes its SPF checks at envrcpt_callback, instead of envfrom_callback,
# and calls result2 (), instead of result (), to allow for an early-out for
# secondaries. The default mode performs SPF checks at envfrom_callback.
#
# Per default, spf-milter queries trusted-fowarder.org (on 'fail' only), to
# check whether the trusted-fowarder domain yields a 'pass' after all. You can
# override the default behavior, adding "dt" (disable trust) as second parameter
# (or third, if you run in "mx" mode). You need at least Mail::SPF::Query 1.99
# for this functionality!

getopts("kl:tmhT");

sub usage {
    my ($ret) = @_;
    print STDERR "Usage: $0 [-k] [-l local_trust] [-t] [-m] [-h] <user> [mx] [dt]\n";
    print STDERR "	-k	kill running milter\n";
    print STDERR "	-l	add local trust record\n";
    print STDERR "	-t	don't add trusted-forwarder.org record\n";
    print STDERR "	-m	trust recipient's MX hosts\n";
    print STDERR "	-T	don't reject failed messages, tag only\n";
    print STDERR "	-h	print this help message\n";
    print STDERR "	<user>	user to run this script as\n";
    print STDERR "	mx	trust recipient's MX hosts (same as -m)\n";
    print STDERR "	dt	don't add trusted-forwarder.org (same as -t)\n";
    exit ($ret);
}

if ($opt_h) {
    usage (0);
}

# Basic, but vital, sanity-check against $basedir. Since we set
# permissions/ownerships on everything (!) in our $basedir, we
# must avoid disasters, such as setting $basedir to /var/run/.
# Therefore, we require that $basedir ends in "spf-milter".

if (not ($basedir =~ /spf-milter$/i)) {
    die '$basedir' . " ('$basedir') must end in /spf-milter!\n";
}

my $oldPid;
if (-f $pidFile) {
    open (PIDFILE, $pidFile) || die "Could not read pid file: $!\n";
    my $pid = <PIDFILE>;
    if ($pid > 0) {
	$oldPid=$pid;
    }

}

if (defined $opt_k) {
    die "SPF milter not running\n" if (!defined $oldPid);

    # We need to kill the milter using signal 3, it apparently doesn't react
    # to more "usual" signals...

    if (!kill (3, $oldPid)) {
	if ($!{ESRCH}) {
	    print STDERR "Sendmail milter not running, cleaning files\n";

	    # Files will be cleaned by END block

	    exit (0);
	} else {

	    # Prevent cleaning away of the running milter's files

	    die "Could not kill SPF milter: $!\n";
	}
    }

    my $needNl=0;
    select (STDERR);
    $|=1;

    # Waiting for milter to die

    for (my $i=0; $i<79; $i++) {
	select (undef, undef, undef, 0.25);
	if (!kill (0, $oldPid) && $!{ESRCH}) {
	    print STDERR "\n" if ($needNl);
	    exit (0); # Milter dead
	}
	print STDERR ".";
	$needNl=1;
    }
    print STDERR "\nForcefully killing milter\n";
    kill (9, $oldPid);
    exit (0);
}

if ($oldPid) {
    my $r = kill (0, $oldPid);
    if (!$!{ESRCH}) {
	$pid=1; # Prevent cleaning away of the running milter's files
	die "SPF milter already running\n";
    }
}

unlink $sock;
unlink $pidFile;

if (not $user = lc ($ARGV[0])) {
    print STDERR "Missing user\n";
    usage (1);
} elsif ($>) {
    print STDERR "You need to start spf-milter as root!\n";
    exit 1;
}

$mx_mode = 1 if ($opt_m || (lc ($ARGV[1]) eq 'mx'));

$trust = 0 if ($opt_t || (lc ($ARGV[1]) eq 'dt') || (lc ($ARGV[2]) eq 'dt'));
push (@extraParams, trusted => $trust);

if ($opt_l) {
    push (@extraParams, local => $opt_l);
}

if ($opt_T) {
    $tagOnly = 1;
}

# Since we will daemonize, play nice.

chdir ('/') or exit 1;

umask (0077);

if (not (-e $basedir)) {
    if (not mkdir $basedir) {
        print STDERR "Odd; cannot create $basedir/\n";
        exit 1;
    }
}


# The Sendmail::Milter 0.18 engine has a small bug, causing it to extract
# the wrong socket-name when, next to the F flags, there's an additional flag
# in the Milter definition, (see: http://rt.cpan.org/NoAuth/Bug.html?id=3892
# for details). Since the extra flag is useful (T for timeouts), we preset our
# connection string to "local:/var/spf-milter/spf-milter.sock", with "spf-milter"
# as Milter name. A corresponding line in sendmail.cf could look like this:
#
# Xspf-milter, S=local:/var/spf-milter/spf-milter.sock, F=T, T=C:4m;S:4m;R:8m;E:16m

if (not $conn = Sendmail::Milter::auto_getconn ('spf-milter', '/etc/mail/sendmail.cf')) {
    log_error_and_exit ("Milter for 'spf-milter' not found!");
}

if ($conn =~ /^local:(.+)/) {
    if (not Sendmail::Milter::setconn ("local:$sock")) {
        log_error_and_exit ("Failed to set connection information!");
    }

    # Now we set a fairly large timeout. The idea here is to set it so large, that
    # the Milter will not try and compete with the sendmail T= timings, which allow
    # for a more fine-grained tuning.

    if (not Sendmail::Milter::settimeout ('8192')) {
        log_error_and_exit ("Failed to set timeout value!");
    }
    if (not Sendmail::Milter::register ('spf-milter', \%my_callbacks, SMFI_CURR_ACTS)) {
        log_error_and_exit ("Failed to register callbacks!");
    }

    # Get info on the user we want to run as. If $uid is undefined, the user
    # does not exist on the system; if zero, it is the UID of root!

   ($login, $pass, $uid, $gid) = getpwnam ($user);
    if (not defined ($uid)) {
        log_error_and_exit ("$user is not a valid user on this system!");
    } elsif (not $uid) {
        log_error_and_exit ("You cannot run spf-milter as root!");
    }
    write_log ("Starting Sendmail::Milter $Sendmail::Milter::VERSION engine");

    # Set all proper permissions/ownerships, according to the user we run as.

    if ((not chown $uid, $gid, $basedir, glob ($basedir . '/*')) ||
        (not chmod 0700, $basedir)) {
        log_error_and_exit ("Cannot set proper permissions!");
    }

    # Drop the Sendmail::Milter privileges!

    $) = $gid;
    $( = $gid;
    $> = $uid;
    $< = $uid;

    # Unlink our previous .sock file, should it exist.

    if (-e $sock) {
        if (not unlink ($sock)) {
            log_error_and_exit ("Cannot unlink $sock!");
        }
    }

    # Give us a pretty proc-title to look at in 'ps ax'. :)

    $0 = 'spf-milter' . (($mx_mode) ? (" [mx mode]") : (""));

    # Fork and give us a pid file.
    if ($pid = fork ()) {
	open (USERLOG, ">". $pidFile) or exit 1;
	flock (USERLOG, 2);
	seek (USERLOG, 0, 0);
	print USERLOG " $pid";
	close (USERLOG);

	# Wait until either milter socket appears or child dies
	my $kid=0;
	while (!-x $sock) {
	    select (undef,undef,undef,0.01);
	    $kid = waitpid(-1, WNOHANG);
	    if ($kid > 0) {
		$pid=0; # trigger cleanup
		die "Could not start milter\n";
	    }
	}
	exit 0;
    }

    # Redirect all input/output from/to null

    open (STDIN, '/dev/null');
    open (STDOUT, '>/dev/null');

    # Complete de daemonization process.

    POSIX::setsid () or exit 1;

    open (STDERR, '>&STDOUT');

    if (Sendmail::Milter::main ()) {
        write_log ("Successful exit from the Sendmail::Milter engine");
    } else {
        write_log ("Unsuccessful exit from the Sendmail::Milter engine");
    }
} else {
    log_error_and_exit ("$conn is not a valid connection object!");
}

END {

    # On exit (child only!) we clean up the mess.

    if (not $pid) {
        unlink ($pidFile);
        unlink ($sock);
    }
}

exit 0;