#!/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.40
#
# Last revision: March 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://www.openspf.org
#      http://www.libsrs2.org/srs/srs.pdf
#
# availability: bundled with Mail::SPF::Query on CPAN
#               or at http://www.openspf.org/downloads.html
#
# this version is compatible with SPF draft 02.9.7.
#

# INSTALLATION:
# =============
#
# Basic INSTALL doc at http://www.openspf.org/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?

use constant FLOCK_SPFLOG => 0;

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

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

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

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

my @extraParams : shared = ();

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

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

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

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

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

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

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

    my $choice = shift;

    return undef if not $choice;

    if ($choice == 1) {

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

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

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

        my $priv_data = shift;

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

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

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

            if ($call_status) {

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

                $smtp_comment ||= $header_comment;

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

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

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

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

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

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

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

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

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

    # We also allow a bypass for STARTTLS authenticated users!

    $priv_data->{'is_authenticated'} = ($ctx -> getsymval ('{verify}') eq 'OK');
    $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.

    $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://www.openspf.org/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', "$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 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 suck 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:tmSrhT");

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 "        <user>        user to run this script as\n";
    print STDERR "        mx        trust recipient's MX hosts (same as -m)\n";
    print STDERR "        dt        don't add trusted-forwarder.org (same as -t)\n";
    exit ($ret);
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    # Drop the Sendmail::Milter privileges!

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

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

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

    # Fork and give us a pid file.

    if ($pid = fork ()) {
        open (USERLOG, ">". $pidFile) or exit 1;
        flock (USERLOG, 2);
        seek (USERLOG, 0, 0);
        print USERLOG " $pid";
        close (USERLOG);

        # Wait until either milter socket appears or child dies

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