#!/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;
syntax highlighted by Code2HTML, v. 0.9.1