#!/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.41
#
# Last revision: April 27, 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/
#      http://www.anarres.org/projects/srs/srs.pdf
#
# 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.7.
#

# 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
# ----------------------------------------------------------

my $VERSION = "1.41";

# 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';

# Our main SRS object; adjust this to your server's needs!

my $srs = new Mail::SRS (Secret => 'whateverfloatsyourboat', MaxAge => 4, HashLength => 8, HashMin => 8, AlwaysRewrite => 1, Separator => '+');

# 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?

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

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

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

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

my @extraParams : shared = ();

my $mx_mode : shared = 0;
my $our_hostname : shared = 0;
my $trust : shared = 1;
my $require_srs_dsn : shared = 0;
my $will_relay_srs1 : shared = 0;
my $tagOnly : shared = 0;
my $use_whitelist : shared = 0;
my @cidr_list : shared;
my %whitelisted_entries;

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);
    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;

                # 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;

                # Need to escape unprotected % characters in spf_smtp_comment,
                # or sendmail will use the default "Command rejected" message instead.
                # Noted by Paul Howarth
                #
                # In fact, sendmail does not like the % sign at all, and will
                # basically bulk on every escaped character! For instance, sending:
                #
                #     http://example.com/my%20example.html
                #
                # Will cause the "Command rejected" error; as will the
                # %40 substitution for the @ sign. The pre-1.41 solution was
                # to simply prepend an extra % char to each existing one. But
                # that rendered the "sender" in a default $smtp_comment invalid
                # (postmaster%@example.com).
                #
                # The 1.41 solution is to simply unescape the lot, so as to avoid
                # sendmail transmission errors. The resulting % chars are then
                # converted to spaces.
                #
                # None of this is particularly pretty, I am aware of that. But a
                # choice, nonetheless, needs to be made: either sendmail trips
                # over the % characters, causing an unrecoverable transmisssion
                # error, or we run the low risk that a click on a browser link may
                # not yield the desired result. I have chosen to avoid the former.

                $priv_data->{'spf_smtp_comment'}   =~ s/%([0-9A-Fa-f]{2})/chr (hex ($1))/eg;
                $priv_data->{'spf_header_comment'} =~ s/%([0-9A-Fa-f]{2})/chr (hex ($1))/eg;

                $priv_data->{'spf_smtp_comment'}   =~ s/%+/ /g;
                $priv_data->{'spf_header_comment'} =~ s/%+/ /g;

                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;

    # We first allow a bypass for STARTTLS authenticated users.
    # In all other cases, where $use_whitelist indicates the use of a
    # whitelist, we set 'is_authenticated' to the "eval" of the
    # CIDR lookup in our IP whitelist. Else, we reset to 0;
    #
    # @cidr_list is a global array, read from "$basedir/whitelist".

    if ($ctx -> getsymval ('{verify}') eq 'OK') {
        $priv_data->{'is_authenticated'} = 1;
    } elsif (not $use_whitelist) {
        $priv_data->{'is_authenticated'} = 0;
    } else {
        $priv_data->{'is_authenticated'} = eval {Net::CIDR::cidrlookup ($priv_data->{'ipaddr'}, @cidr_list)};
    }

    $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;

    # Is this a DSN?

    $priv_data->{'bounce'} = ($priv_data->{'from'} eq '');

    # 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 via SASL? Do not set if we're
    # already STARTTLS authenticated (or whitelisted!).

    $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/STARTTLS authenticated IP addresses always pass!

    if ($priv_data->{'is_authenticated'}) {
        $priv_data->{'spf_result'} = "pass";
        $priv_data->{'spf_header_comment'} = "$our_hostname: $priv_data->{'ipaddr'} is authenticated by a trusted mechanism";
        $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', "Polite people say HELO first");
        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', "$priv_data->{'spf_smtp_comment'}");
            return SMFIS_TEMPFAIL;
        }
    }

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

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

    # Keep the old recipient too, exactly as it appeared
    # in the SMTP dialoge!

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

    # Are we relaying or receiving? The bulk of our labor is at local delivery.

    if ($ctx -> getsymval ('{rcpt_mailer}') eq 'local') {

        # If we require that all DSN messages are SRS signed (-S option),
        # then here we check whether we have a valid SRS address
        # in case of a DSN.
        #
        # Before you use this option, make sure you are well
        # familiar with its possible consequences! Basically, you
        # will be denying access to ALL non-SRS signed recipients,
        # in case of a DSN. Only use this when you have implemented
        # a SRS signing scheme in your MTA, which will sign ALL outgoing
        # envelope-from addresses. Unfortunately, spf-milter cannot do
        # that for you, as the Milter specs do not allow for a method
        # to change the envelope-from address.
        #
        # Also, be sure to visit:
        #
        #    http://www.anarres.org/projects/srs/
        #    http://spf.pobox.com/srs.html
        #    http://asarian-host.net/srs/sendmailsrs.htm
        #
        # The -S option is for people with a specific, deliberate
        # purpose in mind. Do not haphazardly enable this just
        # because the idea of 'signed' addresses makes you feel safer;
        # if you did not specifically set up your MTA for this purpose,
        # then this option is not for you.

        if ($require_srs_dsn) {
            if ($priv_data->{'bounce'}) {

                # First scenario; we receive a SRS0 address; a one-pass
                # reversal should 'eval' to tell us whether it is really
                # ours, and valid.

                if ($priv_data->{'to'} =~ /^SRS0[+-=]/i) {
                    if (not (eval {$reversed_recipient = $srs -> reverse ($priv_data->{'to'})})) {
                        $ctx -> setreply ('550', '5.7.5', "Invalid SRS signature!");
                        $ctx -> setpriv ($priv_data);
                        return SMFIS_REJECT;
                    } else {

                        # We will store reversed recipients in pairs:
                        # the orginal recipient (exactly as it appeared in
                        # the SMTP dialogue) + its reversed counterpart.
                        #
                        # At eom_callback, as per the Milter protocol,
                        # we will avail ourselves of the first best
                        # opportunity to use a corresponding delrcpt/addrcpt
                        # combo to change the recipients in the envelope.

                        $priv_data->{'reversed_recipients'} .= "$envelope_to $reversed_recipient ";
                    }

                # Second scenario; we will use a two-pass reversal on the SRS1 address.
                # If it is still ours thereafter, we will accept it.

                } elsif ($priv_data->{'to'} =~ /^SRS1[+-=]/i) {
                    if (not (eval {$_ = $srs -> reverse ($priv_data->{'to'})})) {
                        $ctx -> setreply ('550', '5.7.5', "Invalid SRS signature!");
                        $ctx -> setpriv ($priv_data);
                        return SMFIS_REJECT;
                    } elsif (not (eval {$reversed_recipient = $srs -> reverse ($_)})) {
                        if (not $will_relay_srs1) {
                            $ctx -> setreply ('551', '5.7.1', "User not local; please try <$_> directly");
                            $ctx -> setpriv ($priv_data);
                            return SMFIS_REJECT;
                        } else {

                            # Since the outer SRS1 address was targeted locally, it did
                            # not trigger sendmail's relay rules. If the reversal of the
                            # SRS1 address appears to be non-local after all, sendmail,
                            # still working under the assumption that this was a local
                            # delivery, will relay without question!
                            #
                            # Please, do not worry about being an open relay, though: SRS1
                            # addresses now have an extra hash to prevent forgery.

                            $reversed_recipient = $_;
                        }
                    }
                    $priv_data->{'reversed_recipients'} .= "$envelope_to $reversed_recipient ";

                # Okay, no SRS address found; and we really should have. If the
                # recipient is not postmaster@ or abuse@ (or abuse-report@, etc),
                # we complain; otherwise, we turn a blind eye.
                #
                # N.B. Future versions of spf-milter may remove this 'bypass'.
                # For now, while SPF is still in the early stages of its
                # adoption phase, we will allow for this exception.

                } elsif (not ($priv_data->{'to'} =~ /^(postmaster|abuse)\b/i)) {
                    $ctx -> setreply ('550', '5.7.5', "Bounce address not SRS signed!");
                    $ctx -> setpriv ($priv_data);
                    return SMFIS_REJECT;
                }

                # We only expect to see SRS in DSN. Mind you, this is a two-way
                # street! We do not accept incoming SRS addresses outside the
                # context of DSN; and, likewise, you cannot send out to (local)
                # SRS recipients, other than using an empty envelope-from!

            } elsif ($priv_data->{'to'} =~ /^SRS[01][+-=]/i) {
                $ctx -> setreply ('550', '5.7.6', "SRS only supported in DSN!");
                $ctx -> setpriv ($priv_data);
                return SMFIS_REJECT;
            }
        }

    # We are relaying. Only a single, outer check here: are
    # we sending to an SRS1 address? If so, a one-pass reversal
    # must 'eval'. The inner reverse may, or may not, 'eval'
    # (in fact, it will probably not, as the result will likely
    # be a third-party SRS0 address).
    #
    # N.B. Please notice the absence of a separate outer SRS0
    # check. We only arrive here in 'relay' mode (which means:
    # any SRS0 target will always have a non-local domain name
    # part, which we will not be able to 'eval' anyway).

    } elsif ($priv_data->{'to'} =~ /^SRS[01][+-=]/i) {
        if (not $priv_data->{'bounce'}) {
            $ctx -> setreply ('550', '5.7.6', "SRS only supported in DSN!");
            $ctx -> setpriv ($priv_data);
            return SMFIS_REJECT;
        } elsif ($priv_data->{'to'} =~ /^SRS1[+-=]/i) {
            if (not (eval {$_ = $srs -> reverse ($priv_data->{'to'})})) {
                $ctx -> setreply ('550', '5.7.5', "Invalid SRS signature!");
                $ctx -> setpriv ($priv_data);
                return SMFIS_REJECT;
            } elsif (not (eval {$reversed_recipient = $srs -> reverse ($_)})) {
                if (not $will_relay_srs1) {
                    $ctx -> setreply ('551', '5.7.1', "User not local; please try <$_> directly");
                    $ctx -> setpriv ($priv_data);
                    return SMFIS_REJECT;
                } else {

                    # Yes, this could be a non-local recipient. Please,
                    # do not worry about being an open relay here;
                    # since the outer SRS1 address was non-local to begin
                    # with, only authorized IP-space can make this relay
                    # happen anyway.

                    $reversed_recipient = $_;
                }
            }
            $priv_data->{'reversed_recipients'} .= "$envelope_to $reversed_recipient ";
        }
    }

    $ctx -> setpriv ($priv_data);

    # We're done if we're already authenticated.

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

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

    return SMFIS_CONTINUE if (not $mx_mode);

    # 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', "[RCPT TO: <$priv_data->{'to'}>] $priv_data->{'spf_smtp_comment'}");
                return SMFIS_REJECT;
            }
        } elsif ($priv_data->{'spf_result'} eq 'error') {
            $ctx -> setreply ('451', '4.7.1', "[RCPT TO: <$priv_data->{'to'}>] $priv_data->{'spf_smtp_comment'}");
            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'} . ')');
    }

    # Only at eom_callback can we substitute SRS recipients.

    if ($priv_data->{'bounce'}) {
        my ($old_recipient, $new_recipient);

        # The convenient twin structure of a hash makes it possible
        # to just slurp in the entire split string, and have it neatly
        # be distributed over "$old_recipient, $new_recipient" pairs.
        # Cute, eh?

        my %srs = split (/ /, $priv_data->{'reversed_recipients'});
        while (($old_recipient, $new_recipient) = each %srs) {
            $ctx -> delrcpt ($old_recipient);
            $ctx -> addrcpt ($new_recipient);
        }
    }

    $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)
#
# BTW, we keep 'is_authenticated' in 1.40; during an entire session
# the connection should remain authenticated (unless a new HELO sounds
# the possible start of a new STARTTLS session).

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->{'bounce'};
    delete $priv_data->{'reversed_recipients'};
    $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:tmSrhvT");

sub usage {
    my ($ret) = @_;
    print STDERR "Usage: $0 [-k] [-l local_trust] [-t] [-m] [-S] [-r] [-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 "        -S        only allow SRS signed bounces (see documentation!)\n";
    print STDERR "        -r        will relay SRS1\n";
    print STDERR "        -T        don't reject failed messages, tag only\n";
    print STDERR "        -h        print this help message\n";
    print STDERR "        -v        display version info\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);
}

if ($opt_v) {
    print "Version: spf-milter $VERSION\n";
    exit 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";
    chomp ($oldPid = <PIDFILE>);
    close (PIDFILE);
}

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

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

    if (not 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

            $pid = 1;

            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 (not 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 (not $!{ESRCH}) {

        # Prevent cleaning away of the running milter's files

        $pid = 1;

        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;
}

$require_srs_dsn = 1 if ($opt_S);
$will_relay_srs1 = 1 if ($opt_r);

# Since we will daemonize, play nice.

chdir ('/') or exit 1;

umask (0077);

# Does $basedir exist? If not, create it; else, try and suck in
# the CIDR whitelist, and check each entry for validity.

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

    # The whitelist is OPTIONAL. It does not need to exist.
    # But if it does, each and every line needs to contain
    # a valid entry (IP address, or network address in
    # proper CIDR notation). Commentary/empty lines are allowed.
    # Valid entries, for example, are:
    #
    # 127.0.0.1    # my local machine.
    # 192.168.64.0/24
    # 10.0.0.0/8
    # 192.68.1.0-192.68.1.255
    # 192.68.0.0/16

    if (open (CIDRLIST, $whitelist_file)) {
        flock (CIDRLIST, 2);
        seek (CIDRLIST, 0, 0);
        while (<CIDRLIST>) {
            tr/\000-\010\012-\037\200-\377//d;

            # Clear out any and all comments.

            s/\043.*//;

            # No white-space, please (also takes care of possible trailing
            # white-space, as the result of removing comments!).

            s/\s+//g;

            # Skip empty lines.

            next if (/^$/);

            # We use a temporary hash, so as to avoid duplicate entries.

            $whitelisted_entries{lc ($_)}++;
        }
        close (CIDRLIST);

        foreach (keys %whitelisted_entries) {
            if (not eval {@cidr_list = Net::CIDR::cidradd ($_, @cidr_list)}) {
                print STDERR "WARNING processing '$whitelist_file': \"$_\" not a valid IP address/not in proper CIDR notation! Skipped.\n";
                next;
            }
        }

        undef %whitelisted_entries;

        # We are certain here: we have read a completely valid whitelist.
        # Now, set a flag for "helo_callback", so it knows of our choice
        # to use a whitelist. Only actually set if we have any valid
        # entries at all.

        $use_whitelist = (@cidr_list);
    } else {
        print STDERR "Unable to open $whitelist_file\n";
    }
}

# 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;

    # 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 (PIDFILE, ">". $pidFile) or exit 1;
        flock (PIDFILE, 2);
        seek (PIDFILE, 0, 0);
        print PIDFILE " $pid";
        close (PIDFILE);

        # Wait until either milter socket appears or child dies

        my $kid = 0;
        while (not -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;


=head1 NAME

spf-milter - Sendmail Milter to perform SPF lookups

=head1 SYNOPSIS

  ./spf/spf-milter-1.41.pl milter
  ./spf-milter-1.41.pl -S -r milter

=head1 ABSTRACT

The SPF protocol relies on sender domains to describe their designated
outbound mailers in DNS. spf-milter is built around Mail::SPF::Query to
determine the legitimacy of an SMTP client IP.

Tested under Perl, v5.8.0 built for i386-freebsd-thread-multi, using the
Sendmail::Milter 0.18 engine.

=head1 DESCRIPTION

Sendmail does not need to "find" the spf-milter script. You can run it
from pretty much every location. The only thing sendmail needs to do, is
to be able to find the local domain socket to connect to (spf-milter
creates "/var/spf-milter/spf-milter.sock" per default).

=head1 PREREQUISITES

spf-milter requires the following modules:

C<POSIX>, C<Sendmail::Milter>, C<Socket>, C<Net::CIDR>, C<Mail::SPF::Query>, C<Mail::SRS>, C<threads>, C<threads::shared>, C<Getopt::Std>, C<Errno>, C<strict>

And at least the following Perl version:

C<Perl 5.8.0>

=head1 SCRIPT CATEGORIES

UNIX/System_administration
Mail

=head1 COPYRIGHT

Copyright (c) 2003-2004 Mark Kramer <admin@asarian-host.net>.

spf-milter is licensed under GPL.

=head1 README

1. INTRODUCTION

spf-milter is a Milter, which works with Sendmail 8.12 and up, and provides
an SPF-compliant extension to the SMTP communication between your MTA and
connecting clients. See http://spf.pobox.com/ for details about SPF itself.

spf-milter is written entirely in Perl, and uses the native threaded Milter
model. spf-milter is licensed under GPL.


2. PREREQUISITES

spf-milter requires:

1): Perl 5.8.x, or higher.

2): Perl modules:

    POSIX
    Sendmail::Milter;
    Socket;
    Net::CIDR;
    Mail::SPF::Query;
    Mail::SRS;
    Getopt
    Errno


3. INSTALLATION

Since spf-milter is written in Perl, you need, for starters,
Sendmail::Milter (at CPAN). The Milter API is threaded, so you need a
thread-enabled Perl (compiled with -Duseithreads) as well. If you do not
know whether you Perl supports threads, try and install Sendmail::Milter
first. It will itself test the ithread functionality of your Perl for
compatibility with Sendmail::Milter.

I built and tested spf-milter under Perl, v5.8.0 built for
i386-freebsd-thread-multi. Earlier versions of Perl versions may or may
not be suitable.


A) Sendmail

You must be using Sendmail 8.12.x

Obtain the latest Sendmail 8.12.x source release from
http://www.sendmail.org. Unpack it. Add the following lines to
devtools/Site/site.config.m4:

  APPENDDEF(`conf_libmilter_ENVDEF', `-DMILTER')
  APPENDDEF(`conf_sendmail_ENVDEF', `-DMILTER')

This enables the Milter functionality. Now build Sendmail as usual
("sh Build" in the sendmail/ directory).

Add the following lines to your Sendmail "m4" configuration file
(*.mc, in the cf/cf/ directory):

  define(`confMILTER_LOG_LEVEL',`9')dnl
  define(`confMILTER_MACROS_HELO', confMILTER_MACROS_HELO`, {verify}')dnl
  INPUT_MAIL_FILTER(`spf-milter', `S=local:/var/spf-milter/spf-milter.sock, F=T, T=C:4m;S:4m;R:8m;E:10m')

Adjust the MILTER_LOG_LEVEL and T timings to your liking. Now build
sendmail.cf as usual ("./Build sendmail.cf" in the cf/cf/ directory). Your
newly generated sendmail.cf will now contain a section that looks like this:

# Milter options
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}, {verify}
O Milter.macros.envfrom=i, {auth_type}, {auth_authen}, {auth_ssf}, {auth_author}, {mail_mailer}, {mail_host}, {mail_addr}
O Milter.macros.envrcpt={rcpt_mailer}, {rcpt_host}, {rcpt_addr}

And this:

######################################################################
######################################################################
#####
#####                   MAILER DEFINITIONS
#####
######################################################################
######################################################################

Xspf-milter, S=local:/var/spf-milter/spf-milter.sock, F=T, T=C:4m;S:4m;R:8m;E:10m

Inspect your new sendmail.cf, to see whether it does indeed contain these things.


B) Startup

You are already ready to start spf-milter! :)

Sendmail does not need to "find" the spf-milter script. You can run it from
pretty much every location. The only thing sendmail needs to do, is to be
able to find the local domain socket to connect to (spf-milter creates
"/var/spf-milter/spf-milter.sock" per default). If you successfully followed
the above steps, then your new sendmail.cf will contain the proper local
socket name.

Backup your old sendmail.cf. Now, stop sendmail, and copy the new
sendmail.cf to its proper location.

Now, start spf-milter first! Depending on where your thread-enabled Perl
resides, of course, you can, in its simplest form, start spf-milter like
this:

./spf-milter-1.41.pl milter

We start spf-milter 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.

You cannot run spf-milter as root.

If everything went okay, try 'ps ax', and your spf-milter will show up as:

"spf-milter (perl)"

Restart sendmail. Now you're done. :)


C) Testing spf-milter functionality

Perform two basic tests:

1) Make sure legitimate mail gets through!

2) Confirm that forged mail is rejected; forging mail from
   mengwong@vw.mailzone.com will do the trick (address used
   with permission).

If properly rejected, you will get a 550 response, and a text with a
reference to "http://spf.pobox.com/why.html? ..." in the line.

N.B. The actual return-text may vary from MTA to MTA, but the 550 response
code SHOULD always be the same (an extended SMTP code, '550', '5.7.1').


4. SRS AND FAKE DSN DETECTION


A) Outline

As of version 1.40, spf-milter comes with a new functionality: fake DSN
detection. It is activated by the -S option; and, when enabled, will spot
and REJECT unsigned DSN recipients. Signatures are based on SRS (Mail::SRS).
This is an advanced option; it requires an MTA counterpart installation to
sign outgoing envelope-from addresses, and should not be used unless you are
well familiar with the entire scheme and its possible ramifications.

The idea, in a nutshell, is as follows. Have an MTA sign all outgoing
envelope-from addresses. Then, when we receive a DSN (bounce message with a
MAIL FROM: <>), we will REJECT this DSN, unless the recipient was SRS
signed. Based on the old "what goes around, comes around" adage (or rather,
"what does not go around, should not come around"): if we do not ever send
out unsigned envelope-from addresses, then we know we are dealing with a
forgery when we receive an unsigned DSN recipient!

Only use this when you have implemented an SRS signing scheme in your MTA,
which will sign ALL outgoing envelope-from addresses. Unfortunately,
spf-milter cannot do that for you, as the Milter specs do not allow for a
method to change the envelope-from address. You may want to have a peek at
my SRS + sendmail integration project, at:

    http://asarian-host.net/srs/sendmailsrs.htm


B) How to use FAKE DSN DETECTION without SRS reversal in sendmail

If your incoming mail server differs from your outgoing one, then there is
way to use FAKE DSN DETECTION without setting up SRS reversal in the
sendmail configuration for you incoming mail server.

Since spf-milter handles your locally targeted SRS recipients, you would
think that suffices. And it does. However, the Milter specification does not
permit the changing of recipients at envrcpt_callback, and forces you to
wait until eom_callback; thereby leaving an intermediate window, between
callbacks, where sendmail itself will verify the recipients (upon return of
envrcpt_callback), and conclude that your nice SRS0 bounce address does not
exist on the system. The result? Sendmail will REJECT the recipient with a
"User unknown" after all.

The way to solve this, is to make use of sendmail's "plussed" user facility.
Define two users (virtusertable), like so:

    SRS0+*@yourdomain.com    user
    SRS1+*@yourdomain.com    user

(where "user" is the name of an existing user).

This will provide the necessary "fallback" for the undefined in-between
callback state. Mind you, these are 'dummy' addresses; they are never
actually used for delivery; they are just there to prevent sendmail from
bulking over your SRS addresses, in-between callbacks.

Now that sendmail has these fallback wildcard addresses, spf-milter can
proceed until eom_callback, where it will replace the SRS signed envelope
recipient(s) with their reversed counterparts.

For this to work, your SRS 'separator' character must be "+". Like so:

    my $srs = new Mail::SRS (Secret => 'yaddayadda', Separator => '+');

So that SRS0+, SRS1+ addresses are formed.


C) Start-up considerations

To use SRS on spf-milter, start it with the -S parameter; a minimum command
line usage would be:

    ./spf-milter-1.41.pl -S milter

This will place spf-milter in FAKE DSN DETECTION mode, running as user
"milter".

There has been some discussion on whether people should become SRS1
forwarding hosts. To accomodate both parties, spf-milter can be started with
an additional option, "-r". If set, spf-milter will relay non-locally
resolving SRS0 addresses (reversed from SRS1 addresses). Per default,
spf-milter only accepts locally resolving SRS0 addresses. If you want full
SRS1 functionality, start spf-milter like so (minimal):

    ./spf-milter-1.41.pl -S -r milter

Whether you start spf-milter with -S or not, when relaying, spf-milter is
always SRS aware (that is, when your own mailer is sending TO foreign SRS0,
SRS1 addresses). The "-r" option, outside -S, only has meaning when
relaying.


5. WHITELISTING

As of version 1.41, spf-milter now supports the use of a whitelist,
consisting of individual IP addresses, and/or IP netblocks expressed in CIDR
notation.

The whitelist is OPTIONAL. It does not need to exist. But if it does, each
and every line needs to contain a valid entry (IP address, or network
address in proper CIDR notation). Commentary/empty lines are allowed. Valid
entries, for example, are:

  127.0.0.1        # my local machine.
  192.168.64.0/24
  10.0.0.0/8
  192.68.1.0-192.68.1.255
  192.68.0.0/16

Connections from IP addresses in the whitelist are exempted from SPF-checks,
and are treated as authenticated.

To use the whitelist, place a text file called "whitelist" in the spf-milter
basedir. Per default, therefore, spf-milter expects the whitelist to be
'/var/spf-milter/whitelist'. The full name, however, is affected by the
global variable $basedir; and the full path to the whitelist is formed as
follows:

my $whitelist_file = $basedir . '/whitelist';

Changes to the whitelist require a restart.


6. COMMON QUESTIONS ANSWERED

1) Why does spf-milter use the native threaded Milter model?

Because Sendmail::Milter does.

2) How does spf-milter stay stable using ithreads?

Instead of using a multiplexor to split threads over individual child
processes (like MIMEDefang), spf-milter 'locks' (thread-locks) its
callbacks, thus effectively serializing the threads; so you get much of
the effect of what the MIMEDefang multiplexor does (kinda). And since the
'locked' attribute really prevents the threads from clobbering over one
another, you can even use thread-unsafe package calls within those subs,
like to DBI.

3) By serializing all callbacks, do you not reduce performance?

Without locking the subroutines, Sendmail::Milter is simply way too
unstable, and effectively unusable. However, since there are 10 callbacks in
total, each thread is only serialized for those occassions when two threads
try and access the same sub at the same time. Otherwise they run parallel
too: one thread may acces the eom_callback whilst another enters the
helo_callback, for instance. In fact, as long as all threads are just
slightly out of phase with one another (one callback difference minimum),
they all run nicely parallel.

4) Does spf-milter act prior to the DATA phase?

Yes, spf-milter makes its SPF checks before the DATA phase; at
envfrom_callback (at: "MAIL FROM: <address>"), or at envrcpt_callback (at:
"RCPT TO: <recipient>"), when running in "mx" mode.

5) Can spf-milter be used within the same sendmail configuration as
MIMEDefang (and other Milters)?

Yes. Quoting a bit from the libmilter documentation:

SPECIFYING FILTERS IN SENDMAIL CONFIGS

Filters are specified with a key letter ``X'' (for ``eXternal'').

For example:

    Xfilter1, S=local:/var/run/f1.sock, F=R
    Xfilter2, S=inet6:999@localhost, F=T, T=C:10m;S:1s;R:1s;E:5m
    Xfilter3, S=inet:3333@localhost

specifies three filters. Filters can be specified in your .mc file using
the following:

    INPUT_MAIL_FILTER(`filter1', `S=local:/var/run/f1.sock, F=R')
    INPUT_MAIL_FILTER(`filter2', `S=inet6:999@localhost, F=T')
    INPUT_MAIL_FILTER(`filter3', `S=inet:3333@localhost')

Which filters are invoked and their sequencing is handled by the
InputMailFilters option:

    O InputMailFilters=filter1, filter2, filter3

This is is set automatically according to the order of the
INPUT_MAIL_FILTER commands in your .mc file. Alternatively, you can
reset its value by setting confINPUT_MAIL_FILTERS in your .mc file.
This options causes the three filters to be called in the same order
they were specified.

=cut