#!/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.42
#
# Last revision: December 2, 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
# ----------------------------------------------------------

# 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.42 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.42 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.libsrs2.org/
        #    http://spf.pobox.com/srs.html
        #    http://srs-socketmap.info/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 1.42\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;