1#!/usr/local/bin/perl 2 3# bogofilter-milter.pl - a Sendmail::Milter Perl script for filtering 4# mail using individual users' bogofilter databases. 5# 6# (additional information below the coypright statement) 7 8# Copyright 2003, 2005, 2007, 2008, 2010 Jonathan Kamens 9# <jik@kamens.brookline.ma.us>. Please send me bug reports, 10# suggestions, criticisms, compliments, or any other feedback you have 11# about this script! 12# 13# The current version of this script and extensive additional 14# documentation are available from 15# <http://stuff.mit.edu/~jik/software/bogofilter/>. 16# 17# This program is free software; you can redistribute it and/or modify 18# it under the terms of the GNU General Public License as published by 19# the Free Software Foundation; either version 2 of the License, or 20# (at your option) any later version. 21# 22# This program is distributed in the hope that it will be useful, but 23# WITHOUT ANY WARRANTY; without even the implied warranty of 24# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 25# General Public License for more details. 26 27# You will need the following non-standard Perl modules installed to 28# use this script: Sendmail::Milter, Mail::Alias, Proc::Daemon, 29# IO::Stringy, Socket, Net::CIDR. Before using this script, search 30# for CONFIGURABLE SETTINGS and configure them appropriately for your 31# site. 32# 33# Inserts "X-Bogosity: Spam, tests=bogofilter" into messages that 34# appear to be spam (or "Ham" or "Unsure" into ones that don't). If 35# the message is rejected, you usually won't see the "Spam", but see 36# below about training mode. 37# 38# Save this script somewhere, launch it as root (by running it in the 39# background or invoking it with "--daemon" in which case it will 40# background itself), and reconfigure your sendmail installation to 41# call it as an external filter (probably by calling INPUT_MAIL_FILTER 42# in your sendmail.mc file). Running this script as root should be 43# safe because it changes its effective UID and GID whenever 44# performing operations on individual users' files (if you find a 45# security problem, please let me know!). 46# 47# NOTE: You will want to take steps to ensure that this script is 48# started before sendmail whenever your machine boots, e.g., by 49# creating an appropriate script in /etc/rc.d/init.d with appropriate 50# links to it in /etc/rc.d/rc?.d, because once you configure sendmail 51# to talk to a particular milter, it may refuse to deliver email if 52# that milter isn't running when the email comes in. 53# 54# For additional information about libmilter and integrating this or 55# any other libmilter filter into your sendmail installation, see the 56# file README.libmilter that ships with sendmail and/or the section 57# entitled "ADDING NEW MAIL FILTERS" in the README file that ships 58# with the M4 sendmail CF templates. 59# 60# You may need to restart this script to get it to notice changes in 61# mail aliases. 62 63# This script logs various informational, warning and error messages 64# to the "mail" facility. 65 66# Thanks to Tom Anderson <neo+bogofilter-milter@orderamidchaos.com> 67# for the IP whitelisting changes and for several other useful 68# suggestions and bug fixes. 69 70# BEGIN CONFIGURABLE SETTINGS 71 72# If this string appears in the Subject of a message (case 73# insensitive), the message won't be filtered. 74my $magic_string = '[no-bogofilter]'; 75 76# Set the syslog facility you wish to log messages to. 77my $log_facility = 'LOG_MAIL'; 78 79# These settings control exactly what error sendmail sends back to the 80# sender if a message is rejected. You can leave them as-is, or 81# customize them as desired. 82my $rcode = 550; # three-digit RFC 821 SMTP reply 83my $xcode = "5.7.1"; # extended RFC 2034 reply code 84my $reject_message = "Your message looks like spam.\n" . 85 "If it isn't, resend it with $magic_string " . 86 "in the Subject line."; 87 88# Whitelist any IP addresses or ranges from this filter. 89# For example: 90#my(@whitelist) = ("127.0.0.1", "10.127.0.1-10.127.0.9", "192.168.0.0/16"); 91my(@ip_whitelist) = (); 92 93# If you want to whitelist any addresses which have authenticated 94# via poprelayd (i.e. remote workstations of users on your server) 95# set $dbfile to your popip.db location, else set it to undef. 96# For example: 97#my $ip_whitelist_db = "/etc/mail/popip.db"; 98my $ip_whitelist_db = undef; 99 100# The largest message to keep in memory rather than writing to a 101# temporary file. 102my $MAX_INCORE_MSG_LENGTH = 1000000; 103 104my $pid_file = '/var/run/bogofilter-milter.pid'; 105 106# Whatever path you specify for $socket needs to match the socket 107# specified in the sendmail.cf file (with "local:" in front of it 108# there, but not here). 109my $socket = '/var/run/bogofilter-milter.sock'; 110 111# The following two settings give more granular control over whether 112# bogofilter is used for any particular user and what configuration 113# settings are used when it is. 114# - If $bogofilter_cf is set, then the script will look for a file 115# with that name in the user's home directory. If it finds it, then 116# bogofilter will be called with "-c $HOME/$bogofilter_cf" so that the 117# specified configuration file is used rather than the default, 118# .bogofilter.cf. 119# - If $require_cf is true, then the specified configuration file 120# *must* exist for bogofilter to be used for this user. In other 121# words, rather than only looking for the .bogofilter subdirectory of 122# the user's home directory, the script will look for both the 123# .bogofilter subdirectory *and* the config file. 124# - Note that $require_cf is ignored if $bogofilter_cf is unset. 125my $bogofilter_cf = undef; 126my $require_cf = undef; 127 128# If you would like the milter to add a unique ID to the X-Bogosity 129# line, then set this variable to true. ", milter_id=..." will be 130# added to the end of the X-Bogosity line. 131my $add_unique_id = 1; 132 133# If a file with this name exists in the user's .bogofilter directory, 134# then it is assumed to contain regular expressions, one per line, to 135# match against Subject lines in incoming messages (lines containing 136# only whitespace and lines starting with "#" are ignored). Any 137# message whose Subject line matches one of the regular expressions 138# will not be filtered, just as if $magic_string (see above) had 139# appeared in its Subject line. 140my $subject_filter_file = 'milter-subject-filters'; 141 142# If an executable file or link with this name exists in the user's 143# .bogofilter directory, and it is owned by the user or root (for 144# security reasons), then it will be used as a filter, i.e., the 145# message will be fed into it and replaced with its output, before 146# bogofilter is run on it, if it returns a zero exit status. 147# Furthermore, the filtered message is what will be put into the 148# $archive_mbox and $ham_archive_mbox files. However, the actual 149# message delivered by the MTA if the milter accepts it will be the 150# unfiltered version, not the filtered version. You could use this, 151# e.g., to reformat incoming email with a script that calls 152# spamitariuim.pl (in bogofilter contrib directory) before filtering 153# it. 154# 155# The following environment variables are available to the script when 156# it is executed: 157# 158# MILTER_REMOTE_IP IP address of remote SMTP server 159# MILTER_REMOTE_NAME Host name of remote SMTP server as per a 160# reverse DNS lookup on its IP address 161# MILTER_LOCAL_IP IP address of SMTP server receiving the 162# message 163# MILTER_LOCAL_NAME Host name of SMTP server receiving the message 164# MILTER_HELOHOST Host name specified by the remote server in 165# its HELO or EHLO command 166# MILTER_ENVFROM The envelope address of the sender of the 167# message, a.k.a., the Return-Path 168# MILTER_ENVRCPT The envelope address of the recipient of the 169# message for whom bogofilter is being invoked. 170# 171# If you want to disable this functionality, set the variable to 172# undef. 173my $filter_script = 'milter-filter-script'; 174 175# If a file with this name exists in the user's .bogofilter directory, 176# then that user's mail will be filtered in training mode. This means 177# that the message will be filtered and registered as spam or non-spam 178# and the appropriate X-Bogosity header will be inserted, but it'll be 179# delivered even if bogofilter thinks it's spam. This allows the user 180# to detect false positives or false negatives and feed them back into 181# bogofilter to train it. To disable this functionality set 182# $training_file to undef. 183my $training_file = 'training'; 184 185# If a file or link with this name exists in the user's .bogofilter 186# directory, then copies of rejected messages will be saved in this 187# file in mbox format, using flock locking. To disable rejected 188# message archiving, set $archive_mbox to undef. 189my $archive_mbox = 'archive'; 190 191# If a file or link with this name exists in the user's .bogofilter 192# directory, then copies of accepted messages (Ham or Unsure) will be 193# saved in this file in mbox format, using flock locking. To disable 194# accepted message archiving, set $ham_archive_mbox to undef. 195my $ham_archive_mbox = 'ham_archive'; 196 197# If $cyrus_deliver is set to an existing executable, then it is 198# assumed to be a Cyrus IMAP "deliver" program. If the $archive_mbox 199# or $ham_archive_mbox for a particular user is a symlink pointing at 200# a nonexistent file whose name starts with "cyrus:", then everything 201# after the "cyrus:" is assumed to be the name of a Cyrus IMAP folder 202# within the user's mailbox to which to deliver the spam message 203# instead of saving it into an mbox format file. 204my $cyrus_deliver = '/usr/lib/cyrus-imapd/deliver'; 205 206# If you would like to use a shared bogofilter database for everyone, 207# rather than separate per-user databases, then create a user on your 208# system to be used as a home for the shared database, and set 209# $database_user to that user's username. 210# 211# If you set $database_user, then all the logic described above for 212# deciding whether to run bogofilter, whether to run in training mode 213# or real mode, and whether to archive spam still applies, so make 214# sure you configure $database_user's account properly. 215# 216# If you set $database_user, then $aliases_file, $sendmail_canon, 217# $sendmail_prog, $recipient_cache_expire, and 218# $recipient_cache_check_interval do NOT apply and are ignored. 219my $database_user = undef; 220 221# Mail::Alias is used to expand SMTP recipient addresses into local 222# mailboxes to determine if any of them have bogofilter databases. If 223# someone sends E-mail to a mailing list or alias whose expansion 224# contains one or more local users with bogofilter databases, then one 225# of those users' database (which one in particular is not defined) 226# will be used to filter the message. To disable this functionality 227# and remove the dependency on Mail::Alias, comment out the "use 228# Mail::Alias;" line and set $aliases_file to undef in the 229# configuration section. With this functionality disabled, mail will 230# only be filtered if it is sent directly to a user in the passwd 231# file. On the other hand, with this functionality enabled, one 232# person's bogofilter database can cause a message to be filtered for 233# everyone on a local mailing list. 234my $aliases_file = '/etc/aliases'; 235 236# If you want the milter to ask sendmail to canonicalize recipient 237# addresses before trying to alias-expand them, then set 238# $sendmail_canon to true and $sendmail_prog to the path of the 239# sendmail binary to invoke. This is necessary, e.g., if you use a 240# virtual user table for some recipients that do sendmail filtering. 241# You may also wish to examine the sendmail_canon subroutine below, 242# because it may not be right for your particular sendmail 243# configuration. Search for CHECKTHIS in the function. 244my $sendmail_canon = 1; 245my $sendmail_prog = '/usr/sbin/sendmail'; 246 247# @discard_control is an array of anonymous arrays. Each sub-array 248# contains a pair of entries, a control pattern and an action, either 249# "discard" or "reject". The action corresponding to the first 250# matching control pattern determines what happens to the messages. 251# If @discard_control is empty or none of its control patterns match, 252# the default action is "reject". The following control patterns are 253# valid: 254 255# "addr:a.b.c.d" matches if the sending host has the indicated IP address 256# "netblock:a.b.c.d/e" matches if the sending host is in the indicated netblock 257# "host:fqdn" matches if the IP address of the sending host resolves 258# to the indicated host name 259# "domain:fqdn" matches if the IP address of the sending host resolves 260# to a host name in the indicated domain 261# "mx" matches if one of the MX servers for the recipient's 262# domain resolves to the IP address of the sending host 263# "*" always matches 264 265# The default @discard_control setting discards messages from MX 266# servers to prevent this script from contributing to spam "blowback", 267# which occurs when a spammer forges someone's real email address as 268# the return address on spam, and then that person has to deal with 269# tons of bounce messages from sites that reject the spam. 270my(@discard_control) = 271 ( 272 ["mx" => "discard"], 273 ["*" => "reject"], 274 ); 275 276# You can configure how long addresses will stay in the cache of 277# addresses that have been been expanded against the virtual user 278# table (if $sendmail_canon is set above), then expanded against the 279# aliases file (if $aliases_file is set above), then checked to see if 280# they represent users who are doing filtering. You would want cache 281# entries to time out if you get a lot of spam dictionary attacks 282# against your mail server, when the spammers try tons of invalid 283# addresses on the off chance that one of them might be valid, because 284# in that case your cache will grow without bound and the bogofilter 285# milter process will get really large. Set this to 0 to disable 286# cache expiration, or to the number of seconds after which cache 287# entries should expire. 288# 289# Configuration changes in the user's bogofilter directory, e.g., 290# changes to $subject_filter_file, aren't detected until the cache 291# entry for the user expires, so if you're allowing users to make 292# changes like that, you should probably reduce this timeout to 293# something smaller so that their changes will take affect somewhat 294# promptly. 295my $recipient_cache_expire = 24 * 60 * 60; # one day 296# How often to expire entries from the cache. 297my $recipient_cache_check_interval = 60 * 60; # one hour 298 299# You may wish to remove this restriction, by setting this variable to 300# 0, if your site gets a lot of mail, but I haven't tested the script 301# to make sure it functions correctly with multiple interpreters. 302my $milter_interpreters = 1; 303 304# END CONFIGURABLE SETTINGS 305 306require 5.008_000; # for User::pwent 307 308use strict; 309use warnings; 310use DB_File; 311use Data::Dumper; 312use English '-no_match_vars'; 313use Fcntl qw(:flock :seek); 314use File::Basename; 315use File::Temp qw(tempfile); 316use Getopt::Long; 317use IO::Scalar; 318use IPC::Open2; 319use Mail::Alias; 320use Net::CIDR; 321use Net::DNS; 322use POSIX; 323use Proc::Daemon; 324use Sendmail::Milter; 325use Socket; 326use Sys::Syslog qw(:DEFAULT :macros setlogsock); 327use User::pwent; 328 329$Data::Dumper::Indent = 0; 330 331# Used to cache the results of alias expansions and checks for 332# filtered recipients. 333my %cached_recipients; 334 335my $whoami = basename $0; 336my $usage = "Usage: $whoami [--daemon] [--debug] [--restart]\n"; 337my($run_as_daemon, $get_help, $debug, $restart); 338 339my %my_milter_callbacks = 340( 341 'helo' => \&my_helo_callback, 342 'envfrom' => \&my_envfrom_callback, 343 'envrcpt' => \&my_rcpt_callback, 344 'header' => \&my_header_callback, 345 'eoh' => \&my_eoh_callback, 346 'body' => \&my_body_callback, 347 'eom' => \&my_eom_callback, 348 'abort' => \&my_abort_callback, 349 'close' => \&my_close_callback, 350 ); 351 352$my_milter_callbacks{'connect'} = \&my_connect_callback 353 if (@ip_whitelist || $ip_whitelist_db || @discard_control); 354 355die $usage if (! GetOptions('daemon' => \$run_as_daemon, 356 'debug' => \$debug, 357 'restart' => \$restart, 358 'help|h|?' => \$get_help)); 359 360if ($get_help) { 361 print $usage; 362 exit; 363} 364 365if ($run_as_daemon) { 366 Proc::Daemon::Init; 367} 368 369if (! (open(PIDFILE, '+<', $pid_file) || 370 open(PIDFILE, '+>', $pid_file))) { 371 &die("open($pid_file): $!\n"); 372} 373 374seek(PIDFILE, 0, SEEK_SET); 375 376if (! flock(PIDFILE, LOCK_EX|LOCK_NB)) { 377 &die("flock($pid_file): $!\n"); 378} 379if (! (print(PIDFILE "$$\n"))) { 380 &die("writing to $pid_file: $!\n"); 381} 382# Flush the PID 383seek(PIDFILE, 0, SEEK_SET); 384 385setlogsock('unix'); 386openlog($whoami, 'pid', $log_facility); 387if (! $debug) { 388 # I'd really like to to this, but it doesn't work with Sys::Syslog 389 # 0.13 in Perl 5.8.8. 390 # setlogmask(&LOG_UPTO(LOG_INFO)); 391 eval " 392 no warnings 'redefine'; 393 sub debuglog { 394 } 395 "; 396} 397 398while ($restart) { 399 my $pid = fork(); 400 if (! defined($pid)) { 401 &die("fork: $!"); 402 } 403 elsif ($pid) { 404 $SIG{'TERM'} = sub { 405 &syslog('info', "got SIGTERM, shutting down"); 406 kill 'TERM', $pid; 407 exit; 408 }; 409 waitpid $pid, 0; 410 my $status = $? >> 8; 411 &syslog('warning', "child process $pid exited (status word $?, exit status $status)"); 412 } 413 else { 414 last; 415 } 416} 417 418my $magic_string_re = $magic_string; 419$magic_string_re =~ s/(\W)/\\$1/g; 420 421# convert whitelist into CIDR notation 422{ 423 my(@whitelist_cidr); 424 425 foreach my $IP (@ip_whitelist) { 426 if (not eval {@whitelist_cidr = 427 Net::CIDR::cidradd($IP, @whitelist_cidr)}) { 428 &die("Error processing whitelist: \"$IP\" is not a valid IP ", 429 "address or range."); 430 } 431 } 432 @ip_whitelist = @whitelist_cidr; 433} 434 435# open popip database for reading 436my %ip_whitelist_db; 437 438&opendb_read if ($ip_whitelist_db); 439 440if ($database_user) { 441 $aliases_file = $sendmail_canon = $sendmail_prog = 442 $recipient_cache_expire = $recipient_cache_check_interval = undef; 443 syslog("info", "Using shared bogofilter database under %s's account", 444 $database_user); 445} 446 447unlink($socket); 448Sendmail::Milter::setconn("local:$socket"); 449Sendmail::Milter::register("bogofilter-milter", 450 \%my_milter_callbacks, SMFI_CURR_ACTS); 451 452Sendmail::Milter::main($milter_interpreters); 453 454&closedb; 455 456sub my_helo_callback { 457 my $ctx = shift; 458 my $helo = shift; 459 460 my $hash = &getpriv($ctx); 461 $hash->{'helo'} = $helo; 462 &setpriv($ctx, $hash); 463 return SMFIS_CONTINUE; 464} 465 466sub my_envfrom_callback { 467 my $ctx = shift; 468 my $envfrom = shift; 469 470 my $hash = &getpriv($ctx); 471 $hash->{'envfrom'} = $envfrom; 472 &setpriv($ctx, $hash); 473 return SMFIS_CONTINUE; 474} 475 476sub my_connect_callback { 477 my $ctx = shift; # milter context object 478 my $hostname = shift; # The connection's host name. 479 my $sockaddr_in = shift; # AF_INET portion of the host address, 480 # from getpeername(2) syscall 481 my $hash = &getpriv($ctx); 482 483 my ($port, $ipaddr) = Socket::unpack_sockaddr_in($sockaddr_in) or 484 &die("Could not unpack socket address: $!"); 485 $ipaddr = Socket::inet_ntoa($ipaddr); # translates into standard IPv4 addr 486 487 $hash->{'remotename'} = $hostname; 488 $hash->{'remoteip'} = $ipaddr; 489 $hash->{'localname'} = $ctx->getsymval('j'); 490 $hash->{'localip'} = $ctx->getsymval('{if_addr}'); 491 492 &debuglog("my_connect_callback: entering with hostname=$hostname, ", 493 "ipaddr=$ipaddr, port=$port"); 494 495 # check if the connecting server is listed in the whitelist 496 if (@ip_whitelist) { 497 if (eval {Net::CIDR::cidrlookup($ipaddr, @ip_whitelist)}) { 498 syslog('info', '%s', "$ipaddr is whitelisted, so this email is " . 499 "being accepted unfiltered."); 500 &setpriv($ctx, undef); 501 return SMFIS_ACCEPT; 502 } 503 else { 504 &debuglog("$ipaddr is not in the whitelist"); 505 } 506 } 507 508 # check if connecting server is listed in the popip database 509 if ($ip_whitelist_db) { 510 if ($ip_whitelist_db{$ipaddr}) { 511 syslog('info', '%s', "$ipaddr is authenticated via poprelayd, " . 512 "so this email is being accepted unfiltered."); 513 &setpriv($ctx, undef); 514 return SMFIS_ACCEPT; 515 } 516 else { 517 &debuglog("$ipaddr is not in the popip database"); 518 } 519 } 520 521 $hash->{'ipaddr'} = $ipaddr; 522 &setpriv($ctx, $hash); 523 &debuglog("my_connect_callback: return CONTINUE with hash"); 524 return SMFIS_CONTINUE; 525} 526 527sub my_rcpt_callback { 528 my $ctx = shift; 529 my $envrcpt = shift; 530 my $hash = &getpriv($ctx); 531 532 &debuglog("my_rcpt_callback: entering with " . Data::Dumper->Dump([&small_hash($hash)], [qw(hash)])); 533 534 if ($hash->{'rcpt'}) { 535 # We've already encountered a recipient who is filtering this message. 536 &setpriv($ctx, $hash); 537 &debuglog("my_rcpt_callback: return CONTINUE with old hash"); 538 return SMFIS_CONTINUE; 539 } 540 my $rcpt = $ctx->getsymval('{rcpt_addr}'); 541 542 &debuglog("my_rcpt_callback: rcpt_addr: $rcpt"); 543 544 if (&filtered_dir($rcpt)) { 545 $hash->{'rcpt'} = $rcpt; 546 $hash->{'envrcpt'} = $envrcpt; 547 &setpriv($ctx, $hash); 548 &debuglog("my_rcpt_callback: return CONTINUE with hash"); 549 return SMFIS_CONTINUE; 550 } 551 else { 552 &setpriv($ctx, undef); 553 &debuglog("my_rcpt_callback: return CONTINUE with undef"); 554 return SMFIS_CONTINUE; 555 } 556} 557 558sub my_header_callback { 559 my($ctx, $field, $value) = @_; 560 my($hash) = &getpriv($ctx); 561 562 &debuglog("my_header_callback: entering with " . Data::Dumper->Dump([&small_hash($hash), $field, $value], [qw(hash field value)])); 563 564 if (! $hash) { 565 &debuglog("my_header_callback: return ACCEPT with no hash"); 566 return SMFIS_ACCEPT; 567 } 568 569 if (lc $field eq 'subject') { 570 if ($value =~ /$magic_string_re/oi) { 571 &setpriv($ctx, undef); 572 &debuglog("my_header_callback: returning ACCEPT for magic subject"); 573 return SMFIS_ACCEPT; 574 } 575 576 if ($hash->{'rcpt'}) { 577 my(@subject_filters) = &user_subject_filters($hash->{'rcpt'}); 578 579 foreach my $filter (@subject_filters) { 580 if ($value =~ /$filter/) { 581 &setpriv($ctx, undef); 582 &debuglog(sprintf("my_header_callback: returning ACCEPT for subject filter %s for recipient %s", 583 $filter, $hash->{'rcpt'})); 584 return SMFIS_ACCEPT; 585 } 586 } 587 } 588 } 589 590 if (lc $field eq 'x-bogosity') { 591 &debuglog("Found $field: $value"); 592 my $index = $hash->{x_bogosity_index} || 1; 593 if ($value =~ /tests=bogofilter/) { 594 unshift(@{$hash->{x_bogosity}}, $index); 595 &debuglog("my_header_callback: stashing $field: $value ", 596 "at index $index"); 597 } 598 $hash->{x_bogosity_index} = $index + 1; 599 } 600 601 $hash = &add_to_message($hash, "$field: $value\n"); 602 603 &setpriv($ctx, $hash); 604 605 &debuglog("my_header_callback: returning CONTINUE with hash"); 606 return SMFIS_CONTINUE; 607} 608 609sub my_eoh_callback { 610 my($ctx) = @_; 611 my($hash) = &getpriv($ctx); 612 613 # If $hash is undefined here, it means that the sender sent no 614 # message header at all, so the block of code in 615 # my_header_callback for checking if $hash is undefined never got 616 # called. This means the message is almost certainly spam, but 617 # it's not our job to determine that if none of the recipients are 618 # using bogofilter. 619 if (! $hash) { 620 &debuglog("my_eoh_callback: return ACCEPT with no hash (message had empty header)"); 621 return SMFIS_ACCEPT; 622 } 623 624 625 &debuglog("my_eoh_callback: entering with " . Data::Dumper->Dump([&small_hash($hash)], [qw(hash)])); 626 627 $hash = &add_to_message($hash, "\n"); 628 629 &setpriv($ctx, $hash); 630 631 &debuglog("my_eoh_callback: returning CONTINUE with hash"); 632 return SMFIS_CONTINUE; 633} 634 635sub my_body_callback { 636 my($ctx, $body, $len) = @_; 637 my($hash) = &getpriv($ctx); 638 639 &debuglog("my_body_callback: entering with " . Data::Dumper->Dump([&small_hash($hash), $len], [qw(hash len)])); 640 641 $hash = &add_to_message($hash, $body); 642 643 &setpriv($ctx, $hash); 644 645 &debuglog("my_body_callback: returning CONTINUE with hash"); 646 return SMFIS_CONTINUE; 647} 648 649sub add_to_message { 650 my($hash, $text) = @_; 651 return $hash if (! $text); 652 653 if (! $hash->{'fh'}) { 654 $hash->{'msg'} = '' if (! $hash->{'msg'}); 655 $hash->{'msg'} .= $text; 656 657 if (length($hash->{'msg'}) <= $MAX_INCORE_MSG_LENGTH) { 658 return $hash; 659 } 660 661 ($hash->{'fh'}, $hash->{'fn'}) = tempfile(); 662 663 if (! $hash->{'fn'}) { 664 &die("error creating temporary file"); 665 } 666 667 &debuglog("switching to temporary file " . $hash->{'fn'}); 668 669 $text = $hash->{'msg'}; 670 delete $hash->{'msg'}; 671 } 672 673 if (! print({$hash->{'fh'} } $text)) { 674 &die("error writing to temporary file " . $hash->{'fn'}); 675 } 676 677 return $hash; 678} 679 680sub message_read_handle { 681 my($hash) = @_; 682 683 if ($hash->{'fn'}) { 684 if (! seek($hash->{'fh'}, 0, SEEK_SET)) { 685 &die("couldn't seek in " . $hash->{'fn'} . ": $!"); 686 } 687 return $hash->{'fh'}; 688 } 689 else { 690 return new IO::Scalar \$hash->{'msg'}; 691 } 692} 693 694 695sub my_eom_callback { 696 my $ctx = shift; 697 my $hash = &getpriv($ctx); 698 my $fh; 699 local($_); 700 701 &debuglog("my_eom_callback: entering with " . Data::Dumper->Dump([&small_hash($hash)], [qw(hash)])); 702 703 my $dir = &filtered_dir($hash->{'rcpt'}); 704 705 if (! $dir) { 706 # This can happen if the MTA loses the input channel from the sender, 707 # so it isn't an error condition. 708 &debuglog("my_eom_callback: called for non-filtered recipient; " . Data::Dumper->Dump([&small_hash($hash)], [qw(hash)])); 709 &setpriv($ctx, undef); 710 &debuglog("my_eom_callback: returning ACCEPT with undef"); 711 return SMFIS_ACCEPT; 712 } 713 714 if (defined($filter_script) and &restrict_permissions($hash->{'rcpt'}) and 715 -x "$dir/$filter_script" and (-o _ or ! (stat(_))[4])) { 716 my $s = "$dir/$filter_script"; 717 718 &unrestrict_permissions; 719 720 syslog('debug', 'filtering with %s', $s); 721 722 my($filter_fh, $filter_fn) = tempfile(); 723 my $stderr_fh = tempfile(); 724 725 if (! $filter_fn) { 726 &die("error creating temporary file"); 727 } 728 $^F = fileno($filter_fh); 729 730 pipe(FROMPARENT, FILTER) or &die("pipe: $!\n"); 731 my $pid = fork; 732 &die("fork: $!\n") if (! defined($pid)); 733 if (! $pid) { 734 close(FILTER); 735 if (! open(STDOUT, ">&", $filter_fh)) { 736 syslog('err', "reopen filter STDOUT to $filter_fn failed: %m"); 737 exit(1); 738 } 739 open(STDERR, ">&", $stderr_fh); 740 if (! open(STDIN, "<&FROMPARENT")) { 741 syslog('err', "reopen filter STDIN from parent failed: %m"); 742 exit(1); 743 } 744 &die("couldn't restrict permissions") if 745 (! &restrict_permissions($hash->{'rcpt'}, 1));; 746 $ENV{'MILTER_REMOTE_IP'} = $hash->{'remoteip'} || ''; 747 $ENV{'MILTER_REMOTE_NAME'} = $hash->{'remotename'} || ''; 748 $ENV{'MILTER_HELOHOST'} = $hash->{'helo'} || ''; 749 $ENV{'MILTER_ENVFROM'} = $hash->{'envfrom'} || ''; 750 $ENV{'MILTER_ENVRCPT'} = $hash->{'envrcpt'} || ''; 751 $ENV{'MILTER_LOCAL_IP'} = $hash->{'localip'} || ''; 752 $ENV{'MILTER_LOCAL_NAME'} = $hash->{'localname'} || ''; 753 754 if (! exec("$s")) { 755 syslog('err', 'exec(%s) failed: %m', $s); 756 exit(1); 757 } 758 } 759 close(FROMPARENT); 760 my $fh = &message_read_handle($hash); 761 my $good_filter = 1; 762 while (<$fh>) { 763 s/\r\n$/\n/; 764 if (! print(FILTER $_)) { 765 syslog('info', 'writing to filter %s: %m', $s); 766 $good_filter = undef; 767 last; 768 } 769 } 770 my @failed; 771 if (! close(FILTER)) { 772 push(@failed, "close(FILTER): $!"); 773 } 774 if (! waitpid($pid, 0)) { 775 push(@failed, "waitpid($pid): $!"); 776 } 777 if ($? >> 8) { 778 push(@failed, "\$?>>8 == " . ($?>>8)); 779 } 780 if (@failed and $good_filter) { 781 syslog('warning', 'filter %s failed: %s', $s, join(", ", @failed)); 782 $good_filter = undef; 783 } 784 if (seek($stderr_fh, 0, SEEK_SET) and -s $stderr_fh) { 785 while (my $error = <$stderr_fh>) { 786 $error =~ s/^\s+//; 787 $error =~ s/\s+$//; 788 syslog('warning', 'stderr output from %s: %s', $s, $error); 789 } 790 close($stderr_fh); 791 } 792 if ($good_filter) { 793 delete $hash->{'msg'}; 794 unlink $hash->{'fn'} if ($hash->{'fn'}); 795 $hash->{'fh'} = $filter_fh; 796 $hash->{'fn'} = $filter_fn; 797 $hash->{'nocr'} = 1; 798 syslog('debug', 'successfully filtered with %s', $s); 799 } 800 else { 801 unlink $filter_fn; 802 close($filter_fh); 803 } 804 } 805 806 if (! pipe(FROMBOGO, TOPARENT)) { 807 &die("pipe: $!\n"); 808 } 809 810 if (! pipe(FROMPARENT, BOGOFILTER)) { 811 &die("pipe: $!\n"); 812 } 813 814 my $pid = fork; 815 if (! defined($pid)) { 816 &die("fork: $!\n"); 817 } 818 elsif (! $pid) { 819 close(FROMBOGO); 820 close(BOGOFILTER); 821 open(STDOUT, ">&TOPARENT") or 822 syslog('warning', "reopen STDOUT to parent failed: $!"); 823 open(STDIN, "<&FROMPARENT"); 824 close(TOPARENT); 825 close(FROMPARENT); 826 &die("couldn't restrict permissions") if 827 (! &restrict_permissions($hash->{'rcpt'}, 1));; 828 my(@cmd) = ('bogofilter', '-v', '-u', '-d', $dir); 829 if ($bogofilter_cf && -f "$dir/$bogofilter_cf") { 830 push(@cmd, '-c', "$dir/$bogofilter_cf"); 831 } 832 exec(@cmd) || &die("exec(bogofilter): $!\n"); 833 # &die had better not return! 834 } 835 836 close(TOPARENT); 837 close(FROMPARENT); 838 $fh = &message_read_handle($hash); 839 if ($hash->{'fn'}) { 840 # This is safe to do on Unix, since on Unix you can unlink an 841 # open file and it'll stay around until the last open file 842 # handle to it goes away. If this script were to be used on 843 # non-Unix operating systems, which is a big "if" that I'm not 844 # sure could ever happen, then this unlink might be a problem 845 # and would need to happen later. 846 unlink $hash->{'fn'}; 847 } 848 849 while (<$fh>) { 850 s/\r\n$/\n/ if (! $hash->{'nocr'}); 851 print(BOGOFILTER $_) || &die("writing to bogofilter: $!\n"); 852 } 853 854 close(BOGOFILTER); 855 my $bogosity_line = <FROMBOGO>; 856 close(FROMBOGO); 857 858 waitpid $pid, 0; 859 my $exit_status = $? >> 8; 860 861 if ($bogosity_line =~ s/^X-Bogosity:\s*//i) { 862 chomp $bogosity_line; 863 } 864 elsif (! $exit_status) { 865 $bogosity_line = "Spam, tests=bogofilter"; 866 } 867 elsif ($exit_status == 1) { 868 $bogosity_line = "Ham, tests=bogofilter"; 869 } 870 elsif ($exit_status == 2) { 871 $bogosity_line = "Unsure, tests=bogofilter"; 872 } 873 874 if ($add_unique_id) { 875 $bogosity_line .= 876 # I wish we could make this a real UUID, but that would 877 # require depending on one of the CPAN UUID modules, and I 878 # don't want to add that dependency just for this feature. 879 ", milter_id=" . sprintf("%lx.%lx.%lx", $$, time(), 880 int(rand(1000000000))); 881 } 882 883 my $from = $ctx->getsymval('{mail_addr}'); 884 if (! $exit_status) { 885 my($training); 886 if ($training_file) { 887 if (&restrict_permissions($hash->{'rcpt'})) { 888 $training = (-f "$dir/$training_file"); 889 &unrestrict_permissions; 890 } 891 else { 892 syslog('warning', 'assuming training mode because ' . 893 'permissions could not be restricted'); 894 $training = 1; 895 } 896 } 897 foreach my $index (@{$hash->{x_bogosity}}) { 898 &debuglog("Removing old X-Bogosity header"); 899 $ctx->chgheader('X-Bogosity', $index, ""); 900 } 901 $ctx->addheader('X-Bogosity', $bogosity_line); 902 my $which = &reject_or_discard($hash); 903 my($verb) = ($which == SMFIS_REJECT) ? "reject" : "discard"; 904 syslog('info', '%s', ($training ? "would $verb" : "${verb}ing") . 905 " likely spam from $from to " . $hash->{'rcpt'} . " based on $dir"); 906 &save_copy($fh, $from, $hash->{'rcpt'}, $dir, $archive_mbox, 907 $bogosity_line, $hash->{'nocr'}); 908 if (! $training) { 909 $ctx->setreply($rcode, $xcode, $reject_message); 910 &setpriv($ctx, undef); 911 return $which; 912 } 913 } 914 else { 915 &save_copy($fh, $from, $hash->{'rcpt'}, $dir, $ham_archive_mbox, 916 $bogosity_line, $hash->{'nocr'}); 917 my $bogosity; 918 if ($exit_status == 1) { 919 $bogosity = "Ham"; 920 } 921 elsif ($exit_status == 2) { 922 $bogosity = "Unsure"; 923 } 924 if ($bogosity_line || $bogosity) { 925 foreach my $index (@{$hash->{x_bogosity}}) { 926 &debuglog("Removing old X-Bogosity header"); 927 $ctx->chgheader('X-Bogosity', $index, ""); 928 } 929 $ctx->addheader('X-Bogosity', $bogosity_line); 930 } 931 } 932 933 &setpriv($ctx, undef); 934 return SMFIS_CONTINUE; 935} 936 937sub save_copy { 938 my($fh, $from, $rcpt, $dir, $archive_mbox, $bogosity, $nocr) = @_; 939 local($_); 940 941 my($archive, $link); 942 943 $archive = ($archive_mbox && 944 &restrict_permissions($rcpt) && 945 (lstat($archive = "$dir/$archive_mbox"))) ? 946 $archive : undef; 947 948 if ($cyrus_deliver && -f $cyrus_deliver && -X $cyrus_deliver && 949 -l $archive && ($link = readlink($archive)) && 950 $link =~ s/^cyrus:// && (! -f $archive)) { 951 &unrestrict_permissions; 952 my $user = &filtered_user($rcpt); 953 if (! $user) { 954 &die("Couldn't determine username for IMAP delivery"); 955 } 956 if (! seek($fh, 0, SEEK_SET)) { 957 &die("error rewinding message handle: $!"); 958 } 959 my $pid = open(DELIVER, "|-"); 960 if (! defined($pid)) { 961 &die("Error forking to execute $cyrus_deliver: $!"); 962 } 963 elsif (! $pid) { 964 exec($cyrus_deliver, '-a', $user, '-m', 965 "user.$user.$link") || 966 &die("exec($cyrus_deliver): $!"); 967 } 968 else { 969 my ($in_header) = 1; 970 my $ret = 1; 971 while ($ret && <$fh>) { 972 s/\r\n/\n/ if (! $nocr); 973 if ($in_header) { 974 next if (/^x-bogosity:.*tests=bogofilter/i); 975 if (/^$/) { 976 if ($bogosity) { 977 $ret = $ret && 978 print(DELIVER "X-Bogosity: $bogosity\n"); 979 } 980 $in_header = 0; 981 } 982 } 983 $ret = $ret && print(DELIVER $_); 984 } 985 $ret = $ret && close(DELIVER); 986 if (! $ret) { 987 syslog('warning', '%s', 988 "$cyrus_deliver failed for user.$user.$link"); 989 } 990 return; 991 } 992 } 993 if ($archive) { 994 # There is an annoying race condition here. Suppose two spam 995 # messages are delivered at the same time to a user whose 996 # archive file is a symlink pointing at a nonexistent (yet) 997 # file. Milter process A tries to open with +< and fails. IN 998 # the meantime, process B also tries to open with +< and fails. 999 # Then A opens witn +>, locks the file and starts writing to 1000 # it, and *then* B opens with +>, thus truncating whatever data 1001 # was written thus far by A. I'm not sure what the best way is 1002 # to fix this race condition reliably, and it seems rare enough 1003 # that it isn't worth the effort. 1004 if (! (open(MBOX, '+<', $archive) || 1005 open(MBOX, '+>', $archive))) { 1006 syslog('warning', '%s', "opening $archive for " . 1007 "write: $!"); 1008 goto no_archive_open; 1009 } 1010 if (! flock(MBOX, LOCK_EX)) { 1011 syslog('warning', '%s', "locking $archive: $!"); 1012 goto close_archive; 1013 } 1014 if (! seek(MBOX, 0, SEEK_END)) { 1015 syslog('warning', '%s', 1016 "seek($archive, 0, SEEK_END): $!"); 1017 goto close_archive; 1018 } 1019 if (! seek($fh, 0, SEEK_SET)) { 1020 &die("error rewinding message handle: $!"); 1021 } 1022 1023 if (! print(MBOX "From " . ($from || 'MAILER-DAEMON') . 1024 " " . localtime() . "\n")) { 1025 syslog('warning', '%s', "write($archive): $!"); 1026 goto close_archive; 1027 } 1028 1029 my($last_blank, $last_nl); 1030 my($in_header) = 1; 1031 while (<$fh>) { 1032 s/\r\n/\n/ if (! $nocr); 1033 $last_nl = ($_ =~ /\n/); 1034 $last_blank = ($_ eq "\n"); 1035 if ($in_header) { 1036 next if (/^x-bogosity:.*tests=bogofilter/i); 1037 if (/^$/) { 1038 if ($bogosity) { 1039 $_ = "X-Bogosity: $bogosity\n" . $_; 1040 } 1041 $in_header = 0; 1042 } 1043 } 1044 else { 1045 s/^From />From /; 1046 } 1047 if (! print(MBOX $_)) { 1048 syslog('warning', '%s', "write($archive): $!"); 1049 goto close_archive; 1050 } 1051 } 1052 1053 # Mbox format requires a blank line at the end 1054 if (! ($last_blank || print(MBOX ($last_nl ? "\n" : "\n\n")))) { 1055 syslog('warning', '%s', "write($archive): $!"); 1056 goto close_archive; 1057 } 1058 1059 close_archive: 1060 if (! close(MBOX)) { 1061 syslog('warning', '%s', "close($archive): $!"); 1062 } 1063 } 1064 no_archive_open: 1065 &unrestrict_permissions; 1066} 1067 1068sub my_abort_callback { 1069 my($ctx) = shift; 1070 my $hash = &getpriv($ctx); 1071 1072 &debuglog("my_abort_callback: entering with " . Data::Dumper->Dump([&small_hash($hash)], [qw(hash)])); 1073 1074 if ($hash->{'fn'}) { 1075 unlink $hash->{'fn'}; 1076 } 1077 1078 &setpriv($ctx, undef); 1079 &debuglog("my_abort_callback: returning CONTINUE with undef"); 1080 return SMFIS_CONTINUE; 1081} 1082 1083sub my_close_callback { 1084 my($ctx) = shift; 1085 my $hash = &getpriv($ctx); 1086 1087 &debuglog("my_close_callback: entering with " . Data::Dumper->Dump([&small_hash($hash)], [qw(hash)])); 1088 1089 if ($hash) { 1090 if ($hash->{'fn'}) { 1091 unlink $hash->{'fn'}; 1092 } 1093 } 1094 1095 &setpriv($ctx, undef); 1096 &debuglog("my_close_callback: returning CONTINUE with undef"); 1097 return SMFIS_CONTINUE; 1098} 1099 1100sub filtered_dir { 1101 my($uid, $gid, $dir) = &expand_recipient($_[0]); 1102 $dir; 1103} 1104 1105sub filtered_user { 1106 my($uid, $gid, $dir, $stamp, $user) = &expand_recipient($_[0]); 1107 $user; 1108} 1109 1110sub user_subject_filters { 1111 my($uid, $gid, $dir, $stamp, $user, $filters) = &expand_recipient($_[0]); 1112 $filters ? @{$filters} : (); 1113} 1114 1115sub restrict_permissions { 1116 my($rcpt) = shift; 1117 my($no_going_back) = shift; 1118 1119 my($uid, $gid, $dir) = &expand_recipient($rcpt); 1120 if (! (defined($uid) && defined($gid))) { 1121 syslog('err', '%s', "internal error: couldn't determine UID and GID " . 1122 "for $rcpt"); 1123 return undef; 1124 } 1125 $EUID = $uid; 1126 $EGID = $gid; 1127 if ($no_going_back) { 1128 # When we're ready to exec an external program, i.e., 1129 # bogofilter, we want to set the real UID and GID so that, 1130 # e.g., bogofilter will look in the correct home directory for 1131 # .bogofilter.cf. 1132 $UID = $uid; 1133 $GID = $gid; 1134 } 1135 1; 1136} 1137 1138sub unrestrict_permissions { 1139 $EUID = $UID; 1140 $EGID = $GID; 1141} 1142 1143my $recipient_cache_last_checked; 1144 1145# $uid, $gid, $dir, $timestamp, $username, \@subject_filters 1146sub expand_recipient { 1147 my($rcpt) = @_; 1148 my($orig, @expanded); 1149 my $now = time; 1150 1151 if ($recipient_cache_expire) { 1152 if (! defined($recipient_cache_last_checked)) { 1153 $recipient_cache_last_checked = $now; 1154 } 1155 if ($now - $recipient_cache_last_checked > 1156 $recipient_cache_check_interval) { 1157 my $old = $now - $recipient_cache_expire; 1158 my(@keys) = keys %cached_recipients; 1159 my(@expired) = grep($cached_recipients{$_}->[3] <= $old, 1160 keys %cached_recipients); 1161 &debuglog('expiring %d entries (out of %d) ' . 1162 'from the recipient cache', 1163 scalar @expired, scalar @keys); 1164 map(delete $cached_recipients{$_}, @expired); 1165 $recipient_cache_last_checked = $now; 1166 } 1167 } 1168 1169 if ($database_user) { 1170 $rcpt = $database_user; 1171 } 1172 1173 if (defined($cached_recipients{$rcpt})) { 1174 return(@{$cached_recipients{$rcpt}}); 1175 } 1176 1177 $rcpt = &sendmail_canon($orig = $rcpt); 1178 1179 if ($rcpt =~ /\@/) { 1180 return(@{$cached_recipients{$orig}} = (undef, undef, undef, $now, undef)); 1181 } 1182 1183 if ($aliases_file) { 1184 my $aliases = Mail::Alias::Sendmail->new($aliases_file); 1185 @expanded = $aliases->expand($rcpt); 1186 } 1187 else { 1188 @expanded = ($rcpt); 1189 } 1190 1191 if ((@expanded == 1) && ($expanded[0] eq $rcpt)) { 1192 my($dir, $pw); 1193 my $stripped = $rcpt; 1194 1195 $stripped =~ s/\+.*//; 1196 $pw = getpwnam($stripped); 1197 @{$cached_recipients{$orig}} = 1198 $pw ? ($pw->uid, $pw->gid, undef, $now, $stripped) : 1199 (undef, undef, undef, $now, undef); 1200 if ($pw && $pw->dir && &restrict_permissions($orig) && 1201 -d ($dir = $pw->dir . "/.bogofilter") && 1202 ! ($bogofilter_cf && $require_cf && ! -f "$dir/$bogofilter_cf")) { 1203 $cached_recipients{$orig}->[2] = $dir; 1204 if ($subject_filter_file) { 1205 my $sff = $dir . "/" . $subject_filter_file; 1206 my @subject_filters; 1207 if (open(SFF, "<", $sff)) { 1208 while (<SFF>) { 1209 s/^\s+//; 1210 s/\s+$//; 1211 next if (/^\#/); 1212 next if (/^$/); 1213 my $re; 1214 eval '$re = qr/$_/;'; 1215 if (! $re) { 1216 syslog("warning", "bad subject filter for %s: %s", 1217 $stripped, $_); 1218 next; 1219 } 1220 push(@subject_filters, $re); 1221 &debuglog(sprintf('subject filter for %s: %s', 1222 $stripped, $_)); 1223 } 1224 } 1225 close(SFF); 1226 if (@subject_filters) { 1227 $cached_recipients{$orig}->[5] = \@subject_filters; 1228 } 1229 } 1230 } 1231 elsif ($database_user) { 1232 syslog("warning", "Shared database user %s is not configured " . 1233 "properly for bogofilter", $database_user); 1234 } 1235 &unrestrict_permissions; 1236 return(@{$cached_recipients{$orig}}); 1237 } 1238 else { 1239 foreach my $addr (@expanded) { 1240 my(@sub); 1241 if (@sub = &expand_recipient($addr)) { 1242 return(@{$cached_recipients{$orig}} = @sub); 1243 } 1244 } 1245 return(@{$cached_recipients{$orig}} = (undef, undef, undef, $now, undef)); 1246 } 1247} 1248 1249sub sendmail_canon { 1250 return $_[0] if (! $sendmail_canon); 1251 1252 my($pid, $sendmail_reader, $sendmail_writer, $last); 1253 local($_); 1254 1255 $pid = open2($sendmail_reader, $sendmail_writer, $sendmail_prog, '-bt') or &die("open2 for sendmail failed"); 1256 print($sendmail_writer "3,0 $_[0]\n"); 1257 close($sendmail_writer); 1258 while (<$sendmail_reader>) { 1259 # CHECKTHIS You should run "sendmail -bt" as root, give it the 1260 # input "3,0 addr" where "addr" is one of the addresses in 1261 # your virtual user table, and confirm that the last 1262 # "returns:" line that it returns matches the regexp here for 1263 # local addresses. 1264 if (/\s+returns: \$\# local \$\:\s+(.+)/) { 1265 $last = $1; 1266 $last =~ s/ \+ .*//; 1267 } 1268 } 1269 close($sendmail_reader); 1270 waitpid $pid, 0; 1271 1272 if ($last) { 1273 return $last; 1274 } 1275 else { 1276 return $_[0]; 1277 } 1278} 1279 1280sub opendb_read { 1281 tie(%ip_whitelist_db, "DB_File", $ip_whitelist_db, O_RDONLY, 0, $DB_HASH) or &die("Can't open $ip_whitelist_db: $!"); 1282} 1283 1284sub closedb { 1285 untie %ip_whitelist_db; 1286} 1287 1288sub die { 1289 my(@msg) = @_; 1290 1291 &closedb; 1292 syslog('err', '%s', "@msg"); 1293 exit(1); 1294} 1295 1296sub debuglog { 1297 syslog('debug', "%s", "DEBUG: " . join("", @_)); 1298} 1299 1300my(%mx_cache); 1301 1302sub reject_or_discard { 1303 my($hash) = @_; 1304 my $hostname; 1305 1306 foreach my $i (0..@discard_control-1) { 1307 my($pattern, $action) = @{$discard_control[$i]}; 1308 my $ret; 1309 if ($action =~ /^reject$/i) { 1310 $ret = SMFIS_REJECT; 1311 } 1312 elsif ($action =~ /^discard$/i) { 1313 $ret = SMFIS_DISCARD; 1314 } 1315 else { 1316 &die("Invalid action $action ", 1317 "for discard control pttern $pattern\n"); 1318 } 1319 if ($pattern =~ /^addr:(.*)$/i) { 1320 my $addr = $1; 1321 &die("Invalid IP address in discard control pattern $pattern\n") 1322 if ($addr !~ /^\d+\.\d+\.\d+\.\d+$/); 1323 if ($hash->{'ipaddr'} eq $addr) { 1324 &debuglog("reject_or_discard: addr match $addr: $action"); 1325 return $ret; 1326 } 1327 } 1328 elsif ($pattern =~ /^netblock:(.*)$/i) { 1329 my $netblock = $1; 1330 &die("Invalid netblock in discard control pattern $pattern\n") 1331 if ($netblock !~ /^\d+\.\d+\.\d+\.\d+\/\d+$/); 1332 if (Net::CIDR::cidrlookup($hash->{'ipaddr'}, $netblock)) { 1333 &debuglog("reject_or_discard: netblock match ", 1334 "$hash->{ipaddr} in $netblock: $action"); 1335 return $ret; 1336 } 1337 } 1338 elsif ($pattern =~ /^host:(.*)$/i) { 1339 my $match_host = lc $1; 1340 $hostname = lc gethostbyaddr(inet_aton($hash->{ipaddr}), AF_INET) 1341 if (! $hostname); 1342 if ($match_host eq $hostname) { 1343 &debuglog("reject_or_discard: ", 1344 "host match $hostname for $hash->{ipaddr}: ", 1345 "$action and cache"); 1346 splice(@discard_control, $i, 0, 1347 [ "addr:$hash->{ipaddr}", $action ]); 1348 return $ret; 1349 } 1350 } 1351 elsif ($pattern =~ /^domain:(.*)$/i) { 1352 my $match_domain = lc $1; 1353 $hostname = lc gethostbyaddr(inet_aton($hash->{ipaddr}), AF_INET) 1354 if (! $hostname); 1355 if ($match_domain eq $hostname or 1356 (substr($hostname, -1-length($match_domain)) eq 1357 ".$match_domain")) { 1358 &debuglog("reject_or_discard: domain match ", 1359 "$hostname for $hash->{ipaddr} in $match_domain: ", 1360 "$action and cache"); 1361 splice(@discard_control, $i, 0, 1362 [ "addr:$hash->{ipaddr}", $action ]); 1363 return $ret; 1364 } 1365 } 1366 elsif ($pattern =~ /^mx$/i) { 1367 my $mx_domain = lc $hash->{'envrcpt'}; 1368 if (! $mx_domain) { 1369 &debuglog("reject_or_discard: no envrcpt\n"); 1370 next; 1371 } 1372 $mx_domain =~ s/.*\@(.*[^\>])\>?/$1/; 1373 my %mx_ips; 1374 if ($mx_cache{$mx_domain} and 1375 # refetch MX records once per hour 1376 time - $mx_cache{$mx_domain}->[0] < 60 * 60) { 1377 %mx_ips = %{$mx_cache{$mx_domain}->[1]}; 1378 } 1379 else { 1380 my %mx_ips; 1381 foreach my $mx (mx($mx_domain)) { 1382 my($name, $aliases, $addrtype, $length, @addrs) = 1383 gethostbyname($mx->exchange); 1384 foreach my $addr (@addrs) { 1385 $mx_ips{inet_ntoa($addr)} = 1; 1386 } 1387 } 1388 $mx_cache{$mx_domain} = [time, \%mx_ips]; 1389 &debuglog("reject_or_discard: cached MX IPs ", 1390 join(" ", sort keys %mx_ips), 1391 " for domain $mx_domain"); 1392 } 1393 if ($mx_ips{$hash->{'ipaddr'}}) { 1394 &debuglog("reject_or_discard: MX addr match ", 1395 "$hash->{ipaddr} for domain $mx_domain: $action"); 1396 return $ret; 1397 } 1398 } 1399 elsif ($pattern eq "*") { 1400 return $ret; 1401 } 1402 else { 1403 &die("Unrecognized discard control pattern: $pattern"); 1404 } 1405 } 1406 1407 return SMFIS_REJECT; 1408} 1409 1410sub getpriv { 1411 my($ctx) = @_; 1412 1413 my $d = $ctx->getpriv(); 1414 my $VAR1; 1415 if ($d) { 1416 eval $d; 1417 } 1418 else { 1419 undef; 1420 } 1421} 1422 1423sub setpriv { 1424 my($ctx, $value) = @_; 1425 1426 if (defined $value) { 1427 my $d = Dumper($value); 1428 $ctx->setpriv($d); 1429 } 1430 else { 1431 $ctx->setpriv(undef); 1432 } 1433} 1434 1435sub small_hash { 1436 my($hash) = @_; 1437 return undef if (! $hash); 1438 my(%hash2) = %{$hash}; 1439 $hash2{'msg'} = "..." if ($hash2{'msg'} and length($hash2{'msg'}) > 100); 1440 \%hash2; 1441} 1442