"Fossies" - the Fresh Open Source Software Archive

Member "Mail-SPF-Query-1.999.1/examples/sendmail-milter" (31 Dec 2005, 31878 Bytes) of package /linux/privat/old/Mail-SPF-Query-1.999.1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 #!/usr/bin/perl
    2 #
    3 # Sendmail Milter to perform SPF lookups
    4 #
    5 # (If you use the shebang line, make sure it contains
    6 # a thread-enabled Perl!)
    7 #
    8 # Code by Mark Kramer <admin@asarian-host.net> on December 3, 2003
    9 #
   10 # Version 1.40
   11 #
   12 # Last revision: March 27, 2004
   13 #
   14 # With thanks to Alain Knaff for adding improved "Getopt" functionality,
   15 # waitpid stuff to ensure spf-milter parent does not exit until child
   16 # is really up and running, a new option to kill the milter, and one to
   17 # add local policy.
   18 
   19 # Tested under Perl, v5.8.0 built for i386-freebsd-thread-multi,
   20 # using the Sendmail::Milter 0.18 engine.
   21 #
   22 # Licensed under GPL
   23 #
   24 # see: http://www.openspf.org
   25 #      http://www.libsrs2.org/srs/srs.pdf
   26 #
   27 # availability: bundled with Mail::SPF::Query on CPAN
   28 #               or at http://www.openspf.org/downloads.html
   29 #
   30 # this version is compatible with SPF draft 02.9.7.
   31 #
   32 
   33 # INSTALLATION:
   34 # =============
   35 #
   36 # Basic INSTALL doc at http://www.openspf.org/sendmail-milter-INSTALL.txt
   37 #
   38 # Adiitional install notes by Alain Knaff:
   39 #
   40 # The milter must be started/stopped explicitly before/after sendmail.
   41 # Add the following to /etc/init.d/sendmail to start it (must be
   42 # before starting sendmail):
   43 #
   44 #   $SPF_MILTER -l 'include:local-forwarders' mail
   45 #
   46 # where local-forwarders is the name of a pseudo-domain holding an SPF
   47 # record describing all hosts allowed to bypass SPF checks (typically,
   48 # foreign hosts on which your users have set up .forwards pointing
   49 # towards addresses hosted by you). If none of your users have set up
   50 # any forwarding, you can leave this away
   51 #
   52 # Add the following to stop it (must be after stopping sendmail):
   53 #
   54 #   $SPF_MILTER -k
   55 #
   56 # Note: This milter looks for the sendmail.cf file in /etc/mail. If
   57 # your sendmail.cf lives elsewhere (SuSE), establish a symlink:
   58 #   ln -s /etc/sendmail.cf /etc/mail/sendmail.cf
   59 #
   60 # ==============
   61 
   62 # ----------------------------------------------------------
   63 #                            config
   64 # ----------------------------------------------------------
   65 
   66 # where do we store pid, sock, and logs? No trailing / please!
   67 # Set it at will, like '/var/spool/spf-milter', as long as it
   68 # ends in "spf-milter". Sanity check, further down the road,
   69 # will ensure that it does!
   70 #
   71 # If you change $basedir, be sure to make the same change to
   72 # INPUT_MAIL_FILTER in your mc file!
   73 
   74 my $basedir = '/var/spf-milter';
   75 
   76 # Our main SRS object; adjust this to your server's needs!
   77 
   78 my $srs = new Mail::SRS (Secret => 'whateverfloatsyourboat', MaxAge => 4, HashLength => 8, HashMin => 8, AlwaysRewrite => 1, Separator => '+');
   79 
   80 # where do we log SPF activity?
   81 
   82 my $SPF_LOG_FILENAME = POSIX::strftime ($basedir . "/spflog-%Y%m.log", localtime);
   83 
   84 # do we feel a need to flock the SPF logfile?
   85 
   86 use constant FLOCK_SPFLOG => 0;
   87 
   88 # ----------------------------------------------------------
   89 #          no user-serviceable parts below this line
   90 # ----------------------------------------------------------
   91 
   92 use POSIX qw (:sys_wait_h);
   93 use Sendmail::Milter;
   94 use Socket;
   95 use Mail::SPF::Query;
   96 use Mail::SRS;
   97 use threads;
   98 use threads::shared;
   99 use strict;
  100 use Getopt::Std;
  101 use Errno qw (ESRCH EINTR);
  102 require 5.8.0;
  103 
  104 use vars qw/$opt_k $opt_l $opt_t $opt_m $opt_S $opt_r $opt_h $opt_T/;
  105 
  106 my $pidFile = $basedir . '/spf-milter.pid';
  107 my $sock = $basedir . '/spf-milter.sock';
  108 
  109 my @extraParams : shared = ();
  110 
  111 my $mx_mode : shared = 0;
  112 my $our_hostname : shared = 0;
  113 my $trust : shared = 1;
  114 my $require_srs_dsn : shared = 0;
  115 my $will_relay_srs1 : shared = 0;
  116 my $tagOnly : shared = 0;
  117 
  118 my ($conn, $user, $pid, $login, $pass, $uid, $gid);
  119 
  120 # Feel free to replace this with your preferred logging scheme, eg Sys::Syslog or Log::Dispatch
  121 
  122 sub write_log : locked {
  123     open  (SPFLOG, "+>>".$SPF_LOG_FILENAME) || (warn "$0: unable to write to $SPF_LOG_FILENAME: $!" && return);
  124     if (FLOCK_SPFLOG) {
  125         flock (SPFLOG, 2);
  126         seek  (SPFLOG, 0, 2);
  127     }
  128     print  SPFLOG localtime () . ": @_\n";
  129     close (SPFLOG);
  130 }
  131 
  132 sub log_error_and_exit : locked {
  133     write_log (@_);
  134     print STDERR "spf-milter: @_\n";
  135     exit 1;
  136 }
  137 
  138 # To accomodate the thread-unsafe Socket package, the one
  139 # "socket_call" provides an additional pseudo-lock mechanism for use
  140 # within the same thread. Since socket_call has the 'locked' attribute,
  141 # within a single thread only one call can be made to it at the time. The
  142 # first parameter to the call is either 1 or 2. The former returns the IP
  143 # address of sockaddr_in; the latter does SPF::Query. Thus providing
  144 # exclusivity within the same thread.
  145 #
  146 # Though I know you will try anyway, do NOT remove the 'locked' attribute;
  147 # spf-milter WILL crash, sooner rather than later. The serialization
  148 # effect of the extra locking mechanism is negligible; it will only occur
  149 # when connect_callback and envfrom_callback (from two different threads)
  150 # should wish to access socket_call at the same time. At any rate, I
  151 # designed spf-milter to run super-stable. Adjust the code if your
  152 # priority lies elsewhere.
  153 
  154 sub socket_call : locked {
  155     # usage:
  156     #  socket_call (0) => undef
  157     #  socket_call (1, sockaddr_in)
  158     #  socket_call (2, "1.2.3.4", 'sender@example.com', 'helohostname.example.com')
  159 
  160     my $choice = shift;
  161 
  162     return undef if not $choice;
  163 
  164     if ($choice == 1) {
  165 
  166     # connect_callback parses (defined $sockaddr_in) as first parameter, thus
  167     # forming choice 1, or none at all. As with all calls to external
  168     # packages, we run them within an eval {} clause to prevent spf-milter
  169     # from dying on us.
  170 
  171         my ($port, $iaddr);
  172         eval {
  173            ($port, $iaddr) = sockaddr_in (shift);
  174             $choice = inet_ntoa ($iaddr);
  175         };
  176         return ($choice);
  177     } elsif ($choice == 2) {
  178 
  179         # Here we do SPF::Query. We parse $priv_data along from envfrom_callback,
  180         # as we want to store $smtp_comment for later use in eom_callback.
  181         #
  182         # We will not use the alternate 'best_guess' method here. Risking a 'fail'
  183         # from best_guess, prior to "Sunrise Date", is too rich for my blood.
  184 
  185         my $priv_data = shift;
  186 
  187         if (my $query = eval {new Mail::SPF::Query (ip => shift, sender => shift, helo => shift, @extraParams)}) {
  188             my ($call_status, $result, $smtp_comment, $header_comment, $spf_record);
  189 
  190             # In "mx" mode, we make a call to result2 (), instead of to result (),
  191             # to which we parse an extra parameter, $priv_data->{'to'}, so
  192             # result2 () can check against secondaries for the recipent.
  193 
  194             if ($mx_mode) {
  195                 $call_status = eval {($result, $smtp_comment, $header_comment, $spf_record) = $query->result2 (shift)};
  196             } else {
  197                 $call_status = eval {($result, $smtp_comment, $header_comment, $spf_record) = $query->result ()};
  198             }
  199 
  200             if ($call_status) {
  201 
  202                 # Return $smtp_comment, if defined, else the prefab $header_comment.
  203 
  204                 $smtp_comment ||= $header_comment;
  205 
  206                 # Need to escape unprotected % characters in spf_smtp_comment,
  207                 # or sendmail will use the default "Command rejected" message instead.
  208                 # Noted by Paul Howarth
  209 
  210                 $smtp_comment =~ s/%/%%/g;
  211 
  212                 # Since $smtp_comment can be whatever is returned, we consider it highly
  213                 # tainted, and first run it through a 'garbage' filter, so as to clear it
  214                 # of weird characters, newlines, etc., that could potentially crash your
  215                 # mailer (possible exploits?).
  216 
  217                ($priv_data->{'spf_smtp_comment'}   = $smtp_comment)   =~ tr/\000-\010\012-\037\200-\377/ /s;
  218                ($priv_data->{'spf_header_comment'} = $header_comment) =~ tr/\000-\010\012-\037\200-\377/ /s;
  219                 return ($result);
  220             } else {
  221                 return undef;
  222             }
  223         } else {
  224             return undef;
  225         }
  226     } else {
  227         return undef;
  228     }
  229 }
  230 
  231 # For some reason, the widespread misconception seems to have crept in
  232 # that Sendmail::Milter private data must somehow be "frozen/thawed"
  233 # before processing (a.l.a the namesake FreezeThaw package). This is not
  234 # the case. FreezeThaw, and similar functions, which freeze referenced
  235 # Perl structures into serialized versions, and thaw these serialized
  236 # structures back into references, are ONLY required should you wish to
  237 # transport entire hashes and such. But there is no need to do that. On a
  238 # per-connection basis, at connect_callback, we declare a private hash,
  239 # and set use "$ctx->setpriv" to set the reference to that hash:
  240 #
  241 # my $priv_data = {};
  242 # $ctx->setpriv($priv_data);
  243 #
  244 
  245 sub connect_callback : locked {
  246     my $ctx = shift;
  247     my $priv_data = {};
  248     $priv_data->{'hostname'} = shift;
  249     my $sockaddr_in = shift;
  250     $priv_data->{'ipaddr'} = socket_call ((defined $sockaddr_in), $sockaddr_in);
  251 
  252     # Our hostname can be extracted from the j macro; idea by Alain Knaff
  253     # There is no need to reset it on each connection, though. It is now
  254     # a global variable, and has been taken out of the per-connection hash.
  255 
  256     $our_hostname ||= $ctx -> getsymval ('j');
  257     $ctx->setpriv($priv_data);
  258     return SMFIS_CONTINUE;
  259 }
  260 
  261 sub helo_callback : locked {
  262     my $ctx = shift;
  263     my $priv_data = $ctx->getpriv();
  264     $priv_data->{'helo'} = shift;
  265 
  266     # We also allow a bypass for STARTTLS authenticated users!
  267 
  268     $priv_data->{'is_authenticated'} = ($ctx -> getsymval ('{verify}') eq 'OK');
  269     $ctx->setpriv($priv_data);
  270     return SMFIS_CONTINUE;
  271 }
  272 
  273 sub envfrom_callback : locked {
  274     my $ctx = shift;
  275     my $priv_data = $ctx->getpriv();
  276    ($priv_data->{'from'} = lc (shift)) =~ s/[<>]//g;
  277 
  278     # Is this a DSN?
  279 
  280     $priv_data->{'bounce'} = ($priv_data->{'from'} eq '');
  281 
  282     # In case of a valid MAIL FROM: <>, SPF::Query checks against the HELO string,
  283     # with 'postmaster' as localpart, but will leave an empty $priv_data->{'from'}
  284     # variable (which, for instance, shows up in $header_comment as a double space
  285     # after "domain of"). Here we compensate for that.
  286 
  287     $priv_data->{'from'} ||= "postmaster\@$priv_data->{'helo'}";
  288 
  289     # Are we authenticated via SASL? Do not set if
  290     # we're already STARTTLS authenticated.
  291 
  292     $priv_data->{'is_authenticated'} ||= $ctx -> getsymval ('{auth_authen}');
  293 
  294     # envfrom_callback can be called more than once within the same connection;
  295     # delete $priv_data->{'spf_result'} on entry!
  296 
  297     delete $priv_data->{'spf_result'};
  298 
  299     # SASL/STARTTLS authenticated IP addresses always pass!
  300 
  301     if ($priv_data->{'is_authenticated'}) {
  302         $priv_data->{'spf_result'} = "pass";
  303         $priv_data->{'spf_header_comment'} = "$our_hostname: $priv_data->{'ipaddr'} is authenticated by a trusted mechanism";
  304         $ctx -> setpriv ($priv_data);
  305         return SMFIS_CONTINUE;
  306     }
  307 
  308     $ctx->setpriv($priv_data);
  309 
  310     # Do the Milter equivalent of "PrivacyOptions=needmailhelo". Needed for SPF.
  311 
  312     if (not $priv_data->{'helo'}) {
  313         $ctx->setreply('503', '5.0.0', "Polite people say HELO first");
  314         return SMFIS_REJECT;
  315     }
  316 
  317     # Did we start in "mx" mode? If so, we will delay SPF checks until
  318     # envrcpt_callback.
  319 
  320     return SMFIS_CONTINUE if ($mx_mode);
  321 
  322     # Make the SPF query, and immediately store the result in our private hash;
  323     # we may also need it later, at eom_callback.
  324 
  325     if ($priv_data->{'spf_result'} = socket_call (2, $priv_data, $priv_data->{'ipaddr'}, $priv_data->{'from'}, $priv_data->{'helo'})) {
  326         if ($priv_data->{'spf_result'} eq 'fail') {
  327             if ($tagOnly) {
  328                 write_log ("SPF \"fail\" from ip=".$priv_data->{'ipaddr'}.
  329                            " helo=".$priv_data->{'helo'}.
  330                            " from=".$priv_data->{'from'});
  331             } else {
  332                 $ctx->setreply('550', '5.7.1', "$priv_data->{'spf_smtp_comment'}");
  333                 return SMFIS_REJECT;
  334             }
  335         } elsif ($priv_data->{'spf_result'} eq 'error') {
  336             $ctx->setreply('451', '4.7.1', "$priv_data->{'spf_smtp_comment'}");
  337             return SMFIS_TEMPFAIL;
  338         }
  339     }
  340 
  341     $ctx -> setpriv ($priv_data);
  342     return SMFIS_CONTINUE;
  343 }
  344 
  345 sub envrcpt_callback : locked {
  346     my $ctx = shift;
  347     my $priv_data = $ctx->getpriv();
  348     my ($envelope_to, $reversed_recipient);
  349 
  350     # Keep the old recipient too, exactly as it appeared
  351     # in the SMTP dialoge!
  352 
  353    ($priv_data->{'to'} = ($envelope_to = shift)) =~ s/[<>]//g;
  354 
  355     # Are we relaying or receiving? The bulk of our labor is at local delivery.
  356 
  357     if ($ctx -> getsymval ('{rcpt_mailer}') eq 'local') {
  358 
  359         # If we require that all DSN messages are SRS signed (-S option),
  360         # then here we check whether we have a valid SRS address
  361         # in case of a DSN.
  362         #
  363         # Before you use this option, make sure you are well
  364         # familiar with its possible consequences! Basically, you
  365         # will be denying access to ALL non-SRS signed recipients,
  366         # in case of a DSN. Only use this when you have implemented
  367         # a SRS signing scheme in your MTA, which will sign ALL outgoing
  368         # envelope-from addresses. Unfortunately, spf-milter cannot do
  369         # that for you, as the Milter specs do not allow for a method
  370         # to change the envelope-from address.
  371         #
  372         # Also, be sure to visit:
  373         #
  374         #    http://www.libsrs2.org
  375         #    http://www.openspf.org/srs.html
  376         #    http://srs-socketmap.info/sendmailsrs.htm
  377         #
  378         # The -S option is for people with a specific, deliberate
  379         # purpose in mind. Do not haphazardly enable this just
  380         # because the idea of 'signed' addresses makes you feel safer;
  381         # if you did not specifically set up your MTA for this purpose,
  382         # then this option is not for you.
  383 
  384         if ($require_srs_dsn) {
  385             if ($priv_data->{'bounce'}) {
  386 
  387                 # First scenario; we receive a SRS0 address; a one-pass
  388                 # reversal should 'eval' to tell us whether it is really
  389                 # ours, and valid.
  390 
  391                 if ($priv_data->{'to'} =~ /^SRS0[+-=]/i) {
  392                     if (not (eval {$reversed_recipient = $srs -> reverse ($priv_data->{'to'})})) {
  393                         $ctx -> setreply ('550', '5.7.5', "Invalid SRS signature!");
  394                         $ctx -> setpriv ($priv_data);
  395                         return SMFIS_REJECT;
  396                     } else {
  397 
  398                         # We will store reversed recipients in pairs:
  399                         # the orginal recipient (exactly as it appeared in
  400                         # the SMTP dialogue) + its reversed counterpart.
  401                         #
  402                         # At eom_callback, as per the Milter protocol,
  403                         # we will avail ourselves of the first best
  404                         # opportunity to use a corresponding delrcpt/addrcpt
  405                         # combo to change the recipients in the envelope.
  406 
  407                         $priv_data->{'reversed_recipients'} .= "$envelope_to $reversed_recipient ";
  408                     }
  409 
  410                 # Second scenario; we will use a two-pass reversal on the SRS1 address.
  411                 # If it is still ours thereafter, we will accept it.
  412 
  413                 } elsif ($priv_data->{'to'} =~ /^SRS1[+-=]/i) {
  414                     if (not (eval {$_ = $srs -> reverse ($priv_data->{'to'})})) {
  415                         $ctx -> setreply ('550', '5.7.5', "Invalid SRS signature!");
  416                         $ctx -> setpriv ($priv_data);
  417                         return SMFIS_REJECT;
  418                     } elsif (not (eval {$reversed_recipient = $srs -> reverse ($_)})) {
  419                         if (not $will_relay_srs1) {
  420                             $ctx -> setreply ('551', '5.7.1', "User not local; please try <$_> directly");
  421                             $ctx -> setpriv ($priv_data);
  422                             return SMFIS_REJECT;
  423                         } else {
  424 
  425                             # Since the outer SRS1 address was targeted locally, it did
  426                             # not trigger sendmail's relay rules. If the reversal of the
  427                             # SRS1 address appears to be non-local after all, sendmail,
  428                             # still working under the assumption that this was a local
  429                             # delivery, will relay without question!
  430                             #
  431                             # Please, do not worry about being an open relay, though: SRS1
  432                             # addresses now have an extra hash to prevent forgery.
  433 
  434                             $reversed_recipient = $_;
  435                         }
  436                     }
  437                     $priv_data->{'reversed_recipients'} .= "$envelope_to $reversed_recipient ";
  438 
  439                 # Okay, no SRS address found; and we really should have. If the
  440                 # recipient is not postmaster@ or abuse@ (or abuse-report@, etc),
  441                 # we complain; otherwise, we turn a blind eye.
  442                 #
  443                 # N.B. Future versions of spf-milter may remove this 'bypass'.
  444                 # For now, while SPF is still in the early stages of its
  445                 # adoption phase, we will allow for this exception.
  446 
  447                 } elsif (not ($priv_data->{'to'} =~ /^(postmaster|abuse)\b/i)) {
  448                     $ctx -> setreply ('550', '5.7.5', "Bounce address not SRS signed!");
  449                     $ctx -> setpriv ($priv_data);
  450                     return SMFIS_REJECT;
  451                 }
  452 
  453                 # We only expect to see SRS in DSN. Mind you, this is a two-way
  454                 # street! We do not accept incoming SRS addresses outside the
  455                 # context of DSN; and, likewise, you cannot send out to (local)
  456                 # SRS recipients, other than using an empty envelope-from!
  457 
  458             } elsif ($priv_data->{'to'} =~ /^SRS[01][+-=]/i) {
  459                 $ctx -> setreply ('550', '5.7.6', "SRS only supported in DSN!");
  460                 $ctx -> setpriv ($priv_data);
  461                 return SMFIS_REJECT;
  462             }
  463         }
  464 
  465     # We are relaying. Only a single, outer check here: are
  466     # we sending to an SRS1 address? If so, a one-pass reversal
  467     # must 'eval'. The inner reverse may, or may not, 'eval'
  468     # (in fact, it will probably not, as the result will likely
  469     # be a third-party SRS0 address).
  470     #
  471     # N.B. Please notice the absence of a separate outer SRS0
  472     # check. We only arrive here in 'relay' mode (which means:
  473     # any SRS0 target will always have a non-local domain name
  474     # part, which we will not be able to 'eval' anyway).
  475 
  476     } elsif ($priv_data->{'to'} =~ /^SRS[01][+-=]/i) {
  477         if (not $priv_data->{'bounce'}) {
  478             $ctx -> setreply ('550', '5.7.6', "SRS only supported in DSN!");
  479             $ctx -> setpriv ($priv_data);
  480             return SMFIS_REJECT;
  481         } elsif ($priv_data->{'to'} =~ /^SRS1[+-=]/i) {
  482             if (not (eval {$_ = $srs -> reverse ($priv_data->{'to'})})) {
  483                 $ctx -> setreply ('550', '5.7.5', "Invalid SRS signature!");
  484                 $ctx -> setpriv ($priv_data);
  485                 return SMFIS_REJECT;
  486             } elsif (not (eval {$reversed_recipient = $srs -> reverse ($_)})) {
  487                 if (not $will_relay_srs1) {
  488                     $ctx -> setreply ('551', '5.7.1', "User not local; please try <$_> directly");
  489                     $ctx -> setpriv ($priv_data);
  490                     return SMFIS_REJECT;
  491                 } else {
  492 
  493                     # Yes, this could be a non-local recipient. Please,
  494                     # do not worry about being an open relay here;
  495                     # since the outer SRS1 address was non-local to begin
  496                     # with, only authorized IP-space can make this relay
  497                     # happen anyway.
  498 
  499                     $reversed_recipient = $_;
  500                 }
  501             }
  502             $priv_data->{'reversed_recipients'} .= "$envelope_to $reversed_recipient ";
  503         }
  504     }
  505 
  506     $ctx->setpriv($priv_data);
  507 
  508     # We're done if we're already authenticated.
  509 
  510     return SMFIS_CONTINUE if ($priv_data->{'is_authenticated'});
  511 
  512     # Here we do the opposite check of envfrom_callback: if not "mx" mode,
  513     # we bale rightaway.
  514 
  515     return SMFIS_CONTINUE if (not $mx_mode);
  516 
  517     # We also need to purge $priv_data->{'spf_result'} for each recipient!
  518 
  519     delete $priv_data->{'spf_result'};
  520 
  521     $ctx->setpriv($priv_data);
  522 
  523     if ($priv_data->{'spf_result'} = socket_call (2, $priv_data, $priv_data->{'ipaddr'}, $priv_data->{'from'}, $priv_data->{'helo'}, $priv_data->{'to'})) {
  524         if ($priv_data->{'spf_result'} eq 'fail') {
  525             if ($tagOnly) {
  526                 write_log ("SPF \"fail\" from ip=".$priv_data->{'ipaddr'}.
  527                            " helo=".$priv_data->{'helo'}.
  528                            " from=".$priv_data->{'from'}.
  529                            " to=".$priv_data->{'to'});
  530             } else {
  531                 $ctx->setreply('550', '5.7.1', "$priv_data->{'spf_smtp_comment'}");
  532                 return SMFIS_REJECT;
  533             }
  534         } elsif ($priv_data->{'spf_result'} eq 'error') {
  535             $ctx->setreply('451', '4.7.1', "$priv_data->{'spf_smtp_comment'}");
  536             return SMFIS_TEMPFAIL;
  537         }
  538     }
  539 
  540     $ctx -> setpriv ($priv_data);
  541     return SMFIS_CONTINUE;
  542 }
  543 
  544 sub eom_callback : locked {
  545     my $ctx = shift;
  546     my $priv_data = $ctx->getpriv();
  547 
  548     # Did we get an SPF result? If so, add the appropriate header. There is no
  549     # longer a need to use the "chgheader" method to replace the first
  550     # occurance of a Received-SPF header; "addheader" will automatically
  551     # prepend the new Received-SPF header.
  552 
  553     if ($priv_data->{'spf_result'}) {
  554         $ctx->addheader('Received-SPF', $priv_data->{'spf_result'} . ' (' . $priv_data->{'spf_header_comment'} . ')');
  555     }
  556 
  557     # Only at eom_callback can we substitute SRS recipients.
  558 
  559     if ($priv_data->{'bounce'}) {
  560         my ($old_recipient, $new_recipient);
  561 
  562         # The convenient twin structure of a hash makes it possible
  563         # to just suck in the entire split string, and have it neatly
  564         # be distributed over "$old_recipient, $new_recipient" pairs.
  565         # Cute, eh?
  566 
  567         my %srs = split (/ /, $priv_data->{'reversed_recipients'});
  568         while (($old_recipient, $new_recipient) = each %srs) {
  569             $ctx -> delrcpt ($old_recipient);
  570             $ctx -> addrcpt ($new_recipient);
  571         }
  572     }
  573 
  574     $ctx->setpriv($priv_data);
  575 
  576     return SMFIS_CONTINUE;
  577 }
  578 
  579 # On RSET, forget everything except the HELO name. Noted by Paul Howarth
  580 #
  581 # (note by me: we also need to preserve the hostname of the sender,
  582 # our own hostname, and the IP address of the sender! Best, therefore, to
  583 # use a negative logic, and just delete the things that need to go)
  584 #
  585 # BTW, we keep 'is_authenticated' in 1.40; during an entire session
  586 # the connection should remain authenticated (unless a new HELO sounds
  587 # the possible start of a new STARTTLS session).
  588 
  589 sub abort_callback : locked {
  590     my $ctx = shift;
  591     my $priv_data = $ctx->getpriv();
  592     delete $priv_data->{'spf_result'};
  593     delete $priv_data->{'from'};
  594     delete $priv_data->{'to'};
  595     delete $priv_data->{'bounce'};
  596     delete $priv_data->{'reversed_recipients'};
  597     $ctx->setpriv($priv_data);
  598     return SMFIS_CONTINUE;
  599 }
  600 
  601 sub close_callback {
  602     my $ctx = shift;
  603     $ctx->setpriv(undef);
  604     return SMFIS_CONTINUE;
  605 }
  606 
  607 my %my_callbacks =
  608 (
  609     'connect' => \&connect_callback,
  610     'helo'    => \&helo_callback,
  611     'envfrom' => \&envfrom_callback,
  612     'envrcpt' => \&envrcpt_callback,
  613     'eom'     => \&eom_callback,
  614     'close'   => \&close_callback,
  615     'abort'   => \&abort_callback,
  616 );
  617 
  618 ############################################################
  619 # Main code
  620 
  621 # We start spf-milter as root for the same reason we do NOT run spf-milter
  622 # as root: security. And we start it with at least one parameter, the user
  623 # to run as. Spf-milter expects to create/read/write its log, pid, and socket,
  624 # all in /var/spf-milter/, and will itself create the directory, if need be,
  625 # and set all appropriate permissions/ownerships.
  626 #
  627 # Add "mx" as second parameter to run spf-milter in "mx" mode. In "mx" mode
  628 # spf-milter makes its SPF checks at envrcpt_callback, instead of envfrom_callback,
  629 # and calls result2 (), instead of result (), to allow for an early-out for
  630 # secondaries. The default mode performs SPF checks at envfrom_callback.
  631 #
  632 # Per default, spf-milter queries trusted-fowarder.org (on 'fail' only), to
  633 # check whether the trusted-fowarder domain yields a 'pass' after all. You can
  634 # override the default behavior, adding "dt" (disable trust) as second parameter
  635 # (or third, if you run in "mx" mode). You need at least Mail::SPF::Query 1.99
  636 # for this functionality!
  637 
  638 getopts("kl:tmSrhT");
  639 
  640 sub usage {
  641     my ($ret) = @_;
  642     print STDERR "Usage: $0 [-k] [-l local_trust] [-t] [-m] [-S] [-r] [-h] <user> [mx] [dt]\n";
  643     print STDERR "        -k        kill running milter\n";
  644     print STDERR "        -l        add local trust record\n";
  645     print STDERR "        -t        don't add trusted-forwarder.org record\n";
  646     print STDERR "        -m        trust recipient's MX hosts\n";
  647     print STDERR "        -S        only allow SRS signed bounces (see documentation!)\n";
  648     print STDERR "        -r        will relay SRS1\n";
  649     print STDERR "        -T        don't reject failed messages, tag only\n";
  650     print STDERR "        -h        print this help message\n";
  651     print STDERR "        <user>        user to run this script as\n";
  652     print STDERR "        mx        trust recipient's MX hosts (same as -m)\n";
  653     print STDERR "        dt        don't add trusted-forwarder.org (same as -t)\n";
  654     exit ($ret);
  655 }
  656 
  657 if ($opt_h) {
  658     usage (0);
  659 }
  660 
  661 # Basic, but vital, sanity-check against $basedir. Since we set
  662 # permissions/ownerships on everything (!) in our $basedir, we
  663 # must avoid disasters, such as setting $basedir to /var/run/.
  664 # Therefore, we require that $basedir ends in "spf-milter".
  665 
  666 if (not ($basedir =~ /spf-milter$/i)) {
  667     die '$basedir' . " ('$basedir') must end in /spf-milter!\n";
  668 }
  669 
  670 my $oldPid;
  671 if (-f $pidFile) {
  672     open (PIDFILE, $pidFile) || die "Could not read pid file: $!\n";
  673     chomp ($oldPid = <PIDFILE>);
  674     close (PIDFILE);
  675 }
  676 
  677 if (defined $opt_k) {
  678     die "SPF milter not running\n" if (not $oldPid);
  679 
  680     # We need to kill the milter using signal 3, it apparently doesn't react
  681     # to more "usual" signals...
  682 
  683     if (not kill (3, $oldPid)) {
  684         if ($!{ESRCH}) {
  685             print STDERR "Sendmail milter not running, cleaning files\n";
  686 
  687             # Files will be cleaned by END block
  688 
  689             exit 0;
  690         } else {
  691 
  692             # Prevent cleaning away of the running milter's files
  693 
  694             $pid = 1;
  695 
  696             die "Could not kill SPF milter: $!\n";
  697         }
  698     }
  699 
  700     my $needNl = 0;
  701     select (STDERR);
  702     $| = 1;
  703 
  704     # Waiting for milter to die
  705 
  706     for (my $i = 0; $i < 79; $i++) {
  707         select (undef, undef, undef, 0.25);
  708         if (not kill (0, $oldPid) && $!{ESRCH}) {
  709             print STDERR "\n" if ($needNl);
  710             exit 0; # Milter dead
  711         }
  712         print STDERR ".";
  713         $needNl = 1;
  714     }
  715 
  716     print STDERR "\nForcefully killing milter\n";
  717     kill (9, $oldPid);
  718     exit 0;
  719 }
  720 
  721 if ($oldPid) {
  722     my $r = kill (0, $oldPid);
  723     if (not $!{ESRCH}) {
  724 
  725         # Prevent cleaning away of the running milter's files
  726 
  727         $pid = 1;
  728 
  729         die "SPF milter already running\n";
  730     }
  731 }
  732 
  733 unlink $sock;
  734 unlink $pidFile;
  735 
  736 if (not $user = lc ($ARGV[0])) {
  737     print STDERR "Missing user\n";
  738     usage (1);
  739 } elsif ($>) {
  740     print STDERR "You need to start spf-milter as root!\n";
  741     exit 1;
  742 }
  743 
  744 $mx_mode = 1 if ($opt_m || (lc ($ARGV[1]) eq 'mx'));
  745 
  746 $trust = 0 if ($opt_t || (lc ($ARGV[1]) eq 'dt') || (lc ($ARGV[2]) eq 'dt'));
  747 push (@extraParams, trusted => $trust);
  748 
  749 if ($opt_l) {
  750     push (@extraParams, local => $opt_l);
  751 }
  752 
  753 if ($opt_T) {
  754     $tagOnly = 1;
  755 }
  756 
  757 $require_srs_dsn = 1 if ($opt_S);
  758 $will_relay_srs1 = 1 if ($opt_r);
  759 
  760 # Since we will daemonize, play nice.
  761 
  762 chdir ('/') or exit 1;
  763 
  764 umask (0077);
  765 
  766 if (not (-e $basedir)) {
  767     if (not mkdir $basedir) {
  768         print STDERR "Odd; cannot create $basedir/\n";
  769         exit 1;
  770     }
  771 }
  772 
  773 # The Sendmail::Milter 0.18 engine has a small bug, causing it to extract
  774 # the wrong socket-name when, next to the F flags, there's an additional flag
  775 # in the Milter definition, (see: http://rt.cpan.org/NoAuth/Bug.html?id=3892
  776 # for details). Since the extra flag is useful (T for timeouts), we preset our
  777 # connection string to "local:/var/spf-milter/spf-milter.sock", with "spf-milter"
  778 # as Milter name. A corresponding line in sendmail.cf could look like this:
  779 #
  780 # Xspf-milter, S=local:/var/spf-milter/spf-milter.sock, F=T, T=C:4m;S:4m;R:8m;E:16m
  781 
  782 if (not $conn = Sendmail::Milter::auto_getconn ('spf-milter', '/etc/mail/sendmail.cf')) {
  783     log_error_and_exit ("Milter for 'spf-milter' not found!");
  784 }
  785 
  786 if ($conn =~ /^local:(.+)/) {
  787     if (not Sendmail::Milter::setconn ("local:$sock")) {
  788         log_error_and_exit ("Failed to set connection information!");
  789     }
  790 
  791     # Now we set a fairly large timeout. The idea here is to set it so large, that
  792     # the Milter will not try and compete with the sendmail T= timings, which allow
  793     # for a more fine-grained tuning.
  794 
  795     if (not Sendmail::Milter::settimeout ('8192')) {
  796         log_error_and_exit ("Failed to set timeout value!");
  797     }
  798     if (not Sendmail::Milter::register ('spf-milter', \%my_callbacks, SMFI_CURR_ACTS)) {
  799         log_error_and_exit ("Failed to register callbacks!");
  800     }
  801 
  802     # Get info on the user we want to run as. If $uid is undefined, the user
  803     # does not exist on the system; if zero, it is the UID of root!
  804 
  805    ($login, $pass, $uid, $gid) = getpwnam ($user);
  806     if (not defined ($uid)) {
  807         log_error_and_exit ("$user is not a valid user on this system!");
  808     } elsif (not $uid) {
  809         log_error_and_exit ("You cannot run spf-milter as root!");
  810     }
  811     write_log ("Starting Sendmail::Milter $Sendmail::Milter::VERSION engine");
  812 
  813     # Set all proper permissions/ownerships, according to the user we run as.
  814 
  815     if ((not chown $uid, $gid, $basedir, glob ($basedir . '/*')) ||
  816         (not chmod 0700, $basedir)) {
  817         log_error_and_exit ("Cannot set proper permissions!");
  818     }
  819 
  820     # Drop the Sendmail::Milter privileges!
  821 
  822     $) = $gid;
  823     $( = $gid;
  824     $> = $uid;
  825     $< = $uid;
  826 
  827     # Give us a pretty proc-title to look at in 'ps ax'. :)
  828 
  829     $0 = 'spf-milter' . (($mx_mode) ? (" [mx mode]") : (""));
  830 
  831     # Fork and give us a pid file.
  832 
  833     if ($pid = fork ()) {
  834         open (USERLOG, ">". $pidFile) or exit 1;
  835         flock (USERLOG, 2);
  836         seek (USERLOG, 0, 0);
  837         print USERLOG " $pid";
  838         close (USERLOG);
  839 
  840         # Wait until either milter socket appears or child dies
  841 
  842         my $kid = 0;
  843         while (not -x $sock) {
  844             select (undef,undef,undef,0.01);
  845             $kid = waitpid (-1, WNOHANG);
  846             if ($kid > 0) {
  847                 $pid = 0; # trigger cleanup
  848                 die "Could not start milter\n";
  849             }
  850         }
  851         exit 0;
  852     }
  853 
  854     # Redirect all input/output from/to null
  855 
  856     open (STDIN, '/dev/null');
  857     open (STDOUT, '>/dev/null');
  858 
  859     # Complete de daemonization process.
  860 
  861     POSIX::setsid () or exit 1;
  862 
  863     open (STDERR, '>&STDOUT');
  864 
  865     if (Sendmail::Milter::main ()) {
  866         write_log ("Successful exit from the Sendmail::Milter engine");
  867     } else {
  868         write_log ("Unsuccessful exit from the Sendmail::Milter engine");
  869     }
  870 } else {
  871     log_error_and_exit ("$conn is not a valid connection object!");
  872 }
  873 
  874 END {
  875 
  876     # On exit (child only!) we clean up the mess.
  877 
  878     if (not $pid) {
  879         unlink ($pidFile);
  880         unlink ($sock);
  881     }
  882 }
  883 
  884 exit 0;