# Sendmail Milter to perform SPF lookups
#
# Code by Mark Kramer <admin@asarian-host.net> on December 3, 2003
#
# Version 1.2
#
# Last revision: January 16, 2004
#
# 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.
#

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

# where do we log SPF activity?

my $SPF_LOG_FILENAME = POSIX::strftime("/var/spf-milter/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;
use Sendmail::Milter;
use Socket;
use Mail::SPF::Query;
use threads;
use threads::shared;
use strict;
my $mx_mode : 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)}) {
            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) = $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

    $priv_data->{'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;
    $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!
    #
    # Be sure to add the following lines to your sendmail.cf, or SMTP AUTH
    # parameters (amongst others) are not parsed!
    #
    # O Milter.LogLevel=9
    # O Milter.macros.connect=j, _, {daemon_name}, {if_name}, {if_addr}
    # O Milter.macros.helo={tls_version}, {cipher}, {cipher_bits}, {cert_subject}, {cert_issuer}
    # O Milter.macros.envfrom=i, {auth_type}, {auth_authen}, {mail_mailer}, {mail_host}, {mail_addr}
    # O Milter.macros.envrcpt={rcpt_mailer}, {rcpt_host}, {rcpt_addr}

    if ($priv_data->{'is_authenticated'}) {
	$priv_data->{'spf_result'} = "pass";
	$priv_data->{'spf_header_comment'} = "$priv_data->{'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') {
            $ctx->setreply('550', '5.7.1', "[$priv_data->{'spf_smtp_comment'}]; see: http://spf.pobox.com/why.html?sender=$priv_data->{'from'}&ip=$priv_data->{'ipaddr'}");
            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') {
            $ctx->setreply('550', '5.7.1', "[$priv_data->{'spf_smtp_comment'}]; see: http://spf.pobox.com/why.html?sender=$priv_data->{'from'}&ip=$priv_data->{'ipaddr'}");
            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;
}

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'   => \&close_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.

if (not $user = lc ($ARGV[0])) {
    print "Usage: perl $0 <user_to_run_as> [mx]\n";
    exit 1;
} elsif ($>) {
    print "You need to start spf-milter as root!\n";
    exit 1;
}

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

# Since we will daemonize, play nice.

chdir ('/') or exit 1;

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

umask (0077);

if (not (-e '/var/spf-milter')) {
    if (not mkdir '/var/spf-milter') {
        print STDERR "Odd; cannot create /var/spf-milter/\n";
        exit 1;
    }
}

# Fork and give us a pid file.

if ($pid = fork ()) {
    open (USERLOG, ">".'/var/spf-milter/spf-milter.pid') or exit 1;
    flock (USERLOG, 2);
    seek (USERLOG, 0, 0);
    print USERLOG " $pid";
    close (USERLOG);
    exit 0;
}

# Complete de daemonization process.

POSIX::setsid () or exit 1;

open (STDERR, '>&STDOUT');

# 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:/var/spf-milter/spf-milter.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, '/var/spf-milter', glob ('/var/spf-milter/*')) ||
        (not chmod 0700, '/var/spf-milter')) {
        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 '/var/spf-milter/spf-milter.sock') {
        if (not unlink ('/var/spf-milter/spf-milter.sock')) {
            log_error_and_exit ("Cannot unlink /var/spf-milter/spf-milter.sock!");
        }
    }

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

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

    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 ('/var/spf-milter/spf-milter.pid');
        unlink ('/var/spf-milter/spf-milter.sock');
    }
}

exit 0;
