#!perl
#***********************************************************************
#
# mimedefang-filter
#
# Spamassassin, antivirus, HELO checks, etc, etc, etc
#
# $Id: mimedefang-filter,v 1.217 2011/09/22 14:10:30 jonas Exp $
#
# Copyright (C)
# Roaring Penguin Software Inc and
# The Swedish Association of the Deafblind (FSDB).
#
# Created by Jonas Eckerman, FSDB, jonas@fsdb.org
#
# This program may be distributed under the terms of the GNU General
# Public License, Version 2, or (at your option) any later version.
#
#***********************************************************************
$FilterVersion = '30';
$FilterRevision = '$Revision: 1.217 $';
$FilterDebug = 'lr39';
#***********************************************************************
# Configuration.
#***********************************************************************
# Add setting to config parser
my %cfgcfg = ();
$cfgcfg{'@i'}{i} = 0;
$cfgcfg{'@i'}{c} = 0;
sub add_cfg_cfg {
my ($c,$v,$d,$t,$f) = @_;
$d = '' unless (defined($d));
$t = 's' unless ($t);
$f = '' unless ($f);
$c =~ s/[-_]+//g;
$c = lc($c);
$$v = $d;
$cfgcfg{'@i'}{c} ++;
$cfgcfg{$c}{v} = $v;
$cfgcfg{$c}{t} = lc($t);
$cfgcfg{$c}{f} = lc($f);
$cfgcfg{$c}{i} = $cfgcfg{'@i'}{c};
$cfgcfg{$c}{x} = 0;
}
# md: $AdminAddress
use vars qw($AdminContactAddress $MyFilterHostName $MyFilterHostNames $OurDomains $MyFilterHostAddress $MyFilterHostCountry);
use vars qw($NoUserDomains $PassAbuse);
use vars qw($LocalNets $WhiteNets $OurNets $CanAuthenticate $WantsReports $WantsExtraHeaders);
add_cfg_cfg('AdminAddress',\$AdminAddress,'postmaster','a');
add_cfg_cfg('AdminContactAddress',\$AdminContactAddress,'','a','AdminAddress');
add_cfg_cfg('AdminName',\$AdminName,'postmaster','s');
add_cfg_cfg('MyFilterHostName',\$MyFilterHostName,'host.domain.tld','s');
add_cfg_cfg('MyFilterHostNames',\$MyFilterHostNames,'','l','myfilterhostname');
add_cfg_cfg('OurDomains',\$OurDomains,'','l','myfilterhostnames');
add_cfg_cfg('NoUserDomains',\$NoUserDomains,'','l');
add_cfg_cfg('NoCheckUserDomains',\$NoCheckUserDomains,'','l');
add_cfg_cfg('NoCheckUserServers',\$NoCheckUserServers,'','l');
add_cfg_cfg('LocalNets',\$LocalNets,'10\.0\.\d{1,3}\.\d{1,3}','l');
add_cfg_cfg('WhiteNets',\$WhiteNets,'10.0.0.0/255.255.0.0','mn');
add_cfg_cfg('OurNets',\$OurNets,'','mn');
add_cfg_cfg('CanAuthenticate',\$CanAuthenticate,0,'b');
add_cfg_cfg('WantsReports',\$WantsReports,'','l');
add_cfg_cfg('WantsExtraHeaders',\$WantsExtraHeaders,'','l');
add_cfg_cfg('PassAbuse',\$PassAbuse,0,'b');
use vars qw($NoCheckUserDomains $NoCheckUserServers $CheckUserErrorContinue);
add_cfg_cfg('NoCheckUserDomains',\$NoCheckUserDomains,'','l');
add_cfg_cfg('NoCheckUserServers',\$NoCheckUserServers,'','l');
add_cfg_cfg('CheckUserErrorContinue',\$CheckUserErrorContinue,0,'b');
use vars qw($SRSDomain $SRSSecret $SRSCopyBounce $GSNDExpire $SRSDSNCaptureNet $SRSDSNCaptureHost $SRSDSNCaptureRcpt $SRSDSNCaptureSndr $SRSDSNCapture $SRSDSNCaptureFrom $SRSDSNCaptureTo $SRSDSNCaptureSubj);
add_cfg_cfg('SRSDomain',\$SRSDomain,'','s');
add_cfg_cfg('SRSSecret',\$SRSSecret,'','ms');
add_cfg_cfg('SRSCopyBounce',\$SRSCopyBounce,'','s');
add_cfg_cfg('SRSDSNCaptureRelayNet',\$SRSDSNCaptureNet,'','l');
add_cfg_cfg('SRSDSNCaptureRelayHost',\$SRSDSNCaptureHost,'','l');
add_cfg_cfg('SRSDSNCaptureRecipient',\$SRSDSNCaptureRcpt,'','l');
add_cfg_cfg('SRSDSNCaptureSender',\$SRSDSNCaptureSndr,'','l');
add_cfg_cfg('SRSDSNCaptureFrom',\$SRSDSNCaptureFrom,'','l');
add_cfg_cfg('SRSDSNCaptureTo',\$SRSDSNCaptureTo,'','l');
add_cfg_cfg('SRSDSNCaptureSubject',\$SRSDSNCaptureSubj,'','l');
add_cfg_cfg('GSNDMaxReturns',\$GSNDMaxReturns,0,'i');
add_cfg_cfg('GSNDExpire',\$GSNDExpire,30*24*60*60,'i');
use vars qw($sendmailconfdir $sm_domains);
add_cfg_cfg('SendmailConfig',\$sendmailconfdir,'/etc/mail','p');
add_cfg_cfg('SM_Domains',\$sm_domains,'local-host-names;mailertable;virtdomains','mpsm');
use vars qw($StreamBlack);
add_cfg_cfg('StreamBlack',\$StreamBlack,'-','s');
# md: $SALocalTestsOnly
use vars qw($SASizeLimit $SAMaxScanTime $SAPreInit $SAPreCompile $SARemember $SATimeout);
use vars qw($SASuspiciousScore $SASuspiciousBodyScore $SASuspiciousHeadScore);
use vars qw($SAScanOutbound $SAOutboundMaxLoad $SAOutboundMaxSwap);
use vars qw($SAScanLocal $SAPassLocal $SAReportLocal $SAReportLocalScore $SALocalMaxLoad $SALocalMaxSwap);
add_cfg_cfg('SALocalTestsOnly',\$SALocalTestsOnly,0,'b');
add_cfg_cfg('SASizeLimit',\$SASizeLimit,200*1024,'i');
add_cfg_cfg('SAMaxScanTime',\$SAMaxScanTime,25*60,'i');
add_cfg_cfg('SAPreInit',\$SAPreInit,0,'b');
add_cfg_cfg('SAPreCompile',\$SAPreCompile,0,'b');
add_cfg_cfg('SASuspiciousScore',\$SASuspiciousScore,1,'i');
add_cfg_cfg('SASuspiciousBodyScore',\$SASuspiciousBodyScore,0,'i');
add_cfg_cfg('SASuspiciousHeadScore',\$SASuspiciousHeadScore,0,'i');
add_cfg_cfg('SARemember',\$SARemember,0,'i');
add_cfg_cfg('SAScanOutbound',\$SAScanOutbound,1,'b');
add_cfg_cfg('SAScanLocal',\$SAScanLocal,0,'b');
add_cfg_cfg('SAPassLocal',\$SAPassLocal,1,'b');
add_cfg_cfg('SAReportLocal',\$SAReportLocal,1,'b');
add_cfg_cfg('SAReportLocalScore',\$SAReportLocalScore,5,'i');
add_cfg_cfg('SAOutboundMaxLoad',\$SAOutboundMaxLoad,0,'i');
add_cfg_cfg('SAOutboundMaxSwap',\$SAOutboundMaxSwap,0,'i');
add_cfg_cfg('SALocalMaxLoad',\$SALocalMaxLoad,0,'i');
add_cfg_cfg('SALocalMaxSwap',\$SALocalMaxSwap,0,'i');
add_cfg_cfg('SATimeout',\$SATimeout,5*60,i);
use vars qw($BncCollect $BncExpire);
add_cfg_cfg('BncCollect',\$BncCollect,0,'b');
add_cfg_cfg('BncExpire',\$BncExpire,7*24*60*60,'i');
use vars qw($spamdsocket $spamdhost $spamdport);
add_cfg_cfg('SpamdSocket',\$spamdsocket,'','s');
add_cfg_cfg('SpamdHost',\$spamdhost,'','s');
add_cfg_cfg('SpamdPort',\$spamdport,0,'i');
use vars qw($AVMaxScanTime $vircache_local $vircache_external);
add_cfg_cfg('AVMaxScanTime',\$AVMaxScanTime,25*60,'i');
add_cfg_cfg('AVCacheLocal',\$vircache_local,0,'i');
add_cfg_cfg('AVCacheExternal',\$vircache_external,0,'i');
# md: $DaemonAddress
use vars qw($MailResultAddress $MailResultMailer $MailResulAttachOriginal $MailResulAttachDefanged $MailResultVerify);
add_cfg_cfg('DaemonAddress',\$DaemonAddress,'mailer-daemon','a');
add_cfg_cfg('MailResultAddress',\$MailResultAddress,'','a');
add_cfg_cfg('MailResultMailer',\$MailResultMailer,'127.0.0.1:25','s');
add_cfg_cfg('MailResulAttachOriginal',\$MailResulAttachOriginal,1,'b');
add_cfg_cfg('MailResulAttachDefanged',\$MailResulAttachDefanged,1,'b');
add_cfg_cfg('MailResultVerify',\$MailResultVerify,1,'b');
use vars qw($SpamReportSpool $SpamReportAddress $SpamReportFoward $HamReportSpool $HamReportAddress);
add_cfg_cfg('SpamReportSpool',\$SpamReportSpool,'/var/spool/spam-reports','p');
add_cfg_cfg('SpamReportAddress',\$SpamReportAddress,'','a');
add_cfg_cfg('SpamReportForward',\$SpamReportForward,'','ms');
add_cfg_cfg('HamReportSpool',\$HamReportSpool,'/var/spool/spam-reports','p');
add_cfg_cfg('HamReportAddress',\$HamReportAddress,'','a');
use vars qw($SpamTrapSpool $SpamTrapAddresses $SpamTrapReportRelay);
use vars qw($trap_maxload $trap_maxswap $trap_chance $trap_keep $trap_timewindow $trap_maxwindow);
add_cfg_cfg('SpamTrapSpool',\$SpamTrapSpool,'/var/spool/spam-reports','p');
add_cfg_cfg('SpamTrapAddresses',\$SpamTrapAddresses,'','l');
add_cfg_cfg('SpamTrapReportRelay',\$SpamTrapReportRelay,0,'b');
add_cfg_cfg('trap_maxload',\$trap_maxload,0,'i');
add_cfg_cfg('trap_maxswap',\$trap_maxswap,0,'i');
add_cfg_cfg('trap_chance',\$trap_chance,0,'i');
add_cfg_cfg('trap_keep',\$trap_keep,24*60*60,'i');
add_cfg_cfg('trap_timewindow',\$trap_timewindow,60*60,'i');
add_cfg_cfg('trap_maxwindow',\$trap_maxwindow,60,'i');
use vars qw($RelayOptionsDomain);
add_cfg_cfg('RelayOptionsDomain',\$RelayOptionsDomain,'','l');
# md: $AddWarningsInline $GeneralWarning
add_cfg_cfg('AddWarningsInline',\$AddWarningsInline,1,'b');
add_cfg_cfg('GeneralWarning',\$GeneralWarning,'WARNING: This e-mail has been altered by MIMEDefang at %s.','t');
use vars qw($debug_loglevel $where_log $where_log_mt $address_list_log);
add_cfg_cfg('DebugLogLevel',\$debug_loglevel,0,'i');
add_cfg_cfg('WhereLog',\$where_log,0,'b');
add_cfg_cfg('WhereLogTime',\$where_log_mt,0,'i');
add_cfg_cfg('AddressListLog',\$address_list_log,0,'b');
# md: $MaxMIMEParts
use vars qw($mailtoobig);
add_cfg_cfg('MaxMIMEParts',\$MaxMIMEParts,-1,'i');
add_cfg_cfg('mail_too_big',\$mailtoobig,32*1024*1024,'i');
use vars qw($bad_exts $office_exts $bad_css_exts $del_bad_ext);
add_cfg_cfg('RemoveFileBadExtension',\$del_bad_ext,1,'b');
add_cfg_cfg('BadExtensions',\$bad_exts,'(ade|adp|app|asd|asf|asx|bas|bat|chm|cmd|com|cpl|crt|dll|fxp|hlp|hta|hto|ins|isp|jse?|lib|lnk|mde|msc|msi|msp|mst|ocx|pcd|pif|prg|scr|sct|sh|shb|shs|sys|vb|vbe|vbs|vcs|vxd|wmd|wms|wmz|wsc|wsf|wsh|\{[^\}]+\})','l');
add_cfg_cfg('OfficeExtensions',\$office_exts,'(doc|xml|dot|rtf|wps|xls|xlt|csv|xlw|wk4|wk3|wk1|wks|xla|mdb|adp|dbf|ppt|pot|pps|ppa|wmf|emf|mpp|mpt|mpd|pub)','l');
add_cfg_cfg('BadCSSExtensions',\$bad_css_exts,'(java|jscript|js|jar|exe)','l');
use vars qw($SuspiciousHeadDiscard $SuspiciousBodyDiscard $VirusDiscard);
add_cfg_cfg('SuspiciousHeadDiscard',\$SuspiciousHeadDiscard,0,'b');
add_cfg_cfg('SuspiciousBodyDiscard',\$SuspiciousBodyDiscard,0,'b');
add_cfg_cfg('VirusDiscard',\$VirusDiscard,0,'b');
use vars qw($disable_bad_html $dbh_sizelimit $dbh_report $dbh_report_diff $RemoveRedundantHTMLFor);
add_cfg_cfg('DisableBadHTML',\$disable_bad_html,1,'b');
add_cfg_cfg('DBH_SizeLimit',\$dbh_sizelimit,1024*1024,'i');
add_cfg_cfg('DBH_Report',\$dbh_report,1,'b');
add_cfg_cfg('DBH_ReportDiff',\$dbh_report_diff,1,'b');
add_cfg_cfg('RemoveRedundantHTMLFor',\$RemoveRedundantHTMLFor,'','l');
use vars qw($fix_headers $check_received);
add_cfg_cfg('FixHeaders',\$fix_headers,1,'b');
add_cfg_cfg('CheckReceived',\$check_received,0,'b');
use vars qw($smtp_cache_good $smtp_cache_fail $smtp_cache_bad $smtp_cache_good_error);
add_cfg_cfg('smtp_cache_good',\$smtp_cache_good,60*60,'i');
add_cfg_cfg('smtp_cache_fail',\$smtp_cache_fail,10*60,'i');
add_cfg_cfg('smtp_cache_bad',\$smtp_cache_bad,60,'i');
add_cfg_cfg('smtp_cache_good_error',\$smtp_cache_good_error,6*60*60,'i');
use vars qw($expn_cache $expnservers $expn_local $expn_cache_error);
add_cfg_cfg('expn_servers',\$expnservers,'','l');
add_cfg_cfg('expn_cache',\$expn_cache,20*60,'i');
add_cfg_cfg('expn_cache_error',\$expn_cache_error,6*60*60,'i');
add_cfg_cfg('expn_localonly',\$expn_local,0,'b');
use vars qw($sc_cache_valid $sc_cache_invalid $sc_cache_unknown $sc_cache_invalid_add $sc_cache_invalid_max);
add_cfg_cfg('sc_cachevalid',\$sc_cache_valid,7*24*60*60,'i');
add_cfg_cfg('sc_cacheinvalid',\$sc_cache_invalid,60*60,'i');
add_cfg_cfg('sc_cacheunknown',\$sc_cache_unknown,7*24*60*60,'i');
add_cfg_cfg('sc_cacheinvalidadd',\$sc_cache_invalid_add,60*60,'i');
add_cfg_cfg('sc_cacheinvalidmax',\$sc_cache_invalid_max,24*60*60,'i');
use vars qw($relaydb $rdb_touch $rdb_stamp_grey $rdb_black_list $rdb_white_list $rdb_min_black $rdb_max_white $rdb_ratio $rdb_sender $rdb_domain $rdb_expire $rdb_virus);
add_cfg_cfg('relaydb',\$relaydb,0,'b');
add_cfg_cfg('rdb_touch',\$rdb_touch,0,'b');
add_cfg_cfg('rdb_stampgrey',\$rdb_stamp_grey,0,'b');
add_cfg_cfg('rdb_blacklist',\$rdb_black_list,12,'i');
add_cfg_cfg('rdb_whitelist',\$rdb_white_list,3,'i');
add_cfg_cfg('rdb_minblack',\$rdb_min_black,100,'i');
add_cfg_cfg('rdb_maxwhite',\$rdb_max_white,0,'i');
add_cfg_cfg('rdb_ratio',\$rdb_ratio,100,'i');
add_cfg_cfg('rdb_sender',\$rdb_sender,0,'b');
add_cfg_cfg('rdb_domain',\$rdb_domain,0,'b');
add_cfg_cfg('rdb_expire',\$rdb_expire,30*24*60*60,'i');
add_cfg_cfg('rdb_virus',\$rdb_virus,0,'b');
use vars qw($spamdb $sdb_expire);
add_cfg_cfg('spamdb',\$spamdb,0,'b');
add_cfg_cfg('sdb_expire',\$sdb_expire,7*24*60*60,'i');
use vars qw($nospamdb $nsdb_black_list $nsdb_white_list $nsdb_sender_count $nsdb_relay_count $nsdb_domain_count $nsdb_expire $nsdb_remember_spam);
add_cfg_cfg('nospamdb',\$nospamdb,0,'b');
add_cfg_cfg('nsdb_blacklist',\$nsdb_black_list,5,'i');
add_cfg_cfg('nsdb_whitelist',\$nsdb_white_list,0,'i');
add_cfg_cfg('nsdb_sendercount',\$nsdb_sender_count,1000,'i');
add_cfg_cfg('nsdb_relaycount',\$nsdb_relay_count,0,'i');
add_cfg_cfg('nsdb_domaincount',\$nsdb_domain_count,0,'i');
add_cfg_cfg('nsdb_expire',\$nsdb_expire,7*24*60*60,'i');
add_cfg_cfg('nsdb_remember_spam',\$nsdb_remember_spam,1,'b');
use vars qw($greylist $gdb_black $gdb_grey $gdb_white $gdb_host_white $gdb_host_black $gdb_reset $gdb_host_reset $gdb_reset_host $gdb_subnet $gdb_from_domain $gdb_from_strip $gdb_to_domain $gdb_to_strip $gdb_log);
add_cfg_cfg('greylist',\$greylist,0,'mbs');
add_cfg_cfg('gdb_black',\$gdb_black,3*60,'i');
add_cfg_cfg('gdb_grey',\$gdb_grey,72*60*60,'i');
add_cfg_cfg('gdb_white',\$gdb_white,36*24*60*60,'i');
add_cfg_cfg('gdb_hostwhite',\$gdb_host_white,7*24*60*60,'i');
add_cfg_cfg('gdb_hostblack',\$gdb_host_black,30,'i');
add_cfg_cfg('gdb_reset',\$gdb_reset,20,'i');
add_cfg_cfg('gdb_hostreset',\$gdb_host_reset,5,'i');
add_cfg_cfg('gdb_resethost',\$gdb_reset_host,0,'b');
add_cfg_cfg('gdb_subnet',\$gdb_subnet,1,'b');
add_cfg_cfg('gdb_fromdomain',\$gdb_from_domain,0,'b');
add_cfg_cfg('gdb_fromstrip',\$gdb_from_strip,1,'b');
add_cfg_cfg('gdb_todomain',\$gdb_to_domain,0,'b');
add_cfg_cfg('gdb_tostrip',\$gdb_to_strip,1,'b');
add_cfg_cfg('gdb_log',\$gdb_log,1,'b');
use vars qw($sentoutdb $out_expire);
add_cfg_cfg('sentoutdb',\$sentoutdb,0,b);
add_cfg_cfg('out_expire',\$out_expire,30*24*60*60,'i');
use vars qw($sc_cache_valid $sc_cache_invalid $sc_cache_unknown $sc_cache_invalid_add $sc_cache_invalid_max);
add_cfg_cfg('sc_cachevalid',\$sc_cache_valid,7*24*60*60,'i');
add_cfg_cfg('sc_cacheinvalid',\$sc_cache_invalid,60*60,'i');
add_cfg_cfg('sc_cacheunknown',\$sc_cache_unknown,7*24*60*60,'i');
add_cfg_cfg('sc_cacheinvalidadd',\$sc_cache_invalid_add,60*60,'i');
add_cfg_cfg('sc_cacheinvalidmax',\$sc_cache_invalid_max,24*60*60,'i');
use vars qw($mxcheck $mx_tempfail $mx_cache_valid $mx_cache_invalid);
add_cfg_cfg('mxcheck',\$mxcheck,0,'b');
add_cfg_cfg('mx_tempfail',\$mx_tempfail,1,'b');
add_cfg_cfg('mx_cache_valid',\$mx_cache_valid,7*24*60*60,'i');
add_cfg_cfg('mx_cache_invalid',\$mx_cache_invalid,60,'i');
use vars qw($authfailwarning $dkcheck $dkimcheck $spfcheck $AuthPassNets $smimecheck);
add_cfg_cfg('authfailwarning',\$authfailwarning,1,'b');
add_cfg_cfg('dkcheck',\$dkcheck,0,'b');
add_cfg_cfg('dkimcheck',\$dkimcheck,0,'b');
add_cfg_cfg('spfcheck',\$spfcheck,0,'b');
add_cfg_cfg('smimecheck',\$smimecheck,0,'b');
add_cfg_cfg('authpassnets',\$AuthPassNets,'','mn');
use vars qw($pgpcheck $pgp_expire $pgp_expire_bad $pgp_keyserver);
add_cfg_cfg('pgpcheck',\$pgpcheck,0,'b');
add_cfg_cfg('pgp_expire',\$pgp_expire,14*24*60*60,'i');
add_cfg_cfg('pgp_expire_bad',\$pgp_expire_bad,1*24*60*60,'i');
add_cfg_cfg('pgp_keyserver',\$pgp_keyserver,'wwwkeys.pgp.net','s');
use vars qw($hashcash $hc_maxrecipients $hc_worktime $hc_maxtime $hc_size $hc_maxload $hc_maxswap);
add_cfg_cfg('hashcash',\$hashcash,0,'b');
add_cfg_cfg('hc_maxrecipients',\$hc_maxrecipients,20,'i');
add_cfg_cfg('hc_worktime',\$hc_worktime,10,'i');
add_cfg_cfg('hc_maxtime',\$hc_maxtime,240,'i');
add_cfg_cfg('hc_size',\$hc_size,0,'i');
add_cfg_cfg('hc_maxload',\$hc_maxload,0,'i');
add_cfg_cfg('hc_maxswap',\$hc_maxswap,0,'i');
use vars qw($dc_keep $dc_grey_new $dc_unknown_user $dc_invalid_mx $dc_time_window $dc_per_time_window $dc_limit $dc_bad_helo $dc_black_host $dc_virus $dc_abuse $dc_trap $dc_limit_time);
add_cfg_cfg('dc_keep',\$dc_keep,5*60,'i');
add_cfg_cfg('dc_grey_new',\$dc_grey_new,0,'b');
add_cfg_cfg('dc_unknown_user',\$dc_unknown_user,0,'b');
add_cfg_cfg('dc_invalid_mx',\$dc_invalid_mx,0,'b');
add_cfg_cfg('dc_bad_helo',\$dc_bad_helo,0,'b');
add_cfg_cfg('dc_time_window',\$dc_time_window,3*60,'i');
add_cfg_cfg('dc_limit',\$dc_limit,10,'i');
add_cfg_cfg('dc_per_time_window',\$dc_per_time_window,3*60,'i');
add_cfg_cfg('dc_limit_per_time',\$dc_limit_time,100,'f');
add_cfg_cfg('dc_black_host',\$dc_black_host,0,'b');
add_cfg_cfg('dc_virus',\$dc_virus,0,'b');
add_cfg_cfg('dc_abuse',\$dc_abuse,0,'b');
add_cfg_cfg('dc_trap',\$dc_trap,1,'b');
use vars qw($hilo_keep $hilo_entries $hilo_margin);
add_cfg_cfg('hilo_keep',\$hilo_keep,366*24*60*60,'i');
add_cfg_cfg('hilo_entries',\$hilo_entries,0,'i');
add_cfg_cfg('hilo_margin',\$hilo_margin,0,'i');
use vars qw($attachments_path $attachments_meta $attachments_url);
use vars qw($attachments_max_size $attachments_max_mail_size $attachments_min_size $attachments_hard_limit $attachments_hard_mail_limit);
use vars qw($attachments_domain $attachments_recipients);
add_cfg_cfg('attachments_path',\$attachments_path,'','p');
add_cfg_cfg('attachments_meta',\$attachments_meta,'.meta','s');
add_cfg_cfg('attachments_url',\$attachments_url,'','s');
add_cfg_cfg('attachments_max_size',\$attachments_max_size,10*1024*1024,'i');
add_cfg_cfg('attachments_max_mail_size',\$attachments_max_mail_size,-1,'i');
add_cfg_cfg('attachments_min_size',\$attachments_min_size,512*1024,'i');
add_cfg_cfg('attachments_domain',\$attachments_domain,'','s');
add_cfg_cfg('attachments_recipients',\$attachments_recipients,'','l');
add_cfg_cfg('attachments_hard_limit',\$attachments_hard_limit,0,'i');
add_cfg_cfg('attachments_hard_mail_limit',\$attachments_hard_mail_limit,-1,'i');
use vars qw($silly_fortunes $silly_oneliners $silly_exclaim);
add_cfg_cfg('silly_fortunes',\$silly_fortunes,'');
add_cfg_cfg('silly_oneliners',\$silly_oneliners,'');
add_cfg_cfg('silly_exclaim',\$silly_exclaim,'');
use vars qw($database_spec $database_user $database_pass);
add_cfg_cfg('database_spec',\$database_spec,'dbi:SQLite:dbname=%s/filterdata.db','p');
add_cfg_cfg('database_user',\$database_user,'','s');
add_cfg_cfg('database_pass',\$database_pass,'','s');
use vars qw($ts_keep);
add_cfg_cfg('ts_keep',\$ts_keep,24*60*60,'i');
use vars qw($block_relay $block_sender);
add_cfg_cfg('block_relay',\$block_relay,0,'mbs');
add_cfg_cfg('block_sender',\$block_sender,0,'mbs');
#***********************************************************************
# Code.
#***********************************************************************
# Note: Lot's of modules are loaded dynamically.
# Search for "load_modules" to find them.
use DBI;
use Text::CSV_XS;
use String::Escape;
$logcsv = Text::CSV_XS->new({sep_char=>',',quote_char=>"'",binary=>1});
$logssv = Text::CSV_XS->new({sep_char=>';',quote_char=>'"',binary=>1});
# :-/
use MIME::Decoder;
MIME::Decoder::install('MIME::Decoder::NBit','us-ascii');
$Features{"SpamAssassin"} = 0; # Reload dynamically later.
$Features{"HTMLCleaner"} = 0; # Reload dynamically later.
$Features{"HTML::Parser"} = 0; # Reload dynamically later.
$Features{"HTML::TokeParser"} = 0; # Reload dynamically later.
$Features{"Net::DNS"} = 0; # Reload dynamically later.
$Features{"File::Scan"} = 0; # Never use this.
# Some initialization
{
if ($FilterRevision =~ /^\$\S+:?\s?(\d+)(\.\S*)?\s?\$$/) {
$FilterVersion += $1;
$FilterVersion .= $2;
}
if ($FilterDebug =~ /^\.?(.+)$/) {
$FilterVersion .= ".$1";
}
}
md_syslog('info',"Filter $FilterVersion loaded");
$sqldb = undef;
$sqldbd = '?';
#md_log_enable('mail');
#md_graphdefang_log_enable('mail', 1);
$Stupidity{"flatten"} = 0;
$Stupidity{"NoMultipleInlines"} = 0;
%storingservers = ();
detect_and_load_perl_modules();
read_cfg_cfg();
read_sendmail_config_stuff();
read_antivirus_feature_config();
$Features{"File::Scan"} = 0; # Never use this.
$is_result_query = 0;
$is_xam_report = 0;
$MailResultAddress = lc($MailResultAddress) if ($MailResultAddress);
$SpamReportAddress = lc($SpamReportAddress) if ($SpamReportAddress);
$HamReportAddress = lc($HamReportAddress) if ($HamReportAddress);
$MailResultMailer = '127.0.0.1' unless ($MailResultMailer);
$SpamReportSpool = '/var/spool/spam-reports' unless ($SpamReportSpool);
$HamReportSpool = '/var/spool/spam-reports' unless ($HamReportSpool);
$RelayOptionsDomain =~ s/\./\\./g;
$hc_maxrecipients = 20 unless ($hc_maxrecipients);
$hc_worktime = 10 unless ($hc_worktime);
$attachments_max_mail_size = $attachments_max_size + 4*1024 if ($attachments_max_mail_size<0 && $attachments_max_size>0);
$attachments_max_mail_size = 0 if ($attachments_max_mail_size<0);
$attachments_hard_mail_limit = $attachments_hard_limit + 4*1024 if ($attachments_hard_mail_limit<0 && $attachments_hard_limit>0);
$attachments_hard_mail_limit = 0 if ($attachments_hard_mail_limit<0);
$attachments_min_size = 0 if ($attachments_max_size>0 && $attachments_min_size > $attachments_max_size);
$MyFilterHostAddress = get_hostip($MyFilterHostName) unless ($MyFilterHostAddress);
$MyFilterHostCountry = get_ip_country($MyFilterHostAddress) unless ($MyFilterHostCountry);
#debug_log(0,'%s %s %s',$MyFilterHostName,$MyFilterHostAddress,$MyFilterHostCountry);
#debug_log(0,'My location: %s',get_ip_location($MyFilterHostAddress));
#$pgpcheck = 0; # Just testing?
my %modhead;
my %warnhead;
$lastwhere = 0;
$herewhere = 0;
$wherelast = '';
$hirestime = 0;
cfg_log();
%SLVars = ();
sub xIDs {
my ($id,$d) = @_;
return $id if ($id && $id ne 'NOQUEUE');
return $d if ($d);
return '';
}
# Maybe log to syslog
sub debug_log {
my $level = shift;
return if ($level>$debug_loglevel);
my $msg = shift;
my $mid = xIDs($SLVars{QI},'-');
my $ll = 'info';
$ll = 'err' if ($level < 0);
my $ls = sprintf("MDFDBG: %s $msg",$mid,@_);
$ls =~ s/[\s\r\n]+$//;
md_syslog($ll,$ls);
}
sub finish_log {
my ($fll,$where,$what) = @_;
return if ($fll>$debug_loglevel);
#debug_log($fll,'??? %s',$what);
my %nnl = ();
if (opendir(D,'.')) {
my @fl = ();
my @dl = ();
while (my $f = readdir(D)) {
next if ($f =~ /^\.\.?$/);
if (-d $f) {
push @dl, sprintf('%10s %s','',$f) if ($what =~ /D/i);
} else {
push @fl, sprintf('%10u %s',(stat(_))[7],$f) if ($what =~ /D/i);
$nnl{$f} = (stat(_))[7] if ((stat(_))[7]);
}
}
closedir(D);
foreach my $f (@dl) {
debug_log($fll,'finish %s d %s',$where,$f);
}
foreach my $f (@fl) {
debug_log($fll,'finish %s f %s',$where,$f);
}
}
foreach my $fn (('COMMANDS','RESULTS')) {
my $fns = substr($fn,0,1);
#debug_log($fll,'??? %s %s',$fns,$fn);
next unless ($what =~ /$fns/i);
next unless ($nnl{$fn});
if ($fn eq 'RESULTS' && load_modules('IO::Handle')) {
IO::Handle::flush(RESULTS);
}
next unless (open(F,'<',$fn));
my @rl = <F>;
close(F);
next unless (@rl);
foreach my $l (@rl) {
$l =~ s/[\r\n]+//gs;
debug_log($fll,'finish %s %s %s',$where,$fns,$l) unless ($l eq '');
}
}
}
sub xyz_log {
my $frc = shift;
my $def = shift;
debug_log($frc?-1:$def,@_);
}
sub where_log_i {
my $frc = shift;
my $msg = shift;
my $n;
my $fs;
if ($hirestime) {
$n = Time::HiRes::time();
$fs = '%7s';
} else {
$n = time();
$fs = '%3s';
}
my $h = '-';
my $e = '-';
my $l = '';
if ($lastwhere) {
$e = $n - $lastwhere;
$h = $n - $herewhere;
if ($hirestime) {
$e = sprintf('%05.3f',$e);
$h = sprintf('%05.3f',$h);
}
$l = "| $wherelast";
}
my $w = sprintf($msg,@_);
xyz_log($where_log,3,"T: $fs $fs %-30s %s",$h,$e,$w,$l) unless (!$frc && $where_log_mt && $e < $where_log_mt);
$lastwhere = $n;
$wherelast = $w
}
sub here_log {
$herewhere = $hirestime ? Time::HiRes::time() : time();
$lastwhere = 0;
$wherelast = '';
where_log_i(0,@_);
}
sub where_log {
where_log_i(0,@_);
}
sub there_log {
where_log_i(1,@_);
}
sub address_list_log {
xyz_log($address_list_log,5,@_);
}
sub escape {
my $l = join('',@_);
$l =~ s/\\/\\\\/gs;
$l =~ s/\n/\\n/gs;
$l =~ s/\r/\\r/gs;
$l =~ s/\t/\\t/gs;
return $l;
}
sub hashcsv {
my $hash = (@_ == 1 && ref($_[0]) eq 'HASH') ? $_[0] : {@_};
my @sl = ();
foreach my $k (sort { lc($a) cmp lc($b) } keys %{$hash}) {
push @sl, sprintf('%s=%s',escape($k),escape($fld->{$k})) if (defined($fld->{$k}) && !ref($fld->{$k}));
}
return '' unless (@sl & $logcsv->combine(@sl));
return $logcsv->string();
}
sub listcsv {
my $list = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? $_[0] : \@_;
my @sl = ();
foreach my $i (@{$list}) {
push @sl, defined($i) ? escape($i) : '';
}
return '' unless (@sl && $logcsv->combine(@sl));
return $logcsv->string();
}
# Log for event analyzing
sub stats_log {
my ($what,@info) = @_;
while (@info < 2) { push @info, ''; }
for (my $i=0;$i<@info;$i++) {
$info[$i] = '' unless (defined($info[$i]));
}
my @lst = ('mdstatl',(defined($what) && !ref($what)) ? $what : '-');
splice @info, 2, 0, {};
if ($what =~ /^(?:reject|stream|deliver|tempfail|discard|trapped)$/i) {
foreach my $k (%SLVars) {
next if ($k eq 'QI');
next if ($k =~ /^_/);
$info[2]->{$k} = $SLVars{$k} if (defined($SLVars{$k}) && $SLVars{$k} ne '');
}
}
foreach my $fld (@info) {
if (ref($fld) eq 'ARRAY') {
push @lst, listcsv($fld);
} elsif (ref($fld) eq 'HASH') {
push @lst, hashcsv($fld);
} elsif (ref($fld) eq 'SCALAR') {
push @lst, escape($$fld);
} elsif (ref($fld) eq '') {
push @lst, escape($fld);
}
}
return unless ($logssv->combine(@lst));
my $mid = xIDs($SLVars{QI},'?');
my $ls = $logssv->string();
md_syslog('info',"$mid: $ls");
shift @lst;
$ls = shift @lst;
return unless ($logssv->combine(@lst));
sql_execute('INSERT INTO logs (logs_stamp,logs_type,logs_cont,logs_mqid,logs_line) VALUES (?,?,?,?,?)',
time(),'stats',$ls,$mid,$logssv->string());
}
# Log for spam rules analyzing
sub spam_log {
my $h = shift;
if ($h ne '-') {
my $r = shift;
my $nl = shift;
unshift @{$nl}, $r;
unshift @{$nl}, $h;
stats_log('spaminfo',$nl,@_);
} else {
stats_log('spaminfo',$h,@_);
}
}
# Maybe log for greylist analyzing
sub greylist_log {
my $e = shift @_;
stats_log('greylist',$e,@_) if (defined($gdb_log) && $gdb_log);
}
sub cfg_log {
my $lvl = shift;
my $w = shift;
$lvl = 1 unless (defined($lvl));
$w = 'cs' unless ($w);
if ($w =~ /c/i) {
foreach my $c (sort { $cfgcfg{$a}{i} <=> $cfgcfg{$b}{i} } keys %cfgcfg) {
next if ($c =~ /^\@/);
debug_log($lvl,'config: %s = %s',$c,${$cfgcfg{$c}{v}});
}
}
if ($w =~ /s/i) {
while (my ($srv,$hst) = each %storingservers) {
debug_log($lvl,'server: %s > %s',$srv,$hst);
}
}
if ($w =~ /f/i) {
foreach my $f (sort keys %Features) {
debug_log($lvl,'feature: %s = %s',$f,$Features{$f});
}
}
}
sub milter_log {
my $lvl = shift;
my $w = shift;
my $p = shift;
$lvl = 1 unless (defined($lvl));
$w = 'c' unless ($w);
$p = '' unless ($p);
$p = " [$p]" if ($p);
if ($w =~ /c/i) {
if (open(CF,'<','COMMANDS')) {
while (my $l = <CF>) {
$l =~ s/[\r\n]+//gs;
debug_log($lvl,'milter command%s: %s',$p,$l);
}
close(CF);
}
}
if ($w =~ /r/i) {
if (open(CF,'<','RESULTS')) {
while (my $l = <CF>) {
$l =~ s/[\r\n]+//gs;
debug_log($lvl,'milter result%s: %s',$p,$l);
}
close(CF);
}
}
if ($w =~ /d/i) {
if (opendir(D,'.')) {
while (my $f = readdir(D)) {
next if ($f =~ /^\.\.?$/);
debug_log($lvl,'milter file%s: %s',$p,$f);
}
closedir(D);
}
}
}
%loaded_modules = ();
sub load_modules{
foreach my $mn (@_) {
my $mnk = $mn;
$mnk =~ s/^\s+//;
$mnk =~ s/[\s\(].*$//;
return 0 if (defined($loaded_modules{$mnk}) && !$loaded_modules{$mnk});
unless (defined($loaded_modules{$mnk}) && $loaded_modules{$mnk}) {
debug_log(1,'load_modules %s (%s)',$mn,$mnk);
eval("use $mn");
if ($@) {
debug_log(-1,'load_modules %s ! %s',$mn,$!);
$loaded_modules{$mnk} = 0;
return 0;
}
$loaded_modules{$mnk} = 1;
}
}
return 1;
}
# Get a file path name
sub get_file_path_name {
my $f = shift;
return $f if ($f =~ /[\/\\]/);
foreach my $d ((sprintf('%s/%s',$Features{'Path:CONFDIR'},'filter'),$Features{'Path:CONFDIR'},
'/usr/local/etc/mimedefang/filter','/etc/mimedefang/filter',
'/usr/local/etc/mimedefang','/etc/mimedefang',
'/usr/local/etc/mail','/etc/mail', )) {
if ($d =~ /mimedefang/) {
return "$d/$f" if (-f "$d/$f");
return "$d/mimedefang-$f" if (-f "$d/mimedefang-$f");
} else {
return "$d/mimedefang-$f" if (-f "$d/mimedefang-$f");
return "$d/$f" if (-f "$d/$f");
}
}
return '';
}
# Read file into array
sub read_a_file {
my ($fn,$match,$noclean) = @_;
my @l = ();
if ($fn && (-f $fn) && (open(CF,'<',$fn))) {
while (my $l = <CF>) {
unless ($noclean) {
next if ($l =~ /^[;#]/);
next if ($l =~ /^[\s\r\n]*$/s);
next if ($match && $l !~ /^$match/i);
}
push @l, $l;
}
close(CF);
}
return \@l;
}
# read the configuration file
sub read_cfg_cfg {
my $cfgfn = get_file_path_name('filter.conf');
die('No filter config!') unless ($cfgfn);
die('Cannot read filter config!') unless (open(F,'<',$cfgfn));
md_syslog('info',"Filter config: $cfgfn");
while (my $l = <F>) {
$l =~ s/[\r\n]+//gs;
next unless ($l);
next if ($l =~ /^\s*[#;]/);
if ($l =~ /^\$(\S+):\s*(.*?)\s*\$?$/) {
md_syslog('info',"Config $1: $2");
} elsif ($l =~ /^\s*(\S+)\s*?[\s:=]\s*(\S.*?)\s*$/) {
my $c = lc($1);
my $v = $2;
$c =~ s/[-_]+//g;
next unless ($c);
next if ($c =~ /^\@/);
if (defined($cfgcfg{$c})) {
if ($cfgcfg{$c}{x} && $cfgcfg{$c}{t} =~ /^m/i) {
${$cfgcfg{$c}{v}} .= ';' if (${$cfgcfg{$c}{v}} ne '');
${$cfgcfg{$c}{v}} .= $v;
} elsif (($cfgcfg{$c}{t} eq 'l' || $cfgcfg{$c}{t} =~ /^m/i) && $v =~ /^\s*\@\{\s*(.*?)\s*\}\s*$/) {
my $lst = read_a_file(get_file_path_name($1,'.*\S'));
if ($cfgcfg{$c}{t} eq 'l') {
${$cfgcfg{$c}{v}} = '';
foreach my $le (@{$lst}) {
$le =~ s/[\r\n]+//gs;
unless ($le =~ /\\[.@]/) {
$le =~ s/\./\\./g;
$le =~ s/\@/\\\@/g;
}
next unless ($le);
${$cfgcfg{$c}{v}} .= '|' if (${$cfgcfg{$c}{v}} ne '');
${$cfgcfg{$c}{v}} .= $le
}
} elsif ($cfgcfg{$c}{t} =~ /^m/i) {
foreach my $le (@{$lst}) {
$le =~ s/[\r\n]+//gs;
${$cfgcfg{$c}{v}} .= ';' if (${$cfgcfg{$c}{v}} ne '');
${$cfgcfg{$c}{v}} .= $le;
}
}
} else {
${$cfgcfg{$c}{v}} = $v;
$cfgcfg{$c}{x} = 1;
}
}
}
}
close(F);
#return;
my @ck = sort { $cfgcfg{$a}{i} <=> $cfgcfg{$b}{i} } keys %cfgcfg;
foreach my $c (@ck) {
next if ($c =~ /^\@/);
${$cfgcfg{$c}{v}} = ${$cfgcfg{$cfgcfg{$c}{f}}{v}} if ($cfgcfg{$c}{f} && !${$cfgcfg{$c}{v}});
}
foreach my $c (@ck) {
next if ($c =~ /^\@/);
if ($cfgcfg{$c}{t} eq 'l') {
${$cfgcfg{$c}{v}} = '' unless (${$cfgcfg{$c}{v}});
${$cfgcfg{$c}{v}} =~ s/\s//g;
unless (${$cfgcfg{$c}{v}} =~ /\\[.@]/) {
${$cfgcfg{$c}{v}} =~ s/\./\\./g;
${$cfgcfg{$c}{v}} =~ s/\@/\\\@/g;
}
${$cfgcfg{$c}{v}} =~ s/,/\|/g if (${$cfgcfg{$c}{v}} !~ /[\(\)\|\{\}]/ && ${$cfgcfg{$c}{v}} =~ /\,/);
${$cfgcfg{$c}{v}} = sprintf('(?:%s)',${$cfgcfg{$c}{v}}) if (${$cfgcfg{$c}{v}} !~ /^\(.*\)$/ && ${$cfgcfg{$c}{v}} =~ /\|/);
} elsif ($cfgcfg{$c}{t} eq 'a') {
${$cfgcfg{$c}{v}} = '' unless (${$cfgcfg{$c}{v}});
next unless (${$cfgcfg{$c}{v}});
${$cfgcfg{$c}{v}} .= '@'.${$cfgcfg{'myfilterhostname'}{v}} if (${$cfgcfg{$c}{v}} =~ /^[^@]+$/);
} elsif ($cfgcfg{$c}{t} eq 't') {
${$cfgcfg{$c}{v}} = '' unless (${$cfgcfg{$c}{v}});
${$cfgcfg{$c}{v}} = sprintf(${$cfgcfg{$c}{v}},${$cfgcfg{'myfilterhostname'}{v}});
${$cfgcfg{$c}{v}} =~ s/[\r\n]*$/\n\n/s;
} elsif ($cfgcfg{$c}{t} eq 'b') {
${$cfgcfg{$c}{v}} = 0 unless (${$cfgcfg{$c}{v}});
${$cfgcfg{$c}{v}} = 0 if (${$cfgcfg{$c}{v}} =~ /^\s*(false|no?|off|0+)\s*$/);
${$cfgcfg{$c}{v}} = 1 if (${$cfgcfg{$c}{v}});
} elsif ($cfgcfg{$c}{t} eq 'i') {
${$cfgcfg{$c}{v}} = 0 unless (${$cfgcfg{$c}{v}});
${$cfgcfg{$c}{v}} = eval(${$cfgcfg{$c}{v}});
} elsif ($cfgcfg{$c}{t} eq 'f') {
${$cfgcfg{$c}{v}} = 0.0 unless (${$cfgcfg{$c}{v}});
${$cfgcfg{$c}{v}} = eval(${$cfgcfg{$c}{v}});
} elsif ($cfgcfg{$c}{t} eq 'ps') {
${$cfgcfg{$c}{v}} = $Features{'Path:SPOOLDIR'} unless (${$cfgcfg{$c}{v}});
${$cfgcfg{$c}{v}} = sprintf('%s/%s',$Features{'Path:SPOOLDIR'},${$cfgcfg{$c}{v}}) if (${$cfgcfg{$c}{v}} !~ /[\/\\]/);
} elsif ($cfgcfg{$c}{t} eq 'pc') {
${$cfgcfg{$c}{v}} = $Features{'Path:CONFDIR'} unless (${$cfgcfg{$c}{v}});
${$cfgcfg{$c}{v}} = sprintf('%s/%s',$Features{'Path:CONFDIR'},${$cfgcfg{$c}{v}}) if (${$cfgcfg{$c}{v}} !~ /[\/\\]/);
} elsif ($cfgcfg{$c}{t} eq 'p') {
${$cfgcfg{$c}{v}} = $Features{'Path:CONFDIR'} unless (${$cfgcfg{$c}{v}});
${$cfgcfg{$c}{v}} = sprintf(${$cfgcfg{$c}{v}},$Features{'Path:SPOOLDIR'},$Features{'Path:CONFDIR'});
} elsif ($cfgcfg{$c}{t} eq 'mpsm') {
my @pil = split(/\s*;\s*/,${$cfgcfg{$c}{v}});
for (my $i=0;$i<@pil;$i++) {
my ($fn,$ft,$fo,$x) = split(/\s*,\s*/,$pil[$i]);
$fn = sprintf('%s/%s',${$cfgcfg{'sendmailconfig'}{v}},$fn) if ($fn !~ /[\/\\]/);
$fo = '?' unless ($fo);
unless ($ft) {
if ($fn =~ /table/i) {
$ft = 'table'
} else {
$ft = 'list';
}
}
$pil[$i] = join(',',$fn,lc($ft),lc($fo));
}
${$cfgcfg{$c}{v}} = join(';',@pil);
} elsif ($cfgcfg{$c}{t} eq 'mbs') {
${$cfgcfg{$c}{v}} = 0 unless (${$cfgcfg{$c}{v}});
${$cfgcfg{$c}{v}} = 0 if (${$cfgcfg{$c}{v}} =~ /^\s*(false|no|n|off|0+)\s*$/);
${$cfgcfg{$c}{v}} = 1 if (${$cfgcfg{$c}{v}} =~ /^\s*(true|yes|y|on|\d*[1-9]\d*)\s*$/);
} else {
${$cfgcfg{$c}{v}} = '' unless (${$cfgcfg{$c}{v}});
}
}
if ($database_spec =~ /sqlite/i) {
$sqldbd = 'L';
} elsif ($database_spec =~ /mysql/i) {
$sqldbd = 'M';
}
}
# Virus check disabling
my %AntiVirusConfig = ();
sub read_antivirus_feature_config {
my $vfn = get_file_path_name('antivirus');
return unless ($vfn);
debug_log(3,'read_antivirus_feature_config %s',$vfn);
if (open(CF,'<',$vfn)) {
#if (open(CF,'<','/etc/mail/mimedefang-antivirus')) {
while (my $l = <CF>) {
$l =~ s/[\r\n]+//gs;
next if ($l =~ /^[;#\@=]/);
#debug_log(0,'read_antivirus_feature_config %s',$l);
if ($l =~ /^\s*(\d+)\s*:\s*(\S+)\s*$/) {
$AntiVirusConfig{$2}{la} = $1;
#debug_log(0,'read_antivirus_feature_config la %s = %s',$2,$1);
} elsif ($l =~ /^\s*(\d+)\s*\%\s*:\s*(\S+)\s*$/) {
$AntiVirusConfig{$2}{sp} = $1;
#debug_log(0,'read_antivirus_feature_config sp %s = %s',$2,$1);
} elsif ($l =~ /^\s*!\s*(\S+)\s*$/) {
$Features{"Virus:$1"} = 0;
debug_log(4,'$Features{Virus:%s} = 0',$1);
} elsif ($l =~ /^\s*(\S+)\s*(.*?)\s*$/) {
$Features{"Virus:$1"} = $2;
debug_log(4,'$Features{Virus:%s} = %s',$1,$2);
}
}
close(CF);
}
foreach my $av (keys %AntiVirusConfig) {
$AntiVirusConfig{$av}{fn} = $Features{"Virus:$av"};
}
}
# Initialize some stuff from the sendmail config
sub read_sendmail_config_stuff {
return unless ($sm_domains);
my $dl = $OurDomains;
$dl =~ s/^\(\?:(.*)\)$/$1/;
$dl =~ s/\\\././g;
foreach my $smd (split(/;/,$sm_domains)) {
my ($smdfn,$smdft,$smdfo,$xxx) = split(/,/,$smd);
next unless ($smdfn);
unless (open(CF,'<',$smdfn)) {
debug_log(-1,'Cannot read sendmail file %s',$smdfn);
die("Cannot read sendmail file $smdfn!") if ($smdfo =~ /\!/);
next;
}
my $mdfignore = 0;
if ($smdft eq 'table') {
while (my $l = <CF>) {
$l =~ s/[\r\n]+//g;
if ($l =~ /^\s*\#\s*mdf-?ignore\s+begin\s*$/i) {
$mdfignore ++;
} elsif ($l =~ /^\s*\#\s*mdf-?ignore\s+end\s*$/i) {
$mdfignore --;
} elsif ($mdfignore < 1) {
next if ($l =~ /^\s*#/);
if ($l =~ /^(\S+)\s+smtp:\[(\S+)\]\s*$/) {
my $d = $1;
my $h = $2;
next if (!$d || !$h);
if ($dl !~ /^(|.*\|)$d(|\|.*)/) {
$dl .= '|' if ($dl);
$dl .= '*' if ($d =~ /^\./);
$dl .= $d;
}
#next if ($h !~ /^10\./);
next if ($h !~ /^$LocalNets$/i);
next if ($NoCheckUserDomains && $d =~ /$NoCheckUserDomains$/i);
next if ($NoCheckUserServers && $d =~ /^$NoCheckUserServers$/i);
$storingservers{lc($d)} = $h;
debug_log(1,"mailertable: $d -> $h");
}
}
}
close(CF);
} elsif ($smdft eq 'list') {
while (my $l = <CF>) {
$l =~ s/[\r\n]+//g;
if ($l =~ /^\s*\#\s*mdf-?ignore\s+begin\s*$/i) {
$mdfignore ++;
} elsif ($l =~ /^\s*\#\s*mdf-?ignore\s+end\s*$/i) {
$mdfignore --;
} elsif ($mdfignore < 1) {
next if ($l =~ /^\s*#/);
$l =~ s/\s+$//;
next if (!$l || $l =~ /\s/);
if ($dl !~ /^(|.*\|)$l(|\|.*)/) {
$dl .= '|' if ($dl);
$dl .= $l;
}
}
}
close(CF);
} else {
debug_log(-1,'Unknown file type %s (%s)',$smdft,$smdfn);
die("Unknown file type $smdft ($smdfn)") if ($smdfo =~ /\!/);
close(CF);
}
}
$dl =~ s/(\.)/\\$1/g;
$dl =~ s/\*/.*/g;
$dl =~ s/\?/./g;
debug_log(1,"domains: ($dl)");
$OurDomains = "($dl)";
}
# create file
sub create_file {
my ($fn) = @_;
return 1 if (-f $fn);
return 0 unless (open(NF,'>>',$fn));
close(NF);
return 1;
}
# Get 1 minute load average
sub get_load_average {
return undef unless (load_modules('Sys::Load'));
#debug_log(0,'get_load_average');
my @la = Sys::Load::getload();
#debug_log(0,'get_load_average %s',join(' ',@la));
return undef unless (@la && $#la == 2);
return $la[0];
}
# Get swap uasge percentage of real mem
sub get_swap_percentage {
return undef unless (load_modules('Sys::MemInfo'));
#debug_log(0,'get_swap_percentage');
my $us;
eval {
my $ts = Sys::MemInfo::totalswap();
my $fs = Sys::MemInfo::freeswap();
$us = ($ts-$fs) if (defined($ts) && defined($fs));
};
return undef unless (defined($us));
#debug_log(0,'get_swap_percentage us %i',$us);
return 0 unless ($us>0);
my $tm;
eval { $tm = Sys::MemInfo::totalmem(); };
return undef unless (defined($tm));
#debug_log(0,'get_swap_percentage tm %i',$tm);
return undef unless ($tm>0);
#debug_log(0,'get_swap_percentage %f',$us/$tm);
return ($us/$tm)*100;
}
# Strip strings
sub address_strip_nc($) {
my ($a) = @_;
$a = '' unless (defined($a));
$a =~ s/[\r\n]+//gs;
$a =~ s/^[<\[]//;
$a =~ s/[>\]]$//;
#$a =~ s/^(.*\@)?\s*(\S+)(\s.*)?$/$1$2/;
return $a;
}
sub address_strip($) {
my ($a) = @_;
return lc(address_strip_nc($a));
}
sub address_strip_p($) {
my ($a) = @_;
$a = '' unless (defined($a));
$a =~ s/^<(.*?)>$/$1/;
return $a;
}
sub address_strip_opt($) {
my $a = address_strip(shift);
$a =~ s/^(.+)[-+=][^\@]+(\@[^\@]+)$/$1$2/;
return $a;
}
sub address_split_nc($) {
my $a = address_strip_nc(shift);
my $usr = '';
my $dom = '';
if ($a =~ /^\s*(\S*)\@(\S+?)\s*$/) {
$usr = $1;
$dom = $2;
} else {
$usr = $a;
$usr =~ s/^\s+//;
$usr =~ s/\s+$//;
}
my $inf = '';
my $pinf = '';
if ($usr =~ /^(.*)\+(.*)$/) {
$inf = $2;
$usr = $1;
$pinf = "+$inf";
}
return ($usr,$dom,$inf,$pinf);
}
sub address_split($) {
my ($usr,$dom,$inf,$pinf) = address_split_nc(shift);
return (lc($usr),lc($dom),$inf,$pinf);
}
# is $a a sub domain of $b?
sub is_sub_domain($$) {
my $a = address_strip(shift);
my $b = address_strip(shift);
$a =~ s/^.*\@//;
$b =~ s/^.*\@//;
$b =~ s/\./\\./g;
return 0 unless ($a && $b);
return 1 if ($a =~ /^(|.*\.)$b$/);
return 0;
}
sub is_sub_domains {
my ($al,$bl) = @_;
return 0 unless ($al && @{$al} && $bl && @{$bl});
foreach my $a (@{$al}) {
my $ok = 0;
foreach my $b (@{$bl}) {
if (is_sub_domain($a,$b)) {
$ok = 1;
last;
}
}
return 0 unless ($ok);
}
return 1;
}
# address in expression?
sub address_match {
my $regex = shift;
return 0 unless ($regex);
for (my $i=0;$i<@_;$i++) {
return $i+1 if ($_[$i] =~ /^<?$regex>?$/i);
}
return 0;
}
# return a time string...
sub time_string {
my ($time,$ss) = @_;
my $h = int($time / (60*60));
$time = $time % (60*60);
my $m = int($time / 60);
my $s = $time % 60;
my $r = "";
if ($ss) {
return sprintf('%u:%02u:%02u',$h,$m,$s) if ($h);
return sprintf('%u:%02u',$m,$s) if ($m);
return "$s";
}
if ($h) {
$r .= "$h hour";
$r .= 's' if ($h != 1);
}
if ($m || $h) {
if ($h && !$s) {
$r .= ' and ';
} elsif ($h) {
$r .= ', ';
}
$r .= "$m minute";
$r .= 's' if ($m != 1);
}
if ($s) {
$r .= ' and ' if ($h || $m);
$r .= "$s second";
$r .= 's' if ($s != 1);
}
return $r;
}
sub hashstring {
my ($hash,$r) = @_;
my @str = ();
if ($hash) {
foreach my $key (sort { lc($a) cmp lc($b) } keys %{$hash}) {
my $val = $hash->{$key};
next unless (defined($val));
while (ref($val) eq 'SCALAR') {
$val = $$val;
}
if (ref($val) eq 'ARRAY') {
if ($r) {
$val = '['.join(',',@{$val}).']';
} else {
my @val = ();
foreach my $itm (@{$val}) {
if (ref($itm) eq 'HASH') {
push @val, hashstring($itm,1);
} else {
push @val, $itm;
}
}
$val = '['.join(',',@val).']';
}
$val = '[...]' if (length($val)>32);
} elsif (ref($val) eq 'HASH') {
if ($r) {
$val = '{...}';
} else {
$val = '{'.hashstring($val,1).'}';
$val = '{...}' if (length($val)>32);
}
} elsif (ref($val) && $val =~ /^(\S+)=/) {
$val = "<$1>";
} elsif (ref($val)) {
$val = '<'.ref($val).'>';
} else {
$val = '' unless (defined($val));
$val = '(...)' if (length($val)>128);
}
$val =~ s/[\s\r\n]+/ /s;
push @str, $r ? "$key:$val" : "$key=$val" unless ($val eq '');
}
}
return join($r ? ',' : '; ',@str);
}
# This procedure returns true for entities with bad filenames.
sub check_bad_filename($) {
my($entity) = @_;
return 0 unless ($del_bad_ext);
my $re = '\.' . $bad_exts . '\.*([^-A-Za-z0-9_.,;]|$)';
return re_match($entity,$re);
}
$filetype = undef;
sub check_file_type {
my ($f) = @_;
unless ($filetype) {
return '' unless (load_modules('File::Type'));
$filetype = File::Type->new();
return '' unless ($filetype);
}
return $filetype->checktype_filename($f);
}
my $geoip = undef;
sub init_geoip {
return 1 if ($geoip);
return 0 unless (load_modules('Geo::IP'));
$geoip = {};
$geoip->{oc} = Geo::IP->open('/usr/local/share/GeoIP/GeoIPCity.dat',GEOIP_INDEX_CACHE|GEOIP_CHECK_CACHE) if (-e '/usr/local/share/GeoIP/GeoIPCity.dat');
$geoip->{oc} = Geo::IP->open('/usr/local/share/GeoIP/GeoLiteCity.dat',GEOIP_INDEX_CACHE|GEOIP_CHECK_CACHE) if (!$geoip->{city} && (-e '/usr/local/share/GeoIP/GeoLiteCity.dat'));
$geoip->{od} = Geo::IP->new(GEOIP_INDEX_CACHE|GEOIP_CHECK_CACHE);
$geoip->{cn} = {'AF'=>'Africa','AS'=>'Asia','EU'=>'Europe','NA'=>'North America','OC'=>'Oceania','SA'=>'South America'} if ($geoip->{oc});
return 1 if ($geoip->{od} || $geoip->{oc});
return 0;
}
sub get_ip_geo {
my $a = shift;
my $i = shift;
my $o = shift;
unless ($o) {
return '' if (check_black_nets($a));
return '' unless (init_geoip());
}
if ($geoip->{oc}) {
my $ir;
if ($geoip->{rc} && $geoip->{rc}->{w} eq $a) {
#debug_log(0,'get_ip_geo: CC %s',$a);
$ir = $geoip->{rc}->{v};
} else {
$ir = eval('$geoip->{oc}->record_by_addr($a)');
$geoip->{rc}->{w} = $a;
$geoip->{rc}->{v} = $ir;
}
if ($ir) {
my $r = eval(sprintf('$ir->%s',($i eq 'continent_name') ? 'continent_code' : $i));
if ($r) {
if ($i eq 'continent_name') {
debug_log(0,'get_ip_geo: GC %s %s %s',$a,$i,$r);
$r = $geoip->{cn}->{uc($r)} if ($geoip->{cn}->{uc($r)});
}
#debug_log(0,'get_ip_geo: RC %s %s %s',$a,$i,$r);
return $r;
}
}
}
if ($geoip->{od} && $i =~ /^country_(?:name|code3?)$/) {
my $r = eval(sprintf('$geoip->{od}->%s_by_addr($a)',$i));
if ($r) {
#debug_log(0,'get_ip_geo: RD %s %s %s',$a,$i,$r);
return $r;
}
}
return '';
}
sub get_ip_country {
my $a = shift;
return get_ip_geo($a,'country_name',0) unless (@_);
my @r = ();
return @r if (check_black_nets($a));
return @r unless (init_geoip());
my $o = '';
foreach my $c (@_) {
if ($c =~ /^\?/i) {
$o .= $c;
next;
}
my $x;
if (length($c) == 3 || $c =~ /3/) {
$x = get_ip_geo($a,'country_code3',1);
} elsif (length($c) == 2 || $c =~ /2/) {
$x = get_ip_geo($a,'country_code',1);
} else {
$x = get_ip_geo($a,'country_name',1);
}
next unless ($x);
push @r, $x;
$r[$#r] = lc($r[$#r]) if ($o =~ /l/i);
}
return @r;
}
sub get_ip_location {
my $a = shift;
return '' if (check_black_nets($a));
return '' unless (init_geoip());
my @r = ();
my $l;
push @r, $l if ($l = get_ip_geo($a,'city',1));
push @r, $l if ($l = get_ip_geo($a,'region_name',1));
push @r, $l if ($l = get_ip_geo($a,'country_name',1));
push @r, $l if ($l = get_ip_geo($a,'continent_name',1));
return join(', ',@r);
}
sub get_ip_os {
# IP2OS header
my $ip = shift;
$ip = $RelayAddr unless ($ip);
my $ipos = '';
my $iposver = '';
my $iposhead = '';
unless (check_black_nets($ip)) {
if (load_modules('p0fIP2OS')) {
($ipos,$iposver) = ip2osver($ip);
#debug_log(0,'get_ip_os: %s %s',$ipos,$iposver);
$ipos = '' unless ($ipos);
$iposver = '' unless ($iposver);
if ($ipos) {
$iposhead = $ipos;
$iposhead .= " $iposver" if ($iposver);
debug_log(1,"ipos: $iposhead");
}
}
}
return ($ipos,$iposver,$iposhead);
}
sub get_ip_os_head {
my ($ipos,$iposver,$iposhead) = get_ip_os(@_);
return $iposhead;
}
sub make_answer {
my $def = shift;
my $msg = join('; ',@_);
$msg = $def unless ($msg);
$msg = "<$SLVars{QI}> $msg" if ($SLVars{QI});
return $msg;
}
sub reject_answer {
return make_answer('Rejected',@_);
}
sub tempfail_answer {
return make_answer('Try again later',@_);
}
@removed_parts = ();
sub removed_part_note($$) {
my ($what,$why) = @_;
push @removed_parts, "$what was removed from this document as it $why.";
debug_log(1,'removed_part_note %i, %s', $#removed_parts, "$what was removed from this document as it $why.");
}
sub note_footer {
my $foot = "Please give the following information to any technician or administrator you contact about this mail:\n";
unshift @_, 'QDir: '.get_quarantine_dir() if ($did_quarantine);
unshift @_, "MsgID: $SLVars{QI}";
unshift @_, "Filter: $FilterVersion";
unshift @_, "Gateway: $MyFilterHostName";
foreach my $infs (@_) {
next unless ($infs);
next if ($infs =~ /^\S+:\s*$/);
$infs =~ s/^([^\s:]+)[\s:]*(.*)$/$1: $2/;
$infs =~ s/^(QDir: ).*\/([^\/]+)/$1$2/i;
$foot .= "$infs\n";
debug_log(2,"note_footer: info: $infs");
}
return $foot;
}
# Dirty mime word encoding...
sub mqpcs {
my $cs = shift;
$cs = 'iso-8859-1' unless ($cs);
while (@_ && $_[0] eq '') { shift @_; }
while (@_ && $_[$#_] eq '') { pop @_; }
my $v = join('; ',@_);
$v = '' unless (defined($v) && $v ne '');
if ($v =~ /[\x00-\x1F\x7F-\xFF]/ && load_modules('MIME::Words ()','Encode')) {
$v = MIME::Words::encode_mimeword(encode($cs,$v),'Q',$cs);
$v =~ s/\s/_/g;
}
return $v;
}
sub mqp {
return mqpcs('',@_);
}
sub mqpma {
my $ia = shift;
return mqp(@_) unless ($ia);
while (@_ && $_[0] eq '') { shift @_; }
while (@_ && $_[$#_] eq '') { pop @_; }
my $v = join(', ',@_);
$v = '' unless (defined($v) && $v ne '');
my $r = '';
while ($v =~ /^(.*?)(\s*<[^>\x00-\x1F\x7F-\xFF]*>\s*)(.*)$/) {
$r .= mqp('',$1).$2;
$v = $3;
}
return $r.mqp('',$v);
}
# retrieve mail addresses...
sub get_addresses_from_value {
my ($adr,$al,$lo,$hn) = @_;
return 0 unless (load_modules('Mail::Address'));
$al = '' unless (defined($al));
$hn = '?' unless ($hn);
my $c = 0;
my @a = Mail::Address->parse($adr);
return 0 unless (@a);
foreach my $a (@a) {
next unless ($a->address);
my $aa = address_strip_nc($a->address);
next unless ($aa);
if ($al =~ /^HASH\(0x[a-zA-Z0-9]+\)$/) {
$al->{lc($aa)} = $aa;
} else {
$aa = lc($aa) if ($lo eq 'lc');
if ($al =~ /^ARRAY\(0x[a-zA-Z0-9]+\)$/) {
if ($lo eq 'all') {
my $usr = lc($aa);
my $dom = '';
if ($usr =~ /^(.*)\@(.*?)$/) {
$dom = $2;
$usr = $1;
}
my %i = (
header => lc($hn),
object => $a,
address => $aa,
name => $a->name,
addr => lc($aa),
user => $usr,
domain => $dom,
);
push @{$al}, \%i;
} else {
push @{$al}, $aa;
}
} elsif ($al =~ /^SCALAR\(0x[a-zA-Z0-9]+\)$/) {
$$al .= "|$aa";
} else {
$al .= "|$aa";
}
}
$c ++;
}
return $c;
}
# retrieve mail addresses from entity, header or string
sub get_addresses_from_header {
my ($head,$hnl,$al,$lo) = @_;
return 0 unless ($head);
if ($head =~ /^(?:MIME::Entity|Mail::Internet)=/) {
$head = $head->head;
return 0 unless ($head);
}
if ($head =~ /^(?:MIME::Head|Mail::Header)=/) {
my $c = 0;
foreach my $hn (split(/:/,$hnl)) {
my @hl = $head->get($hn);
next unless (@hl);
foreach my $h (@hl) {
$c += get_addresses_from_value($h,$al,$lo,$hn);
}
}
return $c;
}
if ($hnl eq '?') {
if ($head =~ /^\s*(\S*):\s+(.*?)\s*$/) {
return get_addresses_from_value($2,$al,$lo,$1);
}
return get_addresses_from_value($head,$al,$lo);
}
return get_addresses_from_value($head,$al,$lo,$hnl);
}
# retrieve first mail address
sub get_address_from_header {
my ($entity,$hn,$lo) = @_;
my @al = ();
return $al[0] if (get_addresses_from_header($entity,$hn,\@al,$lo));
return undef if ($lo eq 'all');
return '';
}
sub get_addresses_string_from_header {
my ($entity,$hn) = @_;
my @al = ();
return '?' unless (get_addresses_from_header($entity,$hn,\@al));
return join(', ',@al);
}
# Get a fortune cookie...
%fortunehandlers = ();
sub get_fortune_cookie {
my ($fn,$l1,$d) = @_;
$d = '' unless ($d);
return $d unless ($fn);
debug_log(5,'get_fortune_cookie %s %u %s',$fn,$l1,$d);
return $d unless (load_modules('Fortune'));
if ($fortunehandlers{$fn} && $fortunehandlers{$fn}{f}) {
$fortunehandlers{$fn} = undef if ((stat($fn))[9] != $fortunehandlers{$fn}{d} || (stat($fn))[7] != $fortunehandlers{$fn}{z});
}
my $fo = 0;
if ($fortunehandlers{$fn} && $fortunehandlers{$fn}{f}) {
debug_log(5,'get_fortune_cookie open %s',$fn);
eval { $fortunehandlers{$fn}{f}->open_file; $fo = 1; };
} else {
return $d unless (-f $fn);
$fortunehandlers{$fn}{d} = (stat(_))[9];
$fortunehandlers{$fn}{z} = (stat(_))[7];
debug_log(1,'get_fortune_cookie create %s',$fn);
eval { $fortunehandlers{$fn}{f} = new Fortune($fn); };
return $d unless ($fortunehandlers{$fn}{f});
if (-f "$fn.dat") {
eval { $fortunehandlers{$fn}{f}->read_header(); $fo = 1; };
} else {
eval { $fortunehandlers{$fn}{f}->compute_header(); $fo = 1; };
}
}
unless ($fo) {
debug_log(-1,'get_fortune_cookie error %s',$fn);
delete $fortunehandlers{$fn};
return $d;
}
my $t = 0;
debug_log(5,'get_fortune_cookie get %u',$t);
while ($t < 10) {
$t ++;
debug_log(3,'get_fortune_cookie get %u',$t);
my $c = $fortunehandlers{$fn}{f}->get_random_fortune;
next unless ($c);
$c =~ s/^[\r\n\s]+//s;
if ($l1) {
$c =~ s/[\r\n\s]+$//s;
next if ($c =~ /[\r\n]/);
$c =~ s/\s+/ /gs;
}
next unless ($c);
next if ($c =~ /[^\r\n\s\x20-\x7E]/);
$fortunehandlers{$fn}{f}->close_file;
debug_log(5,'get_fortune_cookie got %u',$t);
return $c;
}
$fortunehandlers{$fn}{f}->close_file;
debug_log(3,'get_fortune_cookie default %s',$fn);
return $d;
}
# Get a fortune
sub get_fortune {
return get_fortune_cookie($silly_fortunes);
}
# Get a one-liner
sub get_oneliner {
return get_fortune_cookie($silly_oneliners,1);
}
#***********************************************************************
# SQL.
#***********************************************************************
my $sql_did;
sub sql_translate {
my ($cmd) = @_;
if ($sqldbd eq 'M') {
$cmd =~ s/^INSERT OR IGNORE /INSERT IGNORE /;
}
return $cmd;
}
sub sql_do_commands {
$sql_did = 0;
for (my $i=0;$i<@_;$i++) {
my $cmd = sql_translate($_[$i]);
#debug_log(0,'sql_do_commands: %s ',$cmd);
return 0 unless ($cmd);
my $did = $sqldb->do($cmd);
return 0 unless (defined($did));
$sql_did += $did;
}
return 1;
}
sub sql_exec_commands {
$sql_did = 0;
for (my $i=0;$i<@_;$i++) {
my @pars = @{$_[$i]};
my $cmd = sql_translate(shift @pars);
return 0 unless ($cmd);
my $st = $sqldb->prepare_cached($cmd);
return 0 unless ($st);
#debug_log(0,'sql_exec_commands: %s : %s',$cmd,join(' | ',@pars));
my $res = $st->execute(@pars);
$st->finish;
unless ($res) {
debug_log(-1,'sql_exec_commands error: %s : %s',$cmd,join(' | ',@pars));
return 0;
}
$sql_did += $res;
}
return 1;
}
sub sql_disconnect {
$sqldb->disconnect() if ($sqldb);
$sqldb = undef;
}
sub sql_connect {
my $f = shift;
sql_disconnect() if ($f);
if ($sqldb) {
return 1 if ($sqldbd eq 'L');
sql_disconnect() unless (eval { $sqldb->ping });
return 1 if ($sqldb);
debug_log(0,'SQL Connect Old (%s)',$sqldbd);
}
$sqldb = DBI->connect($database_spec,$database_user,$database_pass,{RaiseError=>0});
unless ($sqldb) {
debug_log(-1,'SQL Connect Failed (%s) %s',$sqldbd,$DBI::errstr);
return 0;
}
if ($sqldbd eq 'L') {
sql_do_commands('PRAGMA SYNCHRONOUS=OFF');
}
#debug_log(0,'SQL Connect Ok (%s)',$sqldbd);
return 1;
}
sub sql_quote {
my $s = shift;
sql_connect() unless ($sqldb);
return $s unless ($sqldb);
return $sqldb->quote($s);
}
sub sql_quotes {
my @r = ();
while (my $s = shift @_) {
push @r, sql_quote($s);
}
return @r;
}
sub sql_do {
return 0 unless (sql_connect());
my $ok = sql_do_commands(@_);
return $ok if ($sqldb->{AutoCommit});
if ($ok) {
#debug_log(0,'sql_do: commit');
return $sqldb->commit;
}
debug_log(-1,'sql_do: rollback');
$sqldb->rollback;
return 0;
}
sub sql_execute_multi {
return 0 unless (sql_connect());
$sqldb->begin_work if ($sqldb->{AutoCommit});
my $ok = sql_exec_commands(@_);
return $ok if ($sqldb->{AutoCommit});
return $sqldb->commit if ($ok);
debug_log(-1,'sql_exec: rollback');
$sqldb->rollback;
return 0;
}
sub sql_execute {
return sql_execute_multi(\@_);
}
sub sql_select {
my $cmd = shift;
return undef unless (sql_connect());
return undef unless ($cmd);
my $st;
if (@_) {
debug_log(7,'sql_select: %s : %s',$cmd,join(' | ',@_));
$st = $sqldb->prepare_cached($cmd);
$st->execute(@_) if ($st);
} else {
debug_log(7,'sql_select: %s',$cmd);
$st = $sqldb->prepare_cached("$cmd");
$st->execute if ($st);
}
debug_log(-1,'sql prepare error: %s',$cmd) unless ($st);
return $st;
}
sub sql_select_one_row {
my $st = sql_select(@_);
return undef unless ($st);
my @res = $st->fetchrow_array;
$st->finish;
return \@res;
}
sub sql_select_one {
my $res = sql_select_one_row(@_);
return undef unless ($res && @{$res});
return $res->[0];
}
#***********************************************************************
# More code.
#***********************************************************************
$overlongheader = 0;
sub check_header_length {
my ($h,$s) = @_;
return 0 unless (defined($h) && defined($s) && $h ne '' && $s ne '');
if (length($h)>127 || length($s)>7*1024) {
debug_log(-1,'overlong header %s: %s',$h,$s);
$overlongheader ++;
return 0;
}
return 1;
}
sub u7shv {
my $v = join('; ',@_);
$v =~ s/(\r?\n)(\r?\n)*/$1/g;
$v =~ s/\n(\S)/\n\t$1/g;
return $v unless ($v =~ /[\x7F-\xFF]/ && load_modules('Encode'));
return encode('UTF-7',$v);
}
sub do_action_change_header_stnl {
my ($h,$s,$i) = @_;
return unless ($h && defined($s));
$s =~ s/[\r\n\s]+$//s;
return if ($s eq '');
$s = u7shv($s);
return unless (check_header_length($h,$s));
debug_log(5,'do_action_change_header_stnl %s: %s',$h,$s);
return action_change_header($h,$s,$i) if (defined($i));
return action_change_header($h,$s);
}
sub do_action_insert_header {
my ($ent,$h,$s,$i) = @_;
return unless ($h && defined($s));
$s =~ s/[\r\n\s]+$//s;
return if ($s eq '');
$s = u7shv($s);
$i = 0 unless (defined($i));
$ent->head->add($h,$s,$i) if (defined($ent) && defined($ent->head));
return unless (check_header_length($h,$s));
debug_log(5,'do_action_insert_header %s: %s',$h,$s);
return action_insert_header($h,$s,$i);
}
sub do_action_change_header {
my ($ent,$h,$v,$i) = @_;
return unless ($h && defined($v));
$v =~ s/[\r\n\s]+$//s;
return if ($v eq '');
$v = u7shv($v);
if (defined($i)) {
$ent->head->replace($h,$v,$i-1) if (defined($ent) && defined($ent->head));
action_change_header($h,$v,$i) if (check_header_length($h,$v));
} else {
$ent->head->replace($h,$v) if (defined($ent) && defined($ent->head));
action_change_header($h,$v) if (check_header_length($h,$v));
}
return undef;
}
sub do_action_insert_or_change_header {
my ($entity,$header,$value,$fch,$pos) = @_;
return unless ($header && defined($value));
$value =~ s/[\r\n\s]+$//s;
return if ($value eq '');
$value = u7shv($value);
$fch = 0 unless ($fch);
unless ($fch && defined($entity) && defined($entity->head) && defined($entity->head->get($header))) {
$pos = 0 unless ($pos);
$entity->head->add($header,$value,$pos);
debug_log(5,'do_action_insert_or_change_header %s: %s',$header,$value);
return action_insert_header($header,$value,$pos) if (check_header_length($header,$value));
return;
}
unless ($fch<0) {
$entity->head->replace($header,$value) if (defined($entity) && defined($entity->head));
return action_change_header($header,$value) if (check_header_length($header,$value));
}
return undef;
}
sub do_action_delete_header {
my ($ent,$h,$i) = @_;
if (defined($i)) {
$ent->head->delete($h,$i-1) if (defined($ent) && defined($ent->head));
action_delete_header($h,$i);
return;
}
$ent->head->delete($h) if (defined($ent) && defined($ent->head));
action_delete_header($h);
}
sub do_action_add_header {
my ($ent,$h,$s) = @_;
return unless ($h && defined($s));
$s =~ s/[\r\n\s]+$//s;
return if ($s eq '');
$s = u7shv($s);
$ent->head->add($h,$s,-1) if (defined($ent) && defined($ent->head));
if (length($s)>7*1024) {
$overlongheader ++;
return;
}
return action_insert_add($h,$s);
}
# Decode a MIME encoded header value
sub decode_header {
my $r = join('',@_);
$r =~ s/[\r\n]+$//;
#debug_log(0,'decode_header < %s',$r);
if ($r =~ /=\?(\S+?)\?[QBqb]\?.*\?=/ && load_modules('MIME::Words ()','Encode')) {
my $x = $r; $r = '';
while ($x =~ /^(.*?)(=\?[^\?]*\?[QqBb]\?)(.*?)(\?=)(.*)$/) {
$r .= "$1$2";
my $d = $3; my $e = $4;
$x = $5;
$d =~ s/\?/=3F/gs;
$r .= "$d$e";
}
$r .= $x;
my @vl; eval { @vl = MIME::Words::decode_mimewords($r); };
if (@vl) {
$r = '';
foreach my $v (@vl) {
if ($v->[1]) {
$v->[1] =~ s/^unicode-\d-\d-(utf-\d)$/$1/;
my $dd;
eval { $dd = decode($v->[1],$v->[0]); };
unless (defined($dd)) {
eval { $dd = decode('iso-8859-1',$v->[0]); };
unless (defined($dd)) {
$dd = $v->[0];
$dd =~ s/=\?\S+?\?[QBqb]\?//gs;
$dd =~ s/\?=//gs;
$dd =~ s/=[A-Fa-f0-9][A-Fa-f0-9]/?/gs;
}
}
$r .= $dd;
} else {
$r .= $v->[0];
}
}
#debug_log(0,'decode_header > %s',$r);
}
}
$r =~ s/[\s\r\n\t]+/ /gs;
$r =~ s/^\s+//;
$r =~ s/\s+$//;
return $r;
}
# Remove paths and drive from part name header
# Just testing for now...
sub fix_entity_filename_header {
my ($head,$hn,$ha,$hch) = @_;
my $fn = $head->mime_attr("$hn.$ha");
if (defined($fn)) {
my $cs = '';
if ($fn =~ /=\?(\S+?)\?[QBqb]\?.*\?=/) {
$cs = $1;
$fn = decode_header($fn);
}
my $nn = $fn;
$nn =~ s/\s+/ /gs;
$nn =~ s/^[\s]*(.*?)[\s\.]*/$1/;
$nn =~ s/^\S+:\/\///;
$nn =~ s/^\S+://;
$nn =~ s/^[A-Z][\|:](.*[\\\/])?//;
$nn =~ s/[\?\*\'\"]//g;
$nn =~ s/^[\s]*(.*?)[\s\.]*/$1/;
$nn =~ s/\s+/ /gs;
$nn =~ s/[\\\/]/!/g;
$nn =~ s/^\.+/./;
if ($nn =~ /^(\..*)?$/) {
$nn = "missing$1";
}
my $xn = $fn;
$xn =~ s/([^ ]) +([^ ])/$1 $2/gs;
if ($nn ne $xn) {
debug_log(3,"fefh: $hn.$ha $fn -> $nn");
# Only testing for now?
#return 0;
$head->mime_attr("$hn.$ha",mqpcs($cs,$nn));
$hch->{lc($hn)} = $hn;
return 1;
}
}
return 0;
}
# Checks for some bad header stuff...
sub fix_entity_headers {
my ($entity,$isroot) = @_;
#debug_log(2,"feh 1");
return unless ($fix_headers);
#debug_log(2,"feh 2");
my $head = $entity->head;
my $r = 0;
if ($head) {
#debug_log(2,"feh 3");
my %hch = ();
debug_log(7,"feh: ".$entity->effective_type);
my $csc = 0;
my $fnc = 0;
my $hbc = 0;
# Misconfed MS Outlook Express sometimes uses strange charset,
# but MS Outlook croaks on that. :-/
# Replace it and hope for the best...
if ($entity->effective_type =~ /^text\/(plain|html)$/) {
my $cs = $head->mime_attr('content-type.charset');
if ($cs && lc($cs) eq 'x-user-defined') {
debug_log(4,"feh: cs $cs");
$head->mime_attr('Content-Type.Charset' => 'iso-8859-1');
$hch{'content-type'} = 'Content-Type';
$csc ++;
}
}
my @tl = $head->tags;
foreach my $tn (@tl) {
my $tc = $head->count($tn);
debug_log(7,"feh: head $tn $ti");
for (my $ti=0;$ti<$tc;$ti++) {
my $tv = $head->get($tn,$ti);
next unless ($tv);
debug_log(7,"feh: head o $tn\[$ti\] $tv");
my $tx = $tv;
# We don't like high bit chars in headers, but only check a couple of commonly bad headers
if ($isroot && $tn =~ /^(From|To|Reply-To|Subject)$/i && $tv =~ /[^\t\r\n\x20-\x7E]/) {
my $fia = ($tn =~ /^(From|To|Reply-To)$/i);
my $txt = $tx;
$tx = '';
while ($txt =~ /^(\s*)(.*?)(\s*[\r\n]+\s*)(.*)$/s) {
$txt = $4;
$tx .= $1.mqpma($fia,$2).$3;
}
$tx .= mqpma($fia,$txt);
debug_log(2,'feh: hb %s %s %s',$tn,$tv,$tx);
}
$tx =~ s/=\?x-user-defined\?/=?iso-8859-1?/gsi;
if ($tx ne $tv) {
debug_log(4,"feh: head n $tn\[$ti\] $tx");
$head->replace($tn,$tx,$ti);
$hch{lc($tn)} = $tn;
$csc ++;
}
}
}
$r += $csc;
# We don't like paths and protocols/drives in filenames. Remove them.
$fnc ++ if (fix_entity_filename_header($head,'Content-Type','filename',\%hch));
$fnc ++ if (fix_entity_filename_header($head,'Content-Type','name',\%hch));
$fnc ++ if (fix_entity_filename_header($head,'Content-Disposition','filename',\%hch));
$fnc ++ if (fix_entity_filename_header($head,'Content-Disposition','name',\%hch));
$r += $fnc;
# If we're at the root, headers must be changed through milter stuff...
if ($isroot) {
foreach my $hn (keys %hch) {
next unless ($hch{$hn});
do_action_change_header_stnl($hch{$hn},$head->get($hn));
}
}
#debug_log(2,"feh e1");
if ($csc) {
$modhead{'Replaced bad charset.'} ++;
debug_log(2,"header, bad charset");
#md_graphdefang_log('modified_entity', 'charset');
stats_log('modified','modified_entity','charset');
#do_action_add_header($entity,'X-MIME-Fixed',"replaced bad charset with 'iso-8859-1' at $MyFilterHostName") if ($isroot);
}
if ($fnc) {
$modhead{'Changed bad part name.'} ++;
debug_log(2,"header, bad part name");
#md_graphdefang_log('modified_entity', 'name');
stats_log('modified','modified_entity','name');
}
}
#debug_log(2,"feh ee");
return $r;
}
# saves time stamp
sub save_time_stamp() {
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO times (ts_id,ts_stamp) VALUES (?,?) '.
'ON DUPLICATE KEY UPDATE ts_stamp=VALUES(ts_stamp)',
$SLVars{QI},time());
} else {
sql_execute('REPLACE INTO times (ts_id,ts_stamp) VALUES (?,?)',$SLVars{QI},time());
}
}
sub time_since_stamp() {
my $time = sql_select_one('SELECT ts_stamp FROM times WHERE ts_id=?',$SLVars{QI});
return time()-$time if ($time);
return -1;
}
sub end_time_stamp() {
return unless ($SLVars{QI});
my $start = sql_select_one('SELECT ts_stamp FROM times WHERE ts_id=?',$SLVars{QI});
my $now = time();
my $time = $now-$start if ($start);
$time = 0 unless ($time);
sql_execute('UPDATE times SET ts_end=?,ts_time=? WHERE ts_id=?',$now,$time,$SLVars{QI});
stats_log('time',$time,get_load_average(),get_swap_percentage()) if ($start);
}
sub clean_time_stamps {
return 0 unless ($ts_keep);
debug_log(0,'%u ts rec(s) removed',$sql_did) if (sql_execute('DELETE FROM times WHERE (ts_stamp<?)',time()-$ts_keep) && $sql_did>0);
return $sql_did;
}
my %resolvers = ();
sub get_resolver {
my ($to) = @_;
$to = 5 unless ($to);
return $resolvers{$to} if (defined($resolvers{$to}));
return undef unless (load_modules('Net::DNS'));
$resolvers{$to} = Net::DNS::Resolver->new;
$resolvers{$to}->persistent_tcp(0);
$resolvers{$to}->tcp_timeout($to);
$resolvers{$to}->udp_timeout($to);
return $resolvers{$to};
}
sub get_rdnses {
my $ip = address_strip_nc(shift);
my $to = shift;
return () unless($ip);
return ($ip) unless ($ip =~ /^\d+\.\d+\.\d+\.\d+$/);
my $dns = get_resolver($to?$to:5);
return () unless (defined($dns));
#debug_log(0,'get_rdnses < %s',$ip);
my $ptr = $dns->query($ip,'PTR');
return () unless ($ptr);
my %rnl = ();
foreach my $r ($ptr->answer) {
next unless ($r->type eq 'PTR');
next unless ($r->ptrdname);
#debug_log(0,'get_rdnses > %s %s',$ip,$r->ptrdname);
$rnl{$r->ptrdname} = 1;
}
return wantarray ? keys %rnl : [keys %rnl];
}
sub get_rdns {
foreach my $rn (get_rdnses(@_)) {
return $rn if ($rn);
}
return '['.address_strip_nc($_[0]).']';
}
sub get_hostips {
my $host = address_strip_nc(shift);
my $to = shift;
my $ma = shift;
return () unless($host);
return ($host) if ($host =~ /^\d+\.\d+\.\d+\.\d+$/);
my $dns = get_resolver($to?$to:5);
return () unless (defined($dns));
#debug_log(0,'get_hostip < %s',$host);
my $adr = $dns->query($host,'A');
return () unless ($adr);
my %ipl = ();
my $ic = 0;
foreach my $r ($adr->answer) {
next unless ($r->type eq 'A');
next unless ($r->address);
#debug_log(0,'get_hostip > %s %s',$host,$r->address);
$ipl{$r->address} = 1;
$ic ++;
last if ($ma && $ic >= $ma);
}
return wantarray ? keys %ipl : [keys %ipl];
}
sub get_hostip {
my ($host,$to) = @_;
my @ipl = get_hostips($host,$to,1);
return @ipl ? $ipl[0] : '';
}
sub get_full_circle_dnses {
my $ip = address_strip_nc(shift);
my $to = shift;
return () unless($ip && $ip =~ /^\d+\.\d+\.\d+\.\d+$/);
debug_log(8,'get_full_circle_dnses < %s',$ip);
my %fcnl = ();
my $dns;
foreach my $rn (get_rdnses($ip,$to)) {
next unless ($rn && $rn !~ /^\d+\.\d+\.\d+\.\d+$/);
foreach my $an (get_hostips($rn,$to)) {
debug_log(5,'get_full_circle_dnses > %s %s',$ip,$rn);
$fcnl{$rn} = 1 if ($an eq $ip);
}
}
return wantarray ? keys %fcnl : [keys %fcnl];
}
sub get_full_circle_dns {
foreach my $fcn (get_full_circle_dnses(@_)) {
return $fcn if ($fcn);
}
return '';
}
sub get_mxes {
my ($d,$to,$rip) = @_;
my $dns = get_resolver($to?$to:15);
return () unless (defined($dns));
my @mx = ();
my $mx = $dns->query($d,'MX');
if ($mx) {
foreach my $r ($mx->answer) {
next unless ($r->type eq 'MX');
next unless ($r->exchange);
#debug_log(0,'get_mxes %s %s',$d,$r->exchange);
push @mx, {p=>$r->preference,x=>$r->exchange};
}
}
push @mx, {p=>0,x=>$d} unless (@mx);
if ($rip) {
foreach my $mxr (@mx) {
#debug_log(0,'get_mxes ip %s',$mxr->{x});
$mxr->{a} = [get_hostips($mxr->{x})];
}
}
return wantarray ? @mx : \@mx;
}
sub server_is_mx {
my ($ip,$host,$addr) = @_;
#debug_log(0,'server_is_mx %s %s %s',$ip,$host,$addr);
$addr = address_strip($addr);
if ($addr && $addr =~ /^.*\@([^\@]+)$/) {
my $dom = $1;
foreach my $mx (get_mxes($dom,5,1)) {
foreach my $aa (@{$mx->{a}}) {
#debug_log(0,'server_is_mx a %s %s',$dom,$aa);
if ($aa eq $ip) {
debug_log(3,'server_is_mx %s %s',$dom,$aa);
return $dom;
}
}
}
}
return 0 if ($host =~ /^\[?\d+\.\d+\.\d+\.\d+\]?$/);
my @hosts;
if ($host) {
#debug_log(0,'server_is_mx h %s',$host);
@hosts = ($host);
} else {
#debug_log(0,'server_is_mx q %s',$ip);
@hosts = get_rdnses($ip);
}
my %doms = ();
foreach $host (@hosts) {
my @hnl = split(/\./,$host);
while ($#hnl > 2) { shift @hnl; }
while ($#hnl > 0) {
$doms{lc(join('.',@hnl))} = 1;
shift @hnl;
}
}
foreach my $dom (keys %doms) {
#debug_log(0,'server_is_mx d %s',$dom);
foreach my $mx (get_mxes($dom,5,1)) {
foreach my $aa (@{$mx->{a}}) {
#debug_log(0,'server_is_mx d %s %s',$dom,$aa);
if ($aa eq $ip) {
debug_log(3,'server_is_mx %s %s',$dom,$aa);
return $dom;
}
}
}
}
#debug_log(0,'server_is_mx -');
return 0;
}
sub check_dnsls {
my $addr = shift;
my $to = shift;
my $wans = shift;
my @hits = ();
$to = 15 unless ($to);
$wans = 1 unless ($wans && $wans > 0);
debug_log(3,'check_dnsls ? %u %s %s',$wans,$addr,join(' ',@_));
my %domains = ();
while (@_) {
my $chk = lc(shift @_);
my $tst = 0;
if ($chk =~ /^(.*)[:=](.*)$/) {
$chk = $1;
$tst = $2;
}
$chk =~ s/^[\.\s]+//;
$chk =~ s/[\.\s]+$//;
$tst =~ s/^\s+//;
$tst =~ s/\s+$//;
$domains{$chk} = {tl=>[]} unless ($domains{$chk});
push @{$domains{$chk}->{tl}}, $tst;
}
return wantarray ? (0,\@hits) : 0 unless (%domains);
my $dns = get_resolver($to);
return wantarray ? (0,\@hits) : 0 unless ($dns);
my $caddr = $addr;
if ($caddr =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { $caddr = "$4.$3.$2.$1"; }
my $doms = 0;
debug_log(7,'check_dnsls > %u %s',scalar keys %domains,join(' ',keys %domains));
foreach my $dom (keys %domains) {
$domains{$dom}->{qs} = $dns->bgsend("$caddr.$dom",'A');
$doms ++ if ($domains{$dom}->{qs});
debug_log(1,'check_dnsls > %u %s',$doms,"$caddr.$dom");
}
debug_log(7,'check_dnsls = %u %s',$doms,join(' ',keys %domains));
$to = time() + $to;
my $pans = 0;
while ($doms) {
foreach my $dom (keys %domains) {
next unless ($domains{$dom}->{qs});
next unless ($dns->bgisready($domains{$dom}->{qs}));
my $pkt = $dns->bgread($domains{$dom}->{qs});
$domains{$dom}->{qs}->close;
delete $domains{$dom};
$doms --;
unless (defined($pkt)) {
last unless ($doms);
next;
}
debug_log(1,'check_dnsls < %s',$dom);
my %ga = ();
foreach my $ans ($pkt->answer) {
next unless ($ans->class eq 'IN');
next unless ($ans->type eq 'A');
next unless ($ans->address);
next if ($ga{$ans->address});
foreach my $tst (@{$domains{$dom}->{tl}}) {
next unless (!(%ga || $tst) || ($tst eq $ans->address));
debug_log(1,'check_dnsls @ %s %s %s %s',$dom,$ans->address,$tst,$addr);
push @hits, $dom;
$pans ++;
}
$ga{$ans->address} = 1;
last if ($pans >= $wans);
}
last if ($pans >= $wans);
last unless ($doms);
}
last if ($pans >= $wans);
last unless ($doms);
last if (time() > $to);
sleep(1);
}
foreach my $inf (values %domains) {
$inf->{qs}->close if ($inf->{qs});
}
debug_log(3,'check_dnsls ! %u %u %s %s',$wans,$pans,$addr,join(' ',keys %domains));
return wantarray ? ($pans,\@hits) : $pans if ($pans >= $wans);
return wantarray ? (0,\@hits) : 0;
}
sub trim_host_part {
my $addr = address_strip(shift @_);
my $toboundary = shift @_;
return $addr unless (load_modules('Mail::SpamAssassin::Util::RegistrarBoundaries'));
my $dn = Mail::SpamAssassin::Util::RegistrarBoundaries::trim_domain($addr);
return $addr unless ($dn);
return $dn if ($toboundary);
#debug_log(0,'trim_host_part < %s %s',$addr,$dn);
$addr =~ s/^(.*?\.)([^.]+\.$dn)$/$2/;
#debug_log(0,'trim_host_part > %s %s',$addr,$dn);
return $addr;
}
sub trim_hosts_parts_i {
my $toboundary = shift;
my %dnl = ();
while (@_) {
my $addr = address_strip(shift @_);
if ($addr =~ /^\d+\.\d+\.\d+\.\d+$/) {
push @_, get_rdnses($addr);
} elsif ($addr) {
$dnl{trim_host_part($addr,$toboundary)} = 1;
}
}
return wantarray ? keys %dnl : [keys %dnl];
}
sub get_hosts_parts_names {
my %hpl = ();
while (@_) {
my $addr = address_strip(shift @_);
if ($addr =~ /^\d+\.\d+\.\d+\.\d+$/) {
push @_, get_full_circle_dnses($addr);
} elsif ($addr) {
$hpl{$addr} = 1;
$hpl{trim_host_part($addr)} = 1;
}
}
return wantarray ? keys %hpl : [keys %hpl];
}
sub trim_hosts_parts {
return trim_hosts_parts_i(0,@_);
}
sub get_domains_parts {
return trim_hosts_parts_i(1,@_);
}
sub InitSLVars {
%SLVars = ();
my $vl = join('',@_);
if ($vl =~ /[Mm]/ && $RelayHostname ne $RealRelayHostname) {
$RelayHostname = get_rdns($RelayHostname);
$RealRelayHostname = get_rdns($RealRelayHostname);
} elsif ($vl) {
$RelayHostname = get_rdns($RelayHostname);
$RealRelayHostname = $RelayHostname;
}
if ($vl =~ /[AaHhQqSsRrMm]/) {
$SLVars{RA} = $RelayAddr;
$SLVars{RH} = $RelayHostname;
}
if ($vl =~ /[HhQqSsRrMm]/) {
$SLVars{HN} = $Helo;
}
if ($vl =~ /[QqSsRrMm]/) {
$SLVars{QI} = ($QueueID && $QueueID ne 'NOQUEUE') ? $QueueID : '';
}
if ($vl =~ /[SsRrMm]/) {
$SLVars{MF} = $Sender;
}
if ($vl =~ /[RrMm]/) {
$SLVars{RT} = [@Recipients];
}
if ($vl =~ /[Mm]/) {
$SLVars{MI} = ($MessageID && $MessageID ne 'NOQUEUE') ? $MessageID : '';
$SLVars{MS} = $Subject;
}
foreach my $k (keys %SLVars) {
$SLVars{$k} = '' unless (defined($SLVars{$k}));
}
}
#***********************************************************************
# Dynamic host name checks.
#***********************************************************************
sub check_ip_parts {
my $x = shift;
return 0 if ($x && @_ != 4);
my $ic = 0;
my $hc = 0;
foreach my $p (@_) {
unless ($x) {
my @pp = split(/-/,$p);
return 3 if (check_ip_parts(1,@pp));
@pp = split(/_/,$p);
return 3 if (check_ip_parts(1,@pp));
}
my $i = ($p =~ /^\d{1,3}$/ && $p >= 0 && $p <= 255);
my $h = 0;
if ($p =~ /^[0-9A-Fa-f]{1,2}$/) {
my $i = hex $p;
$h = ($i >= 0 && $i <= 255);
}
$ic ++ if ($i);
$hc ++ if ($h);
return 2 if ($ic == 4);
return 1 if ($hc == 4);
}
return 0;
}
sub check_ip_fqdn {
my $fqdn = shift;
my $ip = shift;
return 0 if ($fqdn =~ /^\[$ip\]$/);
if ($ip =~ /^\d+\.\d+\.\d+\.\d+$/) {
my $rip = join('.',reverse split(/\./,$ip));
$ip =~ s/(\d+)/sprintf('(%1$u|%1$x|%1$02u|%1$02x|%1$03u)',$1)/ge;
$rip =~ s/(\d+)/sprintf('(%1$u|%1$x|%1$02u|%1$02x|%1$03u)',$1)/ge;
$ip =~ s/\./[-._]/g;
$rip =~ s/\./[-._]/g;
return 5 if ($fqdn =~ /(|.*\.)$ip\./i);
return 5 if ($fqdn =~ /(|.*\.)$rip\./i);
$ip =~ s/\[-\._\]//g;
$rip =~ s/\[-\._\]//g;
return 4 if ($fqdn =~ /(|.*\.)$ip\./i);
return 4 if ($fqdn =~ /(|.*\.)$rip\./i);
}
return check_ip_parts(0,split(/\./,$fqdn));
}
sub check_user_fqdn {
my $fqdn = shift;
return 3 if ($fqdn =~ /^(|.*[._-])(a?dsl|cable|dial[-._]?up|dynamic|dynamicip|customer|dhcp)(|[._-].*)$/i);
return 2 if ($fqdn =~ /^(|.*[._-])(cust|kund)(|[._-].*)$/i);
return 1 if ($fqdn =~ /^(|.*[._-])(a?dsl[a-z]|cable)\d*(|[._-].*)$/i);
return 0;
}
sub check_muser_fqdn {
my $fqdn = shift;
return 1 if ($fqdn =~ /\d+[-_.]\d+[-_.]\d+/);
return 1 if ($fqdn =~ /^\d+[-_.]\d+[-_.]/);
return 1 if ($fqdn =~ /(cust|ppp|cable|dsl|user|pool|\d{8})/i);
return 0 if ($fqdn =~ /(^|[-_.])\d*(mta|mx)\d*[-_.]/i);
return 1 if ($fqdn =~ /(^|[-_.])\d*(kund|cust|dyn|nat|pop|\d{5})\d*[-_.]/i);
return 1 if ($fqdn !~ /\./);
return 1 if ($fqdn =~ /\[.*\]/);
return 0;
}
sub check_mail_fqdn {
my $fqdn = shift;
my $xxx = '(barracuda|ironport|mail|relay|smtp|out|exch|mx|mta)';
return 3 if ($fqdn =~ /^(|.*[._-])$xxx\d{0,5}(|[._-].*)$/i);
return 2 if ($fqdn =~ /^(|.*[._-])$xxx[-._]?$xxx\d{0,5}(|[._-].*)$/i);
return 1 if ($fqdn =~ /(mail|smtp|relay|exchange)/i);
return 0;
}
sub check_server_fqdn {
my $fqdn = shift;
return 1 if ($fqdn =~ /^(|.*[._-])(server|gateway|gate|gw)\d{0,5}(|[._-].*)$/i);
return 0;
}
sub check_no_fqdn {
my $fqdn = shift;
my $ip = shift;
return 1 if ($fqdn =~ /^\[$ip\]$/);
return 0;
}
sub check_maybe_dynamic_fqdn {
my ($fqdn,$ip) = @_;
return 1 unless ($fqdn);
return 0 unless ($ip);
return 1 if (check_no_fqdn($fqdn,$ip) || check_ip_fqdn($fqdn,$ip));
return 0 if (check_mail_fqdn($fqdn));
return 1 if (check_muser_fqdn($fqdn) || check_user_fqdn($fqdn));
return 0;
}
sub check_maybe_server_fqdn {
my ($fqdn,$ip) = @_;
return 0 unless ($fqdn);
return 0 unless ($ip);
return 0 if (check_no_fqdn($fqdn,$ip) || check_ip_fqdn($fqdn,$ip));
return 1 if (check_mail_fqdn($fqdn));
return 0 if (check_muser_fqdn($fqdn) || check_user_fqdn($fqdn));
return 1 if (check_server_fqdn($fqdn));
return 0;
}
#***********************************************************************
# Misc (lists etc) checks.
#***********************************************************************
$SpamTrapAddresses =~ s/[:>]+/>/;
sub trap_this {
my $traps = shift;
my $sender = address_strip(shift);
my $recipient = address_strip(shift);
return 0 unless ($traps);
#debug_log(0,'trap> <%s> <%s> /%s/',$sender,$reipient,$traps);
return 1 if ($recipient =~ /^$traps$/i);
return 1 if ("$sender>$recipient" =~ /^$traps$/i);
return 0;
}
sub spam_trap_this {
return trap_this($SpamTrapAddresses,@_);
}
sub trap_clean {
return 0 unless ($trap_keep);
debug_log(0,'%u trap rec(s) removed',$sql_did) if (sql_execute('DELETE FROM trapper WHERE (trap_stamp<?)',time()-$trap_keep) && $sql_did>0);
return $sql_did;
}
sub trap_add {
my $host = shift;
sql_execute('INSERT INTO trapper (trap_stamp,trap_host) VALUES (?,?)',time(),address_strip($host));
}
sub trap_many {
return 0 unless ($trap_maxwindow && $trap_timewindow);
my $cnt = sql_select_one('SELECT COUNT(trap_stamp) FROM trapper WHERE trap_stamp>?',time()-$trap_timewindow);
return $cnt if ($cnt && $cnt>$trap_maxwindow);
return 0;
}
# Retrieves the storing server
sub storing_server {
my ($dom) = @_;
$dom = address_strip($dom);
$dom =~ s/^.*\@//;
return undef if ($dom =~ /^\./);
while ($dom) {
return $storingservers{$dom} if ($storingservers{$dom});
$dom =~ s/^\.//;
$dom =~ s/^[^.]*//;
}
return undef;
}
sub address_is_local {
my ($a,$css,$crm,$crt,$ncssrm) = @_;
$css = 1 unless (defined($css));
$crm = 0 unless (defined($crm));
$crt = 1 unless (defined($crt));
$ncssrm = 0 unless (defined($ncssrm));
unless ($a =~ /\@/) {
return 1 if ($a =~ /^$LocalNets$/i);
return 1 if (check_black_nets($a));
return 0;
}
unless ($ncssrm) {
if ($css) {
return 1 if ($a =~ /\@$OurDomains>?$/i);
my $hst = storing_server($a);
return 1 if ($hst =~ /^$LocalNets$/i);
return 1 if (check_black_nets($hst));
}
if ($crm && defined($RecipientMailers{$a}) && ${RecipientMailers{$a}}[0] =~ /^e?smtp$/i && ${RecipientMailers{$a}}[1] !~ /\.$/) {
return 1 if (${RecipientMailers{$a}}[1] =~ /^$LocalNets$/i);
return 1 if (check_black_nets(${RecipientMailers{$a}}[1]));
}
}
if ($crt && defined($RecipientMailers{$a}) && ${RecipientMailers{$a}}[0]) {
return address_is_local($RecipientMailers{$a}->[2],$css,$crm,0);
}
return 0;
}
sub mail_is_outbound {
my $hrm = (defined($RecipientMailers) && $RecipientMailers && %{$RecipientMailers}) ? 1 : 0;
foreach my $a (@_) {
return 1 unless (address_is_local($a,1,$hrm,$hrm));
}
return 0;
}
# Checks authentication
sub check_authenticated {
my ($checkmanual) = @_;
return 0 unless ($CanAuthenticate);
if ($checkmanual) {
open(COMM, "<./COMMANDS") or return 0;
while(<COMM>) {
if (/^=auth_authen/) {
close(COMM);
return 1;
}
}
close(COMM);
return 0;
}
return 0 unless ($SendmailMacros{auth_authen});
return $SendmailMacros{auth_authen};
}
# Checks against a small internal list
sub check_ip_in_list($$) {
my $ip = address_strip(shift);
return 0 unless ($ip && $ip =~ /^\d+\.\d+\.\d+\.\d+$/);
my $addr = inet_aton($ip);
return 0 unless ($addr);
foreach my $lst (@_) {
next unless ($lst);
foreach my $net (split(/;/,$lst)) {
$net =~ s/\s+//g;
next unless ($net);
my ($na_s,$nm_s) = split(/\//,$net);
$nm_s = '255.255.255.255' unless ($nm_s);
my $na = inet_aton($na_s);
my $nm = inet_aton($nm_s);
next unless ($na && $nm);
return 1 if (($addr & $nm) eq ($na & $nm));
}
}
return 0;
}
# Checks against a small internal IP address white list
sub check_internal_whitelist($) {
my($ip) = @_;
return check_ip_in_list($ip,"127.0.0.1/255.255.255.255;$WhiteNets");
}
# Checks if IP is a black net
sub check_black_nets($) {
my($ip) = @_;
return check_ip_in_list($ip,'10.0.0.0/255.0.0.0;172.16.0.0/255.240.0.0;192.168.0.0/255.255.0.0;127.0.0.0/255.255.255.0');
}
# Checks if IP is considered verified
sub check_auth_pass_nets($) {
my($ip) = @_;
return 0 unless ($AuthPassNets);
return check_ip_in_list($ip,$AuthPassNets);
}
# Check if HELO pretends to be ours.
sub check_our_helo($) {
my ($helo) = @_;
debug_log(4,"Checking helo: $helo");
#return 0 if ($helo =~ /^[<\[]?localhost(\.localdomain)?[\]>]?(\s.*)?$/i);
return 0 if ($helo =~ /^[<\[]?localhost(\.localdomain)?[\]>]?$/i);
#if ($helo =~ /^[<\[]?\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}[\]>]?(\s.*)?$/) {
if ($helo =~ /^[<\[]?\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}[\]>]?$/) {
return 1 if (check_ip_in_list($helo,$OurNets));
}
$helo = address_strip($helo);
return 1 if ($helo =~ /(^|^.*\.)$OurDomains$/i);
return 0;
}
# check verification
sub check_verification {
my ($verified,$what,$sender) = @_;
$sender = address_strip($sender);
return unless ($verified && @{$verified});
foreach my $snd (@{$verified}) {
if ($snd =~ /^(.*):(.*)$/) {
my $vp = $1;
my $va = $2;
next unless ($vp =~ /^$what$/);
return 1 if (address_strip($va) eq $sender);
}
}
return 0;
}
# check mail from verification
sub check_sender_verification {
my ($verified,$sender) = @_;
return 0 unless ($sender =~ /\@/);
return check_verification($verified,'SPF',$sender);
}
# Check mail address against list
sub check_mail_address_list($$$) {
my ($what,$addr,$list) = @_;
return 0 if (!($list && @{$list}));
$what = '*' unless ($what);
$what = '*' if ($what eq '?');
$addr = address_strip($addr);
debug_log(3,"Checking for $what, $addr");
foreach $l (@{$list}) {
my $line = $l;
my $x = '*';
$line =~ s/^(\n?\s*)(.*)(\s*\n?)$/$2/;
$line = lc($line);
if ($line =~ /^(\S+)\s+(\S+.*)$/) {
$x = $1;
$line = $2;
}
$x = '*' if ($x eq '?');
$x =~ s/gray/grey/g;
next unless ($x && $line);
debug_log(3,"Checking against $x, $line");
debug_log(3,"whatmatch") if ($what eq '*' || $x eq '*' || $x =~ /$what/);
debug_log(3,"addrmatch") if ($addr =~ /^$line$/);
if (($what eq '*' || $x eq '*' || $x =~ /$what/) && $addr =~ /^$line$/) {
debug_log(3,"Matched $what, $addr against $et $addr");
return 1
}
}
return 0;
}
# Checks against a list of addresses.
sub check_address_list {
# The list may be in three formats, specified with the first parameter.
# If the first parameter is "P", the list is a plain list with one host address
# (IP or domain) per line. The adresses may not be regular expressions.
# If the first parameter is "L", the list contains one address specifier
# per line. An adress specifier consists of a keyword followed by an address
# (or two addresses in some instances).
# The addresses are regular expressions.
# The parameter can be specified as "L:prefix" to require a prefix in front of
# keywords.
# If the first parameter is "R", the list contains the output from relaydb -vl.
# A sample blacklist (note that ^ and $ will allways be used around each entry):
# Sender big@boss\.com
# Host (.*\.|)artprice\.com
# Host (.*\.|)artmarket\.com
# Host (.*\.|)artinvestment\.com
# Host (.*\.|)serveur\.com
# Host (.*\.|)servergroup\.com
# Host (.*\.|)serveurgroup\.com
# Host (.*\.|)artists-server\.com
return (0,"","") unless (@_);
my %lcfg = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
return (0,"","") if (!($lcfg{list} && @{$lcfg{list}}));
$lcfg{ip} = address_strip($lcfg{ip});
$lcfg{hostname} = address_strip($lcfg{hostname});
$lcfg{helo} = address_strip($lcfg{helo});
$lcfg{from} = address_strip($lcfg{from});
$lcfg{sender} = address_strip($lcfg{sender});
$lcfg{format} = '' unless ($lcfg{format});
$lcfg{plain} = ($format =~ /^[PR]/i) unless (defined($lcfg{plain}));
$lcfg{comment} = $lcfg{file} if (!defined($lcfg{comment}) && defined($lcfg{file}));
if ($lcfg{recipient}) {
$lcfg{recipients} = [] unless ($lcfg{recipients});
push @{$lcfg{recipients}}, $lcfg{recipient};
}
unless (defined($lcfg{prefix})) {
$lcfg{prefix} = '';
if ($lcfg{format} =~ /^L:(.*)$/i) {
$lcfg{prefix} = $1;
}
}
$lcfg{prefix} =~ s/^(.)(.*?)_*$/$1(?:$2)?_?/;
address_list_log('check_address_list %s',hashstring(\%lcfg));
#debug_log(0,'CALPar %s',hashstring(\%lcfg));
my $hit = "";
my $log = "";
my $mp = '.+@';
#debug_log(0,"aldbg $lcfg{comment} ^ $lcfg{prefix}");
foreach $l (@{$lcfg{list}}) {
my $line = $l;
my $et = '';
my $addr = '';
my $retval = 1;
$line =~ s/^(\n?\s*)(.*)(\s*\n?)$/$2/;
if ($line =~ /^!\s*(.*)$/) {
$retval = 0;
$line = $1;
}
if (defined($line) && $line ne "") {
debug_log(4,"Line $line");
if ($lcfg{format} =~ /^P/i) {
$et = "HOST";
$addr = $line;
} elsif ($lcfg{format} =~ /^R/i) {
my $wc;
my $bc;
my $xxx;
($addr,$wc,$bc,$xxx) = split(/\s/,$line,4);
if (($rdb_ratio == -1) || (($bc > 0) && ($wc == 0))) {
$et = "HOST";
} elsif ($wc != 0) {
if ($bc/$wc > $rdb_ratio) {
$et = "HOST";
}
}
} elsif ($lcfg{format} =~ /^L/i) {
($et,$addr) = split(/\s+/,$line,2);
}
my $etp = (defined($et) && $et ne "" && defined($addr) && $addr ne "");
#debug_log(0,"aldbg $lcfg{comment} < $etp $et");
if ($etp && $lcfg{prefix} ne '') {
if ($et =~ /^$lcfg{prefix}(.*)$/i) {
$et = $1;
} else {
$etp = 0;
}
}
#debug_log(0,"aldbg $lcfg{comment} > $etp $et");
if ($etp) {
#address_list_log('check_address_list ? "%s"=~"%s..." "%s"',$et,$lcfg{prefix},$addr);
if ($et =~ /^S(?:ender)?[-_]?R(?:elay)?$/i) {
#address_list_log('check_address_list + "%s"=~"%s%s_%s"',$et,$prefix,'S(ender)?','R(elay)?');
my ($addr1,$addr2) = split(/\s+/,$addr,2);
if (($lcfg{sender} =~ /^$addr1$/i) && ($lcfg{ip} =~ /^$addr2$/i)) {
$hit = "$lcfg{sender}!$lcfg{ip}";
$log = "sender_host";
}
} elsif ($et =~ /^S(?:ender)?[-_]?H(?:ost)?$/i) {
#address_list_log('check_address_list + "%s"=~"%s%s_%s"',$et,$prefix,'S(ender)?','H(ost)?');
my ($addr1,$addr2) = split(/\s+/,$addr,2);
if ($lcfg{sender} =~ /^$addr1$/i) {
if ($lcfg{hostname} =~ /^$addr2$/i) {
$hit = "$lcfg{sender}!$lcfg{hostname}";
$log = "sender_host";
} elsif ($lcfg{helo} =~ /^$addr2$/i) {
$hit = "$lcfg{sender}!$lcfg{helo}";
$log = "sender_helo";
} elsif ($lcfg{ip} =~ /^$addr2$/i) {
$hit = "$lcfg{sender}!$lcfg{ip}";
$log = "sender_host";
}
}
} elsif ($et =~ /^S(?:ender)?$/i) {
#address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'S(ender)?');
if ($lcfg{sender} =~ /^$addr$/i) {
$hit = $lcfg{sender};
$log = "mail_from";
}
} elsif ($et =~ /^H(?:ost)?$/i) {
#address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'H(ost)?');
if (($lcfg{plain} && $lcfg{hostname} eq $addr) ||
(!$lcfg{plain} && $lcfg{hostname} =~ /^$addr$/i)) {
$hit = $lcfg{hostname};
$log = "host";
} elsif (($lcfg{plain} && $lcfg{helo} eq $addr) ||
(!$lcfg{plain} && $lcfg{helo} =~ /^$addr$/i)) {
$hit = $lcfg{helo};
$log = "helo";
} elsif (($lcfg{plain} && $lcfg{from} eq $addr) ||
(!$lcfg{plain} && $lcfg{from} =~ /^$addr$/i)) {
$hit = $lcfg{from};
$log = "from";
} elsif (($lcfg{plain} && $lcfg{ip} eq $addr) ||
(!$lcfg{plain} && $lcfg{ip} =~ /^$addr$/i)) {
$hit = $lcfg{ip};
$log = "host";
} elsif (($lcfg{plain} && $lcfg{sender} eq $addr) ||
(!$lcfg{plain}&& $lcfg{sender} =~ /^$mp$addr$/i)) {
$hit = $lcfg{sender};
$log = "mail_from";
}
} elsif ($et =~ /^R(?:elay)?$/i) {
#address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'R(elay)?');
if (($lcfg{plain} && $lcfg{ip} eq $addr) ||
(!$lcfg{plain} && $lcfg{ip} =~ /^$addr$/i)) {
$hit = $lcfg{ip};
$log = "host";
}
} elsif ($et =~ /^He(?:ll?o)?$/i) {
#address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'He(ll?o)?');
if (($lcfg{plain} && $lcfg{helo} eq $addr) ||
(!$lcfg{plain} && $lcfg{helo} =~ /^$addr$/i)) {
$hit = $lcfg{helo};
$log = "helo";
}
} elsif ($et =~ /^(?:To?|R(?:[ce]|cpt|ecipient))$/i) {
#address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'R(cpt|ecipient)?');
if ($lcfg{recipients}) {
foreach my $val (@{$lcfg{recipients}}) {
next unless (address_strip($val) =~ /^$addr$/i);
$hit = $val;
$log = 'rcpt';
last;
}
}
} elsif ($et =~ /^B(?:ounc(?:e|es|ing)|nc)?$/i) {
#debug_log(0,'CAL Bounce ?');
if ((defined($lcfg{sender}) && $lcfg{sender} eq '') &&
($lcfg{recipients} && (@{$lcfg{recipients}} == 1)) &&
(address_strip($lcfg{recipients}->[0]) =~ /^$addr$/i) &&
out_check_for_bounce($ip,$lcfg{recipients}->[0])) {
debug_log(0,'CAL Bounce ! <> <%s> ~ %s',$lcfg{recipients}->[0],$addr);
$hit = $lcfg{recipients}->[0];
$log = 'bounce';
}
} elsif ($et =~ /^Hash$/i) {
debug_log(0,"aldbg $lcfg{comment} # $lcfg{hash} $addr");
address_list_log('check_address_list + "%s"=~"%s%s"',$et,$lcfg{prefix},'Hash');
if ($lcfg{hash} eq $addr) {
$hit = $lcfg{hash};
$log = "hash";
}
} elsif ($et =~ /^M(?:ulti)?$/i) {
#debug_log(0,'AL Multi L %s',$addr);
address_list_log('check_address_list + "%s"=~"%s%s"',$et,$lcfg{prefix},'M(ulti)?');
my @hits = ();
my $miss = 0;
foreach my $mon (split(/\s+/,$addr)) {
#debug_log(0,'AL Multi T %s',$mon);
my ($var,$val,$tst,$rev,$asv);
if ($mon =~ /^(\!)(.*)$/) {
$rev = $1;
$mon = $2;
}
if ($mon =~ /^([-_A-Za-z0-9]+):(.*)$/) {
$var = $1;
$tst = $2;
$val = ($lcfg{entity} && $lcfg{entity}->head) ? $lcfg{entity}->head->get($var) : undef;
if (defined($val)) {
$val =~ s/[\s\r\n]+/ /gs;
$val =~ s/^\s+//;
$val =~ s/\s+$//;
}
$var .= ':';
address_list_log('check_address_list + multi H %s "%s" /^%s$/',$var,$val,$tst);
} elsif ($mon =~ /^([-_A-Za-z0-9]+)=(.*)$/) {
$var = $1;
$tst = $2;
address_list_log('check_address_list + multi v %s "%s"',$var,$tst);
if ($var =~ /^R(?:elay)?$/i) {
$val = address_strip($lcfg{ip});
$var = 'relay';
} elsif ($var =~ /^S(?:ender)?$/i) {
$val = address_strip($lcfg{sender});
$var = 'sender';
} elsif ($var =~ /^H(?:ost)?n?(?:ame)?$/i) {
$val = address_strip($lcfg{hostname});
$var = 'host';
} elsif ($var =~ /^He(?:ll?o)?$/i) {
$val = address_strip($lcfg{helo});
$var = 'helo';
} elsif ($var =~ /^(?:To?|R(?:[ce]|cpt|ecipient))$/i) {
$val = [];
foreach $vlc (@{$lcfg{recipients}}) {
#debug_log(0,'AL Multi v rcpt:%s',$vlc);
push @{$val}, address_strip($vlc);
}
$var = 'rcpt';
} else {
$var = lc($var);
if (defined($lcfg{$var})) {
$val = $lcfg{$var};
} else {
$miss ++;
last;
}
}
$var .= '=';
address_list_log('check_address_list + multi V %s "%s" /^%s$/',$var,$val,$tst);
}
#debug_log(0,'AL Multi V rev:%s tst:%s var:%s val:%s',
# !defined($rev) ? '-' : $rev,
# !defined($tst) ? '-' : "/^$tst\$/i",
# !defined($var) ? '-' : $var,
# !defined($val) ? '-' : !ref($val) ? $val : ref($val) ne 'ARRAY' ? ref($val) : join('; ',@{$val}),
#);
if ($rev && !(defined($val) && $val ne '')) {
$miss ++;
last;
}
if ((ref($val) eq '') && ($rev xor ((!defined($val) && $tst eq '') || ($val =~ /^$tst$/i)))) {
push @hits, "$rev$var$val";
address_list_log('check_address_list + multi * %s "%s" /^%s$/',$var,$val,$tst);
next;
}
if (ref($val) eq 'ARRAY') {
if (!@{$val} && ($rev xor ($tst eq ''))) {
push @hits, "$rev$var$val";
address_list_log('check_address_list + multi * %s "%s" /^%s$/',$var,$val,$tst);
next;
}
my $ahit = 0;
foreach my $vali (@{$val}) {
next unless ($rev xor (address_strip($vali) =~ /^$tst$/i));
address_list_log('check_address_list + multi * %s "%s" /^%s$/',$var,$vali,$tst);
push @hits, "$rev$var$vali";
$ahit ++;
last;
}
next if ($ahit);
}
$miss ++;
last;
}
#debug_log(0,'AL Multi %s %i %s',$miss?'M':@hits?'H':'R',$miss,join(' & ',@hits));
if (@hits && !$miss) {
debug_log(0,'AL Multi H %s',join(' & ',@hits));
$hit = join(' & ',@hits);
$log = 'multi';
}
}
if ($hit ne '') {
address_list_log('check_address_list HIT %s @ %s %s',$lcfg{comment}?$lcfg{comment}:'-',$log,$hit);
$retval = ($retval ? 0 : 1) if ($lcfg{reverse});
return ($retval,$hit,$log);
}
}
}
}
return (0,$hit,$log);
}
# Checks against a list of addresses.
sub check_address_list_filtered {
return (0,"","") unless (@_);
my %lcfg = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
# All lines where the first parameter does not match $filter will be stripped.
# The remaining stuff will be handle by check_address_list above.
return (0,"","") if (!($lcfg{list} && @{$lcfg{list}}));
my @flst = ();
foreach $l (@{$list}) {
my $line = $l;
debug_log(4,"FLineX: '$line'");
$line =~ s/^(\n?\s*)(.*)(\s*\n?)$/$2/;
if (defined($line) && $line ne "") {
debug_log(4,"FLineL: '$line'");
if ($line =~ /^(\S+)\s+(.*?)$/) {
my $x = $1;
my $l = $2;
if ($x =~ /^(!\s*)(.*)$/) {
$l = "$1$l";
$x = $2;
}
debug_log(4,"FLineT: '$x' = '$lcfg{filter}' ?");
if ($lcfg{filter} =~ /^$x$/i) {
debug_log(3,"FLineA: '$l'");
push @flst, $l;
}
}
}
}
return (0,"","") unless (@flst);
$lcfg{list} = \@flst;
return check_address_list(\%lcfg);
}
# Read file into array (with cache)
%listcache = ();
sub get_file_path_name_and_fx {
my ($fn,$match,$noclean) = @_;
my $vfn = get_file_path_name($fn);
my $id = sprintf("%s:%i:%s",$match,$noclean,$fn);
my $fx = '!';
if ($vfn && (-f $vfn)) {
my @fs = stat(_);
$fx = join(';',$fs[0],$fs[1],$fs[7],$fs[9],$vfn);
}
return ($vfn,$id,$fx);
}
sub read_list_file {
my ($fn,$match,$noclean) = @_;
my ($vfn,$id,$fx) = get_file_path_name_and_fx($fn,$match,$noclean);
#debug_log(0,'read_list_file c %s %s %s %s',$fn,$vfn,$fx,$listcache{$id}{x}) if ($listcache{$id});
return $listcache{$id}{d} if (defined($listcache{$id}) && $listcache{$id}{x} eq $fx);
address_list_log('read_list_file %s %s %s %s',$fn,$vfn,$id,$fx);
#debug_log(0,'read_list_file c %s %s',$fn,$fx);
#debug_log(0,'read_list_file r %s',$vfn) unless ($fx eq '!');
$listcache{$id}{x} = $fx;
$listcache{$id}{d} = ($fx eq '!') ? undef : read_a_file($vfn,$match,$noclean);
#debug_log(0,'read_list_file R %s %u',$vfn,scalar @{$listcache{$id}{d}}) unless ($fx eq '!');
return $listcache{$id}{d};
}
sub list_file_changed {
my ($fn,$match,$noclean) = @_;
my ($vfn,$id,$fx) = get_file_path_name_and_fx($fn,$match,$noclean);
return 1 if (defined($listchache{$id}) && $listcache{$id}{x} ne $fx);
return 0;
}
sub read_text_file {
my ($fn) = @_;
return read_list_file($fn,0,1);
}
sub read_delivery_file {
my $ldal = read_list_file(@_);
#debug_log(0,'read_delivery_file: %s',@_);
return undef unless ($ldal);
my @dl = ();
for my $lda (@{$ldal}) {
#debug_log(0,'read_delivery_file? %s',$lda);
next unless ($lda =~ /^(\S+)([-+=>\s]+)(.+)$/);
my $ai = {a=>$1,w=>$2,d=>$3};
$ai->{w} =~ s/\s+//gs;
$ai->{w} = '=' unless ($ai->{w});
if ($ai->{d} =~ /\/$/) {
$ai->{d} =~ s/\/+$//;
$ai->{f} = 'd';
} else {
next;
}
debug_log(7,'read_delivery_file! "%s" "%s" "%s:%s"',$ai->{a},$ai->{w},$ai->{f},$ai->{d});
push @dl, $ai;
}
return \@dl;
}
# Check if recipient(s) address is in white list
sub check_recipient_white ($$) {
my ($what,$addr) = @_;
#my $cfdata = read_list_file('/etc/mail/recipient-whitelist');
my $cfdata = read_list_file('recipient-whitelist');
return check_mail_address_list($what,$addr,$cfdata)
}
sub check_recipients_white ($$) {
my ($what,$addrs) = @_;
return 0 if (!($addrs && @{$addrs}));
#my $cfdata = read_list_file('/etc/mail/recipient-whitelist');
my $cfdata = read_list_file('recipient-whitelist');
foreach my $addr (@{$addrs}) {
return 0 unless (check_mail_address_list($what,$addr,$cfdata));
}
return 1;
}
# Check if sender address is in white list
sub check_sender_white ($$) {
my ($what,$addr) = @_;
#my $cfdata = read_list_file('/etc/mail/sender-whitelist');
my $cfdata = read_list_file('sender-whitelist');
return check_mail_address_list($what,$addr,$cfdata)
}
# Check if listed as a mail backup
sub check_mail_backup($$) {
my ($ip,$hostname) = @_;
#my $cfdata = read_list_file('/etc/mail/mimedefang-backups');
my $cfdata = read_list_file('backups');
my ($found,$hit,$log) = check_address_list(
format => 'L',
ip => $ip,
hostname => $hostname,
list => $cfdata,
comment => 'backup',
);
return 1 if ($found);
return 0;
}
# Check if whitelisted in whitelist file
sub check_external_whitelist {
my ($ip,$hostname,$sender) = @_;
return 1 if (check_mail_backup($ip,$hostname));
#my $cfdata = read_list_file('/etc/mail/mimedefang-whitelist');
my $cfdata = read_list_file('whitelist');
my ($found,$hit,$log) = check_address_list(
format => 'L',
ip => $ip,
hostname => $hostname,
sender => $sender,
list => $cfdata,
comment => 'whitelist',
);
return 1 if ($found);
return 0;
}
# Check if blacklisted in blacklist file
sub check_external_blacklist {
my ($ip,$hostname,$helo,$from,$sender) = @_;
#my $cfdata = read_list_file('/etc/mail/mimedefang-blacklist');
my $cfdata = read_list_file('blacklist');
my($found,$hit,$log) = check_address_list(
format => 'L',
ip => $ip,
hostname => $hostname,
helo => $helo,
from => $from,
sender => $sender,
list => $cfdata,
comment => 'blacklist',
);
return ($found,$hit,$log);
return (0,"","");
}
# Check if whitelisted in whitelist-by-recipient file
sub check_external_whitelist_by_recipient($$$$$$) {
my ($ip,$hostname,$helo,$from,$sender,$recipient) = @_;
return 1 if (check_mail_backup($ip,$hostname));
#my $cfdata = read_list_file('/etc/mail/mimedefang-whitelist-by-recipient');
my $cfdata = read_list_file('whitelist');
my %cfinfo = (
format => 'L',
ip => $ip,
hostname => $hostname,
from => $from,
sender => $sender,
recipient => $recipient,
list => $cfdata,
comment => 'whitelist',
);
my ($found,$hit,$log) = check_address_list(%cfinfo);
return 1 if ($found);
$cfdata = read_list_file('whitelist-by-recipient');
$cfinfo{filter} = address_strip($recipient);
$cfinfo{helo} = $helo;
$cfinfo{list} = $cfdata;
$cfinfo{comment} = 'whitelist-by-recipient';
($found,$hit,$log) = check_address_list_filtered(%cfinfo);
return 1 if ($found);
return 0;
}
# Check if blacklisted in blacklist-by-recipient file
sub check_external_blacklist_by_recipient($$$$$$) {
my ($ip,$hostname,$helo,$from,$sender,$recipient) = @_;
#my $cfdata = read_list_file('/etc/mail/mimedefang-blacklist-by-recipient');
my $cfdata = read_list_file('blacklist');
my %cfinfo = (
format => 'L',
ip => $ip,
hostname => $hostname,
helo => $helo,
from => $from,
sender => $sender,
recipient => $recipient,
list => $cfdata,
comment => 'blacklist',
);
my($found,$hit,$log) = check_address_list(%cfinfo);
return ($found,$hit,$log) if ($found);
my $cfdata = read_list_file('blacklist-by-recipient');
$cfinfo{filter} = address_strip($recipient);
$cfinfo{list} = $cfdata;
$cfinfo{comment} = 'blacklist-by-recipient';
($found,$hit,$log) = check_address_list_filtered(%cfinfo);
return ($found,$hit,$log) if ($found);
return (0,"","");
}
# Check if listed in bypass file
sub check_something_bypass {
my ($file,$prefix,$ip,$hostname,$sender,$recipients,$verified,$entity,$hash) = @_;
debug_log(7,'check_something_bypass: %s:%s p %s %s %s',$file,$prefix,$ip,$hostname,$sender);
my $cfdata = read_list_file($file);
my %params = (
format => $prefix ? "L:$prefix" : 'L',
ip => $ip,
hostname => $hostname,
sender => $sender,
recipients => $recipients,
entity => $entity,
hash => $hash,
list => $cfdata,
file => $file
);
my ($found,$hit,$log) = check_address_list(\%params);
if ($found) {
debug_log(1,'check_something_bypass: %s:%s P %s %s',$file,$prefix,$hit,$log);
return 1;
}
return 0 unless ($verified && @{$verified});
$prefix = $prefix ? 'L:'.$prefix.'_' : 'L:';
foreach my $snd (@{$verified}) {
my ($vt,$sndx) = split(/:/,$snd,2);
debug_log(7,'check_something_bypass: %s:%s v %s %s',$file,$prefix,$vt,$sender);
if ($sndx =~ /\@/) {
$params{sender} = $sndx;
} else {
$params{helo} = $sndx;
}
$params{format} = "$prefix$vt";
($found,$hit,$log) = check_address_list(\%params);
unless ($found) {
$params{format} = $prefix.'verified';
($found,$hit,$log) = check_address_list(\%params);
}
if ($found) {
debug_log(1,'check_something_bypass: %s:%s V %s %s',$file,$prefix,$hit,$log);
return 1;
}
}
return 0;
}
# Check if unlisted in bypass file
sub check_something_not_bypass {
my ($file,$prefix,$ip,$hostname,$sender,$recipients,$entity,$hash) = @_;
debug_log(7,'check_something_not_bypass: %s:%s p %s %s %s',$file,$prefix,$ip,$hostname,$sender);
my $cfdata = read_list_file($file);
my %params = (
format => $prefix ? "L:$prefix" : 'L',
ip => $ip,
hostname => $hostname,
sender => $sender,
recipients => $recipients,
entity => $entity,
hash => $hash,
list => $cfdata,
reverse => 1,
file => $file
);
my ($found,$hit,$log) = check_address_list(\%params);
if ($found) {
debug_log(3,'check_something_not_bypass: %s:%s P %s %s',$file,$prefix,$hit,$log);
return 1;
}
return 0 unless ($entity);
my @from = ();
get_addresses_from_header($entity,'Reply-To:From:Sender',\@from);
foreach my $snd (@from) {
debug_log(7,'check_something_not_bypass: %s:%s f %s',$file,$prefix,$snd);
$params{sender} = $snd;
($found,$hit,$log) = check_address_list(\%params);
if ($found) {
debug_log(3,'check_something_not_bypass: %s:%s F %s %s',$file,$prefix,$hit,$log);
return 1;
}
}
return 0;
}
# Check if listed in spamassassin-bypass file
sub check_spamassassin_bypass {
return check_something_bypass('spamassassin-bypass','',@_);
}
# Check if unlisted in spamassassin-bypass file
sub check_spamassassin_not_bypass {
return check_something_not_bypass('spamassassin-bypass','',@_);
}
# Check if listed in virus-bypass file
sub check_virus_bypass {
my ($scanner,$ip,$hostname,$sender,$recipients,$entity,$hash) = @_;
$scanner =~ s/[^a-zA-Z0-9]+//gs;
return 0 if (check_something_not_bypass('virus-bypass','',$ip,$hostname,$sender,$recipients,$entity));
return 0 if ($scanner && check_something_not_bypass('virus-bypass',$scanner,$ip,$hostname,$sender,$recipients,$entity));
return 1 if (check_something_bypass('virus-bypass','',$ip,$hostname,$sender,$recipients,0,$entity));
return 1 if ($scanner && check_something_bypass('virus-bypass',$scanner,$ip,$hostname,$sender,$recipients,0,$entity));
}
sub check_virus_time_exceeded {
my ($ip,$host) = @_;
debug_log(1,"cvte 1: $ip, $host");
return 0 unless ($AVMaxScanTime && ($AVMaxScanTime > 0));
my $t = time() - $ScanStartedAt;
debug_log(1,"cvte 2: $t");
return 0 unless ($t > $AVMaxScanTime);
debug_log(1,"cvte 3");
return 0 unless (check_internal_whitelist($ip) || check_external_whitelist($ip,$host) || check_authenticated());
debug_log(1,'Virus time exceeded: %u > %u',$t,$AVMaxScanTime);
return 1;
}
sub check_virus_entity_no_scan {
my ($entity) = @_;
return 0 unless (check_internal_whitelist($RelayAddr));
return -1 unless ($entity);
my $bdy = $entity->bodyhandle;
return -2 unless ($bdy);
my $path = $entity->bodyhandle->path;
return -3 unless (defined($path));
my $size = (stat($path))[7];
return 0 unless ($size);
return 1 if ($size > $mailtoobig);
return 0;
}
sub check_spam_time_exceeded {
debug_log(1,'cste 1');
return 0 unless ($SAMaxScanTime && ($SAMaxScanTime > 0));
my $t = time() - $ScanStartedAt;
debug_log(1,"cste 2: $t");
return 0 unless ($t > $SAMaxScanTime);
debug_log(1,'Spam time exceeded: %u > %u',$t,$SAMaxScanTime);
return 1;
}
sub check_options_relay {
my ($ip,$helo,$anyone) = @_;
return 0 unless ($RelayOptionsDomain);
return 0 unless ($anyone || check_internal_whitelist($ip));
if ($helo =~ /^(|.*\.)$RelayOptionsDomain$/i) {
return $1 if ($1);
return '-';
}
return 0;
}
sub check_relay_option_ex {
my $ip = shift;
my $helo = shift;
my $anyone = shift;
my $optl = check_options_relay($ip,$helo,$anyone);
$optl =~ s/[-_]//g;
debug_log(1,'Relay Options: %s',$optl);
return 0 unless ($optl);
while (my $o = shift @_) {
next unless ($o);
debug_log(1,'Relay Option Check: %s',$o);
if ($optl =~ /^(|.*\.)$o(|\..*)$/i) {
debug_log(1,'Relay Option True: %s',$o);
return 1;
}
}
return 0;
}
sub check_relay_option {
my $ip = shift;
my $helo = shift;
return check_relay_option_ex($ip,$helo,0,@_);
}
sub check_any_relay_option {
my $helo = shift;
return check_relay_option_ex('0.0.0.0',$helo,1,@_);
}
sub check_user_in_domain {
my $usr = address_strip(shift @_);
my $dom = $usr;
$usr =~ s/\@[^@]*$//;
$dom =~ s/^.*\@//;
my $cfdata = read_list_file("users\@$dom");
return (0,0) unless (defined($cfdata));
debug_log(7,'check_user_in_domain ? %s %s',$usr,$dom);
my $delim = chr(0);
my $default = 0;
my $definitive = 1;
foreach my $l (@{$cfdata}) {
my $line = $l;
$line =~ s/[\r\n\s]+$//;
$line =~ s/^\s+//;
next if ($line =~ /^[;#]/);
if ($l =~ /^\s*\@(.*)$/) {
my $c = $1;
next unless ($c =~ /^\s*(\S+)[\s=:]+(.*)$/);
my $v = $2;
$c = lc($1);
if ($c eq 'delimiter') {
$delim = $v;
} elsif ($c eq 'default') {
$default = $v;
} elsif ($c eq 'definitive') {
$definitive = $v;
}
next;
}
debug_log(5,'check_user_in_domain l %s %s %s',$usr,$dom,$line);
my $retval = 1;
if ($line =~ /^!\s*(.*)$/) {
$retval = 0;
$line = $2;
}
$line =~ s/$delim.*$//;
debug_log(5,'check_user_in_domain c %s %s %s',$usr,$dom,$line);
next unless ($usr =~ /^$line$/i);
debug_log(3,'check_user_in_domain + %s %s %i',$usr,$dom,$retval);
return ($retval?$definitive:1,$retval);
}
debug_log(7,'check_user_in_domain - %s %s',$usr,$dom);
return ($default?$definitive:1,$default);
}
#***********************************************************************
# RelayDB stuff.
#***********************************************************************
# Check if blacklisted by relaydb
sub check_relay_blacklist {
my ($ip,$what) = @_;
return (0,'','') unless ($ip);
return (0,'','') unless ($relaydb);
return (0,'','') unless (defined($rdb_ratio) || $rdb_min_black);
$what = 'relay' unless ($what);
debug_log(3,"check_relay_blacklist: a:$ip");
my $rinf = sql_select_one_row('SELECT rl_touch,rl_spam,rl_ham FROM relaylist WHERE rl_host=?',$ip);
debug_log(3,"check_relay_blacklist: ap:$ip t:%s s:%s h:%s",$rinf->[0],$rinf->[1],$rinf->[2]);
return (0,'','') unless ($rinf && $rinf->[0]);
return (0,'','') unless (($rdb_expire<=0) || ($rinf->[0] > time()-$rdb_expire));
$rinf->[1] = 0 unless ($rinf->[1]);
$rinf->[2] = 0 unless ($rinf->[2]);
return (0,'','') unless (($rdb_min_black<0) || ($rinf->[1] && ($rinf->[1] >= $rdb_min_black)));
return (0,'','') unless (($rdb_max_white<0) || !$rinf->[2] || $rinf->[2] <= $rdb_max_white);
if ($rdb_ratio > -1) {
return (1,$ip,$what) if ($rinf->[2] == 0 && $rinf->[1] > 0);
return (1,$ip,$what) if ($rinf->[1]/$rinf->[2] > $rdb_ratio);
return (0,'','');
}
return (1,$ip,$what);
}
# Check if relay has sent spam
sub check_relay_spam {
my ($ip) = @_;
return 0 unless ($ip);
return 0 unless ($relaydb);
my $rinf = sql_select_one_row('SELECT rl_touch,rl_spam FROM relaylist WHERE rl_host=?',$ip);
return 0 unless ($rinf && $rinf->[0] && $rinf->[1]);
return 0 unless (($rdb_expire<=0) || ($rinf->[0] > time()-$rdb_expire));
return $rinf->[1];
}
# Report to relaydb
sub report_address_relay_xam {
my ($xam,$ip) = @_;
my $now = time();
if ($sqldbd eq 'M') {
sql_execute("INSERT INTO relaylist (rl_host,rl_stamp,rl_touch,rl_$xam) VALUES(?,?,?,?) ".
"ON DUPLICATE KEY UPDATE rl_stamp=VALUES(rl_stamp),rl_touch=VALUES(rl_touch),rl_$xam=rl_$xam+1",
$ip,$now,$now,1);
} else {
sql_execute_multi(
['INSERT OR IGNORE INTO relaylist (rl_host) VALUES (?)',$ip],
["UPDATE relaylist SET rl_stamp=?,rl_touch=?,rl_$xam=rl_$xam+1 WHERE rl_host=?",$now,$now,$ip],
);
}
}
sub report_address_relay($$) {
my ($ip,$hits) = @_;
return unless ($relaydb);
return unless (defined($rdb_ratio) || $rdb_min_black);
if ($hits > $rdb_black_list) {
debug_log(3,"report_relay: spam $ip");
report_address_relay_xam('spam',$ip);
} elsif ($hits < $rdb_white_list) {
debug_log(3,"report_relay: ham $ip");
report_address_relay_xam('ham',$ip);
} elsif ($rdb_stamp_grey) {
debug_log(3,"report_relay: grey stamp $ip");
my $now = time();
sql_execute('UPDATE relaylist SET rl_stamp=?,rl_touch=? WHERE rl_host=?',$now,$now,$ip);
} elsif ($rdb_touch) {
debug_log(3,"report_relay: grey touch $ip");
my $now = time();
sql_execute('UPDATE relaylist SET rl_touch=? WHERE rl_host=?',$now,$ip);
}
}
sub report_address_relay_spam($) {
my ($ip) = @_;
return unless ($relaydb);
return unless (defined($rdb_ratio) || $rdb_min_black);
my $now = time();
debug_log(3,"report_relay: spam $ip");
report_address_relay_xam('spam',$ip);
}
sub report_address_relay_virus($) {
my ($ip) = @_;
return unless ($relaydb);
return unless ($rdb_virus);
my $now = time();
debug_log(0,"report_relay: virus $ip");
report_address_relay_xam('spam',$ip);
}
# Report verified address to relaydb
sub report_verified_relay {
my ($verified,$hits) = @_;
return unless ($rdb_sender || $rdb_domain);
return unless ($verified && @{$verified});
debug_log(3,'report_verified: %03.1f %s',$hits,join(' ',@{$verified}));
foreach my $snd (@{$verified}) {
if ($snd =~ /^(SPF|DKIM|DK|DomainKey):(.*)$/i) {
my $sa = address_strip($2);
if ($sa =~ /^.*\@(.+)$/) {
report_address_relay($1,$hits) if ($rdb_domain);
report_address_relay($sa,$hits) if ($rdb_sender);
} else {
report_address_relay($sa,$hits) if ($rdb_domain);
}
}
}
}
sub report_relay($$$) {
my ($ip,$verified,$hits) = @_;
report_address_relay(address_strip($ip),$hits);
report_verified_relay($verified,$hits);
}
# Update relaydb stamp for IP address
sub touch_relay($) {
my ($ip) = @_;
return unless ($relaydb);
return unless ($rdb_touch);
return unless (defined($rdb_ratio) || $rdb_min_black);
my $now = time();
debug_log(3,"report_relay: touch $ip");
sql_execute('UPDATE relaylist SET rl_touch=? WHERE rl_host=?',$now,$ip);
}
# Check if sender blacklisted by relaydb
sub check_sender_blacklist {
my $sender = address_strip(shift);
return (0,'','') unless ($sender);
my ($bad,$hit,$log) = (0,'','');
($bad,$hit,$log) = check_relay_blacklist($sender,'sender') if ($rdb_sender);
if ($rdb_domain && !$bad) {
$sender =~ s/^.*\@//;
($bad,$hit,$log) = check_relay_blacklist($sender,'domain');
}
return ($bad,$hit,$log);
}
# Checks a relay against the blacklists
sub check_relay($$$$$$) {
my($msgid,$ip,$hostname,$failcode,$log_prepend,$from_received) = @_;
# Check if blacklisted by relaydb
my ($bad,$hit,$log) = check_relay_blacklist($ip);
if ($bad) {
touch_relay($ip) if (defined($rdb_touch) && $rdb_touch);
debug_log(3, $log_prepend."check_relay: Blacklisted by relaydb, $hostname [$ip], " . $log);
#return ('CONTINUE', "We currently do not want mail from $hit, but go head anyway.");
#md_syslog('info', "MDLOG,$msgid,$log_prepend$hit,$log,?,?,?");
if ($from_received) {
stats_log(lc($failcode),"$log_prepend$log",$hit);
} else {
stats_log(lc($failcode),"$log_prepend$log",[$hit,$ip,$hostname,$msgid]);
}
return ($failcode, make_answer('Denied',"At the moment we do not want mail from $hit."));
}
return ('CONTINUE', "Ok, go ahead.");
}
#***********************************************************************
# NoSPamDB stuff.
#***********************************************************************
# Get the no spam count
sub get_no_spam_count {
my ($ip) = @_;
return 0 unless ($ip);
return 0 unless ($nospamdb);
debug_log(3,"get_no_spam_count: a:$ip");
my $rinf = sql_select_one_row('SELECT ns_touch,ns_count FROM nospamlist WHERE ns_host=?',$ip);
debug_log(3,"get_no_spam_count: ap:$ip t:%s r:%s",$rinf->[0],$rinf->[1]);
return 0 unless ($rinf && $rinf->[0]);
return 0 unless ($rinf->[1] && $rinf->[1] != 0);
return 0 unless (($nsdb_remember_spam && ($rinf->[1]<0)) || ($nsdb_expire<=0) || ($rinf->[0] > time()-$nsdb_expire));
debug_log(3,"check_address_no_spam_has_spam: ap:$ip r:%s",$rinf->[1]);
return $rinf->[1];
}
# Report address to nospamdb
sub report_address_no_spam($$$) {
my ($ip,$hits,$count) = @_;
return unless ($nospamdb);
return unless ($count);
return unless ($hits eq 'spam' || $hits < $nsdb_white_list || $hits > $nsdb_black_list);
return if ($nsdb_remember_spam && (get_no_spam_count($ip) < 0));
my $now = time();
if ($hits eq 'spam' || $hits > $nsdb_black_list) {
debug_log(3,"report_address_no_spam: spam $ip");
if ($nsdb_remember_spam) {
debug_log(3,"report_address_no_spam: remember spam $ip");
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO nospamlist (ns_host,ns_stamp,ns_touch,ns_count) VALUES (?,?,?,?) '.
'ON DUPLICATE KEY UPDATE ns_stamp=VALUES(ns_stamp),ns_touch=VALUES(ns_touch),ns_count=VALUES(ns_count)',
$ip,$now,$now,-1);
} else {
sql_execute_multi(
['INSERT OR IGNORE INTO nospamlist (ns_host) VALUES (?)',$ip],
['UPDATE nospamlist SET ns_stamp=?,ns_touch=?,ns_count=? WHERE ns_host=?',$now,$now,-1,$ip],
);
}
} else {
debug_log(3,"report_address_no_spam: spam $ip");
sql_execute('UPDATE nospamlist SET ns_stamp=?,ns_touch=?,ns_count=? WHERE ns_host=?',$now,$now,0,$ip);
}
} elsif ($hits < $nsdb_white_list) {
debug_log(3,"report_address_no_spam: ham $ip");
sql_execute_multi(
['INSERT OR IGNORE INTO nospamlist (ns_host) VALUES (?)',$ip],
['UPDATE nospamlist SET ns_stamp=?,ns_touch=?,ns_count=ns_count+1 WHERE ns_host=? AND ns_count>=0',$now,$now,$ip],
);
}
}
# Report verified address to nospam db
sub report_verified_no_spam {
my ($verified,$hits) = @_;
return unless ($nospamdb);
return unless ($verified && @{$verified});
foreach my $snd (@{$verified}) {
if ($snd =~ /^(SPF|DKIM|DK|DomainKey):(.*)$/i) {
my $sa = address_strip($2);
if ($sa =~ /^.*\@(.+)$/) {
report_address_no_spam($1,$hits,$nsdb_domain_count);
report_address_no_spam($sa,$hits,$nsdb_sender_count);
} else {
report_address_no_spam($sa,$hits,$nsdb_domain_count);
}
}
}
}
# Report to nospamdb
sub report_no_spam {
my ($ip,$verified,$hits) = @_;
return unless ($nospamdb);
debug_log(3,'report_no_spam: %03.1f %s %s',$hits,$ip,join(' ',@{$verified}));
report_address_no_spam($ip,$hits,$nsdb_relay_count);
report_verified_no_spam($verified,$hits);
#foreach my $hpn (get_hosts_parts_names($ip)) {
# debug_log(0,'report_no_spam: %f hpn %s %s',$hits,$ip,$hpn);
#}
}
sub report_no_spam_spam {
my ($ip) = @_;
return unless ($nospamdb);
debug_log(3,'report_no_spam: spam %s',$ip);
report_address_no_spam($ip,'spam',$nsdb_relay_count);
}
# Check if address white listed by nospamdb
sub check_address_no_spam {
my ($ip,$count) = @_;
return 0 unless ($nospamdb);
return 0 unless ($ip);
return 0 unless ($count && $count>0);
my $nsc = get_no_spam_count($ip);
return 0 unless ($nsc > $count);
debug_log(1,"check_address_no_spam: ap:$ip true");
return 1;
}
# Get the no spam status for addresses
sub get_no_spam_bad {
foreach my $ip (@_) {
#debug_log(0,'get_no_spam_bad a %s',$ip);
my $r = get_no_spam_count($ip);
return 1 if ($r < 0);
next unless ($ip =~ /\@/);
my $ad = $ip;
$ad =~ s/^.*\@//;
#debug_log(0,'get_no_spam_bad d %s',$ip);
$r = get_no_spam_count($ad);
return 1 if ($r < 0);
}
#debug_log(0,'get_no_spam_bad %s',join(' ',@_));
return 0;
}
# Get the no spam counts for addresses
sub get_no_spam_counts {
my ($min,$max);
foreach my $ip (@_) {
my $r = get_no_spam_count($ip);
$min = $r if (!defined($min) || $r<$min);
$max = $r if (!defined($max) || $r>$max);
next unless ($ip =~ /\@/);
my $ad = $ip;
$ad =~ s/^.*\@//;
$r = get_no_spam_count($ad);
$min = $r if (!defined($min) || $r<$min);
$max = $r if (!defined($max) || $r>$max);
}
return ($min,$max);
}
# Checks if verified sender should bypass SpamAssassin
sub check_verified_no_spam {
my ($verified,$all) = @_;
return 0 unless ($nospamdb);
return 0 unless ($verified && @{$verified});
debug_log(3,'check_verified_no_spam: %u %u %s',$nsdb_sender_count,$nsdb_domain_count,join(' ',@{$verified}));
my $nsc = 0;
foreach my $snd (@{$verified}) {
if ($snd =~ /^(SPF|DKIM|DK|DomainKey):(.*)$/i) {
my $sa = address_strip($2);
if ($sa =~ /^.*\@(.+)$/) {
$nsc ++ if (check_address_no_spam($1,$nsdb_domain_count));
return 1 if ($nsc && !$all);
return 0 if ($all && !$nsc);
$nsc ++ if (check_address_no_spam($sa,$nsdb_sender_count));
} else {
$nsc ++ if (check_address_no_spam($sa,$nsdb_domain_count));
}
return 1 if ($nsc && !$all);
return 0 if ($all && !$nsc);
}
}
return 1 if ($nsc);
return 0;
}
# Check if white listed by nospamdb
sub check_no_spam {
my ($ip,$verified,$all) = @_;
my $nsi = check_address_no_spam($ip,$nsdb_relay_count);
return 1 if ($nsi && !$all);
return 0 if ($all && !$nsi);
return check_verified_no_spam($verified,$all);
}
#***********************************************************************
# Spam Hash DB stuff
#***********************************************************************
sub remember_spam_hash {
my ($hash,$report) = @_;
return unless ($spamdb && $hash && $report);
my $rcpts = join(',',sort { $a cmp $b } @Recipients);
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO spamresults (spam_hash,spam_sender,spam_recipients,spam_count,spam_stamp,spam_score,spam_required,spam_id) VALUES (?,?,?,?,?,?,?,?) '.
'ON DUPLICATE KEY UPDATE spam_count=spam_count+1,spam_stamp=VALUES(spam_stamp),spam_score=VALUES(spam_score),spam_required=VALUES(spam_required),spam_id=VALUES(spam_id)',
$hash,$Sender,$rcpts,1,time(),sprintf('%i',$report->{hits}*100),sprintf('%i',$report->{req}*100),$SLVars{QI});
} else {
sql_execute_multi(
['INSERT OR IGNORE INTO spamresults (spam_hash,spam_sender,spam_recipients) VALUES (?,?,?)',$hash,$Sender,$rcpts],
['UPDATE spamresults SET spam_count=spam_count+1,spam_stamp=?,spam_score=?,spam_required=?,spam_id=? WHERE spam_hash=? AND spam_sender=? AND spam_recipients=?',
time(),
sprintf('%i',$report->{hits}*100),
sprintf('%i',$report->{req}*100),
$SLVars{QI},$hash,$Sender,$rcpts],
);
}
};
sub check_spam_hashes {
my ($hash) = @_;
return 0 unless ($spamdb && $hash);
my $rcpts = join(',',sort { $a cmp $b } @Recipients);
my $rinf = sql_select_one_row('SELECT spam_stamp,spam_id,spam_score,spam_required FROM spamresults WHERE spam_hash=? AND spam_recipients=? AND spam_sender=?',$hash,$rcpts,$Sender);
return 0 unless ($rinf && @{$rinf});
#sql_execute_multi(['UPDATE spamresults SET spam_count=spam_count+1 WHERE spam_hash=? AND spam_recipients=? AND spam_sender=?',$hash,$rcpts,$Sender]);
my $spam = (time() - $rinf->[0] < $sdb_expire) ? 1 : 0;
$rinf->[2] = sprintf('%03.1f',$rinf->[2]/100);
$rinf->[3] = sprintf('%03.1f',$rinf->[3]/100);
debug_log(0,'check_spam_hashes: <%s> %u %s %s %s %i %i',$rinf->[1],$spam,$hash,$Sender,$rcpts,$rinf->[2],$rinf->[3]);
return ($spam,$rinf->[0],$rinf->[1],$rinf->[2],$rinf->[3]);
}
sub inc_spam_hash {
my ($hash) = @_;
my $rcpts = join(',',sort { $a cmp $b } @Recipients);
sql_execute_multi(['UPDATE spamresults SET spam_count=spam_count+1 WHERE spam_hash=? AND spam_recipients=? AND spam_sender=?',$hash,$rcpts,$Sender]) if ($hash);
}
#***********************************************************************
# Dictionary and Greylisting stuff.
#***********************************************************************
# Add message to list of messages
sub msgl_add {
my $mid = address_strip_nc(shift);
return unless ($mid);
my $spam = shift;
my $sndr = address_strip(shift);
$spam = $spam ? ",msg_spam=?" : '';
my $now = time();
while (@_) {
my $rcpt = address_strip(shift @_);
if ($sqldbd eq 'M') {
if ($spam) {
sql_execute('INSERT INTO messages (msg_id,msg_sender,msg_recipient,msg_stamp,msg_spam) VALUES (?,?,?,?,?) '.
'ON DUPLICATE KEY UPDATE msg_spam=VALUES(msg_spam)',
$mid,$sndr,$rcpt,$now,$now);
} else {
sql_execute('INSERT INTO messages (msg_id,msg_sender,msg_recipient,msg_stamp,msg_count) VALUES (?,?,?,?,?) '.
'ON DUPLICATE KEY UPDATE msg_count=msg_count+1',
$mid,$sndr,$rcpt,$now,1);
}
} else {
sql_execute_multi(
['INSERT OR IGNORE INTO messages (msg_id,msg_sender,msg_recipient,msg_stamp) VALUES (?,?,?,?)',$mid,$sndr,$rcpt,$now],
$spam
? ["UPDATE messages SET msg_spam=? WHERE msg_id=? AND msg_sender=? AND msg_recipient=?",$now,$mid,$sndr,$rcpt]
: ["UPDATE messages SET msg_count=msg_count+1 WHERE msg_id=? AND msg_sender=? AND msg_recipient=?",$mid,$sndr,$rcpt]
);
}
}
}
# Get time since first seen messages
sub msgl_info {
my $mid = address_strip_nc(shift);
return unless ($mid);
my $sndr = address_strip(shift);
my $now = time();
my @r = ();
while (@_) {
my $rcpt = address_strip(shift @_);
my $msgf = sql_select_one_row('SELECT msg_stamp,msg_count FROM messages WHERE msg_id=? AND msg_sender=? AND msg_recipient=?',$mid,$sndr,$rcpt);
next unless ($msgf && $#$msgf > 0 && $msgf->[0] && $msgf->[1]);
push @r, {r=>$rcpt,t=>$msgf->[0],e=>$now-$msgf->[0],c=>$msgf->[1]};
}
return sort { $a->{c} <=> $b->{c} } @r if (@r);
return @r;
}
# Get time since first seen messages
sub msgl_info_str {
my @mi = msgl_info(@_);
return '' unless (@mi);
my @rs = ();
my %rs = ();
foreach my $mri (@mi) {
my $rs = sprintf('%u,%s',$mri->{c},time_string($mri->{e},1));
next if ($rs{$rs});
$rs{$rs} = 1;
push @rs, $rs;
}
return join('; ',@rs);
}
sub msgl_spam {
my $mid = address_strip_nc(shift);
return unless ($mid);
my $sndr = address_strip(shift);
my $r = 0;
my $n = 0;
my $t = 0;
my $age = $SARemember ? time()-$SARemember : 0;
while (@_) {
my $rcpt = address_strip(shift @_);
my $spam = sql_select_one('SELECT msg_spam FROM messages WHERE msg_id=? AND msg_sender=? AND msg_recipient=?',$mid,$sndr,$rcpt);
unless ($spam) {
$n ++;
next;
}
debug_log(0,'msgl_spam a %s %u %u',$mid,$age,$spam);
$n ++ if ($age == 0 || $spam<$age);
$t = $spam if ($spam>$t);
$r ++;
}
$r = -$r if ($n);
debug_log(1,'msgl_spam r %s %i %u',$mid,$r,$t);
return ($r,$t);
}
sub out_subject {
my $subj = decode_header(join(' ',@_));
$subj =~ s/[^\x20-\x7E]/?/g;
$subj =~ s/^(?:\[\S+\]\s*)?(?:\S{1,5}:\s*)?(?:\[\S+\]\s*)?(\S)/$1/;
return $subj;
}
sub out_add {
my $entity = shift;
my $sender = shift;
return unless ($sentoutdb);
return unless ($entity && $entity->head);
my $now = time();
my $id = address_strip_nc($entity->head->get('Message-Id'));
my $subj = out_subject($entity->head->get('Subject'));
my @from = ();
push @from, address_strip($sender);
get_addresses_from_header($entity,'Reply-To:From',\@from,'lc');
my @sql = ();
my %rh = ();
while (@_) {
my $rcpt = address_strip(shift @_);
next if ($rcpt =~ /\@$OurDomains>?$/i);
next if ($rh{$rcpt});
$rh{$rcpt} = 1;
my $rcptu = $rcpt;
my $rcptd = '';
if ($rcptu =~ /^(.*)\@(.*?)$/) {
$rcptd = $2;
$rcptu = $1;
}
my %fh = ();
foreach my $from (@from) {
next unless ($from =~ /\@$OurDomains>?$/i);
next if ($fh{$from});
$fh{$from} = 1;
push @sql, ['INSERT INTO sentout (out_id,out_sender,out_rcpt_usr,out_rcpt_dom,out_subject,out_stamp) VALUES (?,?,?,?,?,?)',
$id,$from,$rcptu,$rcptd,$subj,$now];
}
}
sql_execute_multi(@sql) if (@sql);
}
sub out_check_for_bounce {
my ($relay,$recipient) = @_;
return 1 if (check_internal_whitelist($relay));
return 0 unless ($recipient =~ /\@$OurDomains>?$/i);
return 1 if (sql_select_one("SELECT out_stamp FROM sentout WHERE (out_sender=?) AND (out_stamp>?) LIMIT 1",
address_strip($recipient),$out_expire ? time() - $out_expire : 0));
return 0;
}
sub out_check {
my $head = shift;
my $sender = shift;
return 0 unless ($sentoutdb);
return 0 unless ($head);
if ($head =~ /^(?:MIME::Entity|Mail::Internet)=/) {
$head = $head->head;
return 0 unless ($head);
}
my $now = time();
my $et = 0;
$et = $now-$out_expire if ($out_expire);
my @from = ();
get_addresses_from_value($sender,\@from,'all') if ($sender);
get_addresses_from_header($head,'From:Sender:Reply-To',\@from,'all');
my @domp = ();
my $domq = '';
my @usrp = ();
my $usrq = '';
my %xq = ();
my %yq = ();
foreach my $fi (@from) {
if ($fi->{domain} && !$xq{$fi->{domain}}) {
$xq{$fi->{domain}} = 1;
$domq .= ' OR ' if ($domq);
$domq .= 'out_rcpt_dom=?';
push @domp, $fi->{domain};
}
next unless ($fi->{user});
my $ud = sprintf('%s@%s',$fi->{user},$fi->{domain});
next if ($yq{$ud});
$yq{$ud} = 1;
$usrq .= ' OR ' if ($usrq);
$usrq .= '(out_rcpt_dom=? AND out_rcpt_usr=?)';
push @usrp, $fi->{domain};
push @usrp, $fi->{user};
}
my @top = ();
my $toq = '';
%xq = ();
while (@_) {
my $rcpt = address_strip(shift @_);
next unless ($rcpt);
next if ($xq{$rcpt});
$xq{$rcpt} = 1;
$toq .= ' OR ' if ($toq);
$toq .= 'out_sender=?';
push @top, $rcpt;
}
my @idp = ();
my $idq = '';
%xq = ();
foreach my $hn(('References','In-Reply-To')) {
my @hl = $head->get($hn);
next unless (@hl);
foreach my $hv (@hl) {
foreach my $hid (split(/\s+/,$hv)) {
next unless ($hid =~ /^\s*<.*>\s*$/);
$hid = address_strip_nc($hid);
next unless ($hid);
next if ($xq{$hid});
$xq{$hid} = 1;
$idq .= ' OR ' if ($idq);
$idq .= 'out_id=?';
push @idp, $hid;
}
}
}
return 0 unless ($domq && $toq);
if ($idq) {
my $cc = sql_select_one("SELECT out_stamp FROM sentout WHERE ($idq) AND ($domq) AND ($toq) AND (out_stamp>?) LIMIT 1",
@idp,@domp,@top,$et);
debug_log(2,'out_check: %u - (%s) AND (%s) AND (%s)',$cc,$idq,$domq,$toq);
return 1 if ($cc);
}
return 0 unless ($usrq);
my $subj = out_subject($head->get('Subject'));
my $cc = sql_select_one("SELECT out_stamp FROM sentout WHERE ($toq) AND ($usrq) AND (out_subject=?) AND (out_stamp>?) LIMIT 1",
@top,@usrp,$subj,$et);
debug_log(2,'out_check: %u - (%s) AND (%s) AND (out_subject=%s)',$cc,$usrq,$toq,$subj);
return 1 if ($cc);
return 0;
}
# Strip strings for use in the greylist.
sub greylist_strip($) {
my($a) = @_;
#$a =~ s/;/:/g;
return $a;
}
sub greylist_strip_mail($$$) {
my($a,$d,$s) = @_;
$a = address_strip($a);
my $au = $a;
my $ad = $a;
$ad =~ s/.*@([^@]*)$/$1/;
$au =~ s/@[^@]*$//;
if ($d) {
$au = "*";
} elsif ($s) {
$au =~ s/(.+)\+.*$/$1/;
my $aut;
my $autt = $au;
do {
$aut = $autt;
$autt =~ s/^(|.*[^a-z0-9])[a-f0-9]*\d[a-f0-9]*(|[^a-z0-9].*)$/$1#$2/;
} until ($autt eq $aut);
$au = $aut if ($aut =~ /[a-z0-9]/);
#$au =~ s/[^-a-z0-9_.#]/?/g;
}
return greylist_strip($au."@".$ad);
}
sub greylist_strip_ip($) {
my ($a) = @_;
$a =~ s/(.*)\.[0-9]+$/$1\.*/ if (defined($gdb_subnet) && $gdb_subnet);
return greylist_strip(address_strip($a));
}
sub greylist_strip_host {
my ($a) = @_;
return greylist_strip(address_strip($a));
}
sub greylist_strip_triplet(@) {
my ($i,$s,$r) = @_;
$s = greylist_strip_mail($s,(defined($gdb_from_domain) && $gdb_from_domain),(defined($gdb_from_strip) && $gdb_from_strip));
$r = greylist_strip_mail($r,(defined($gdb_to_domain) && $gdb_to_domain),(defined($gdb_to_strip) && $gdb_to_strip));
$i = greylist_strip_ip($i);
return ($i,$s,$r);
}
sub greylist_strip_dataset(@) {
my ($i,$s,$r) = greylist_strip_triplet(@_);
my $h = greylist_strip_host(@_);
return ($h,$i,$s,$r);
}
sub dc_clean {
return 0 unless ($dc_keep);
debug_log(0,'%u dc rec(s) removed',$sql_did) if (sql_execute('DELETE FROM dictionary WHERE (dc_stamp<?)',time()-$dc_keep) && $sql_did>0);
return $sql_did;
}
# Add host to dictionary list
sub dc_add {
my ($host) = @_;
my $now = time();
sql_execute('INSERT INTO dictionary (dc_stamp,dc_host) VALUES (?,?)',$now,$host);
}
sub dict_add_grey {
return 0 unless ($dc_grey_new);
return dc_add(greylist_strip_host(@_));
}
sub dict_add_unknown_user {
return 0 unless ($dc_unknown_user);
return dc_add(greylist_strip_host(@_));
}
sub dict_add_invalid_mx {
return 0 unless ($dc_invalid_mx);
return dc_add(greylist_strip_host(@_));
}
sub dict_add_bad_helo {
return 0 unless ($dc_bad_helo);
return dc_add(greylist_strip_host(@_));
}
sub dict_add_black_host {
return 0 unless ($dc_black_host);
return dc_add(greylist_strip_host(@_));
}
sub dict_add_virus {
return 0 unless ($dc_virus);
return dc_add(greylist_strip_host(@_));
}
sub dict_add_abuse {
return 0 unless ($dc_abuse);
return dc_add(greylist_strip_host(@_));
}
sub dict_add_trap {
return 0 unless ($dc_trap);
return dc_add(greylist_strip_host(@_));
}
# Greylist exemption stuff.
sub test_exemptions {
my $comment = shift;
my $exlist = shift;
my $ip = address_strip(shift);
my $fqdn = shift;
my $hlo = shift;
my $oh = '';
$oh = '_host' unless (@_);
my $snd = address_strip(shift);
my $rcpt = shift;
my $entity = shift;
return wantarray ? (1,'','') : 1 unless ($exlist);
return wantarray ? (0,'set',$exlist) : 0 if ($exlist && $exlist =~ /^\d+$/s);
#debug_log(0,'%s_exempt %s %s %s',$comment,$fqdn,$ip,$exlist);
foreach my $gck (split(/\s*;\s*/,$exlist)) {
my @mis = ();
my ($gc,$gv) = split(/\s*:\s*/,$gck,2);
my $rv = 0;
if ($gc =~ /^(\?|except )\s*(.*)$/) {
$gc = $2;
$rv = 1;
push @mis, '?';
}
my $gn = 1;
if ($gc =~ /^(!|not )\s*(.*)$/) {
$gc = $2;
$gn = 0;
push @mis, '!';
}
$gc =~ s/[-_\s]+//g;
$gc = lc($gc);
push @mis, $gc;
my $tm = 0;
#debug_log(0,'%s_exempt %s %s %u %s %s',$comment,$fqdn,$ip,$gn,$gc,$gv);
if ($gc =~ /^r(ev|everse)?dns$/) {
push @mis, $fqdn;
$tm = 1 if ($fqdn !~ /^\[?$ip\]?$/ && $fqdn =~ /\S+\.\S+/);
} elsif ($gc =~ /^d(yn|ynamic)?$/) {
push @mis, ($fqdn,$ip);
$tm = 1 if (check_maybe_dynamic_fqdn($fqdn,$ip));
#debug_log(0,'%s_exempt dynamic %s %s',$comment,$fqdn,$ip) if ($tm);
} elsif ($gc =~ /^s(tatic|server|rv)?$/) {
push @mis, ($fqdn,$ip);
$tm = 1 if (check_maybe_server_fqdn($fqdn,$ip));
#debug_log(3,'%s_exempt server %s %s',$comment,$fqdn,$ip) if ($tm);
} elsif ($gc =~ /^f(ull)?c(ircle)?dns$/) {
push @mis, $ip;
$tm = 1 if (get_full_circle_dns($ip));
#debug_log(0,'%s_exempt fcdns %s',$comment,$ip) unless ($tm);
} elsif ($gc =~ /^(ip|rhs|d|dom|domain)?dns(bl|blacklist|wl|whitelist)?s?$/) {
$Features{"Net::DNS"} = load_modules('Net::DNS') unless ($Features{"Net::DNS"});
next unless ($Features{"Net::DNS"});
my $chadr;
$gv =~ s/\s+//;
if ($gc =~ /^(rhs|d|dom|domain)dns/) {
next unless ($snd);
$chadr = $snd;
$chadr =~ s/^.*\@//;
next unless ($chadr);
$gv = 'nomail.rhsbl.sorbs.net' unless ($gv);
} else {
$chadr = $ip;
$gv = 'combined.njabl.org,dnsbl.sorbs.net' unless ($gv);
}
my @dnsbl = split(/,/,$gv);
my $blaw = 1;
$blaw = shift @dnsbl if (@dnsbl && $dnsbl[0] =~ /^\d+$/);
my $tmtm = $tm;
if (@dnsbl && $dnsbl[0]) {
push @mis, $chadr;
my ($cdr,$cdh) = check_dnsls($chadr,15,$blaw,@dnsbl);
#debug_log(0,'%s_exempt dnsbl %s %s',$comment,$cdr,join(',',@{$cdh}));
push @mis, $blaw;
if ($cdr) {
$tm = 1 if ($cdr);
push @mis, @{$cdh};
} else {
foreach my $odl (@dnsbl) {
my $dlo = $odl;
$dlo =~ s/:.*$//;
push @mis, $dlo;
}
}
}
#debug_log(0,'%s_exempt dnsbl %i %i<>%i %s',$comment,$blaw,$tm,$tmtm,join('|',@dnsbl)) if ($tm != $tmtm);
#debug_log(0,'%s_exempt dnsbl %s %s',$comment,$ip,$gv) if ($tm);
} elsif ($gc =~ /^c(ountry)?$/) {
my @cc = ();
push @cc, lc($fqdn) if ($fqdn);
$cc[0] =~ s/^.*\.//;
push @cc, get_ip_country($ip,'?lr','f','c3','c2');
$gv =~ s/\s+//;
next unless (@cc);
foreach my $cv (split(/,/,lc($gv))) {
next unless ($cv);
$cv = ".*$cv.*" if (length($cv)>3);
push @mis, $cv;
for (my $c=0;$c<@cc && !$tm;$c++) {
$tm = 1 if ($cc[$c] =~ /^$cv$/);
#debug_log(0,'%s_exempt country %s %s',$comment,$cc[$c],$cv) if ($tm);
}
last if ($tm);
}
} elsif ($gc =~ /^h(ost)?$/) {
next unless ($fqdn);
$gv =~ s/\s+//;
next unless ($gv);
$gv =~ s/,+/,/g;
$gv =~ s/\./\\./g unless ($gv =~ /(\\|\.[\*\?])/);
$gv =~ s/(^|,)(.)/$1.*\\.$2/g;
$gv =~ s/,/|/g;
push @mis, $gv;
$gv = "($gv)";
$tm = 1 if ($fqdn =~ /^$gv$/i);
#debug_log(0,'%s_exempt host %s %s',$comment,$fqdn,$gv) if ($tm);
} elsif ($gc =~ /^r(elay)?(db)?$/) {
$tm = 1 if (check_relay_spam($ip));
push @mis, $ip;
#debug_log(0,'%s_exempt relay %s',$comment,$ip) if ($tm);
} elsif ($gc =~ /^no?s(pam)?(db)?$/) {
my @gnsa = ($ip);
push @gnsa, $snd unless ($oh);
push @mis, @gnsa;
if ($gv && $gv > 0) {
my ($nsl,$nsh) = get_no_spam_counts(@gnsa);
$tm = 1 if ($nsl < $gv);
} else {
$tm = 1 if (get_no_spam_bad(@gnsa));
}
} elsif ($gc =~ /^o(perating)?s(ystem)?$/) {
next unless ($gv);
next unless (load_modules('p0fIP2OS'));
my ($os,$osv) = ip2osver($ip);
next unless ($os || $osv);
$os = "$os $osv";
$os =~ s/\s+/ /g;
$os =~ s/\s+$//;
$os =~ s/^\s+//;
next unless ($os);
$gv =~ s/,+/,/g;
$gv =~ s/\|+/\|/g;
$gv =~ s/\./\\./g unless ($gv =~ /(\\|\.[\*\?])/);
$gv =~ s/,/|/g unless ($gv =~ /\|/);
$gv =~ s/\s+/\\s+/g;
push @mis, $gv;
$gv = "($gv)";
$tm = 1 if ($os =~ /$gv/i);
} elsif ($gc =~ /^s(ent)?o(ut)?(db)?$/) {
next if ($oh);
next unless ($entity);
push @mis, ('*',$snd,@{$rcpt});
$tm = 1 if (out_check($entity,$snd,@{$rcpt}));
} elsif ($gc =~ /^m(ail)?e?x(change)?$/i) {
push @mis, ($ip,$fqdn,$snd);
$tm = 1 if (server_is_mx($ip,$fqdn,$snd));
} elsif ($gc =~ /^spfp(ass)?$/i) {
if ($snd && $snd !~ /^<>$/) {
push @mis, $snd;
$tm =1 if (check_spf_mfrom($snd)>0);
} elsif ($hlo) {
push @mis, $hlo;
$tm =1 if (check_spf_helo($hlo)>0);
}
} elsif ($gc =~ /^spff(ail)?$/i) {
if ($snd && $snd !~ /^<>$/) {
push @mis, $snd;
$tm =1 if (check_spf_mfrom($snd)<0);
} elsif ($hlo) {
push @mis, $hlo;
$tm =1 if (check_spf_helo($hlo)<0);
}
} elsif ($gc =~ /^h(ell?o)?fqdn$/) {
next unless ($hlo);
push @mis, $hlo;
$tm = 1 if ($hlo =~ /\./ && $hlo !~ /^\[.*\]$/ && $hlo !~ /^\d+\.\d+\.\d+\.\d+$/);
} elsif ($gc =~ /^a(ll)?$/) {
$tm = 1;
#debug_log(0,'%s_exempt all',$comment);
} else {
debug_log(-1,'%s_exempt%s unknown exemption: "%s"',$comment,$oh,$gc);
next;
}
if ($tm == $gn) {
debug_log(2,'%s_exempt%s %u %s %s %s %s',$comment,$oh,$rv,$gck,$ip,$fqdn,$snd);
if ($comment eq 'greylist') {
greylist_log($rv?"exempted$oh":"check$oh",[0,$ip,$hlo?$hlo:'',$oh?'':$snd,'',$fqdn],\@mis);
}
push @lst, $logcsv->string() if ($logcsv->combine(@sl));
return wantarray ? ($rv,"$gc:$gv",$logcsv->combine(@mis)?$logcsv->string():join(',',@mis)) : $rv;
}
}
debug_log(2,'%s_exempt%s 1 - %s %s %s',$comment,$oh,$ip,$fqdn,$snd);
if ($comment eq 'greylist') {
greylist_log("exempted$oh",[0,$ip,$oh?$snd:'','',$fqdn]);
}
return wantarray ? (1,'','') : 1;
}
sub greylist_exempt {
return test_exemptions('greylist',$greylist,@_);
}
sub check_blockrelay {
return test_exemptions('relay',$block_relay,@_);
}
sub check_blocksender {
return test_exemptions('sender',$block_sender,@_);
}
# Checks if host IP is white in the grey-list.
sub greylist_check_host {
my ($ip) = greylist_strip_host(@_);
my $white = 0;
my $black = 0;
$white = $gdb_host_white if (defined($gdb_host_white) && ($gdb_host_white > 0));
$black = $gdb_host_black if (defined($gdb_host_black) && ($gdb_host_black > 0));
return (-1,'') unless ($white || $black);
debug_log(4,"greylist_check_host: $ip");
my $now = time();
my $stamps = sql_select_one_row('SELECT hl_stamp,hl_touch FROM hostlist WHERE hl_host=?',$ip);
return (-1,'') unless ($stamps);
my $stamp = 0;
my $touch = 0;
if (@$stamps) {
$stamp = $stamps->[0] if ($stamps->[0]);
$touch = $stamps->[1] if ($stamps->[1]);
}
debug_log(4,'greylist_check_host: %s %u %u',$ip,$stamp,$touch);
return (0,'white') if ($white && $touch && ($touch > $now - $white));
return (-1,'') unless ($black);
unless ($stamp) {
sql_execute('INSERT OR IGNORE INTO hostlist (hl_host,hl_stamp) VALUES (?,?)',$ip,$now);
dict_add_black_host(@_);
return ($black,'new');
}
my $rr = ($stamp+$black)-$now;
if ($rr > 0) {
dict_add_black_host(@_);
return ($rr,'black');
}
return (-1,'');
}
# Checks if a triplet is in the grey-list.
# Returns seconds until the triplet will be accepted, or -1 for error.
sub greylist_update {
my ($reset,$accept,$ip,$sender,$recipient) = @_;
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO greylist (gl_reset,gl_accepted,gl_host,gl_sender,gl_recipient) VALUES (?,?,?,?,?) '.
'ON DUPLICATE KEY UPDATE gl_reset=VALUES(gl_reset),gl_accepted=VALUES(gl_accepted)',
$reset,$accept,$ip,$sender,$recipient);
} else {
sql_execute('REPLACE INTO greylist (gl_reset,gl_accepted,gl_host,gl_sender,gl_recipient) VALUES (?,?,?,?,?)',$reset,$accept,$ip,$sender,$recipient);
}
}
sub greylist_check($$$) {
my ($hip,$ip,$sender,$recipient) = greylist_strip_dataset(@_);
my ($hresult,$hevent) = greylist_check_host(@_);
debug_log(3,'greylist_check: %u %s host',$hresult,$hevent) if ($hresult >= 0);
unless ($hresult) {
greylist_log('white_host',[0,$hip,$sender,$recipient]);
return (0,'White Host');
}
my $now = time();
my $reset = 0;
my $accepted = 0;
my $stamps = sql_select_one_row('SELECT gl_reset,gl_accepted FROM greylist WHERE gl_host=? AND gl_sender=? AND gl_recipient=?',$ip,$sender,$recipient);
if ($stamps) {
if (@$stamps) {
$reset = $stamps->[0] if ($stamps->[0]);
$accepted = $stamps->[1] if ($stamps->[1]);
}
if ($now < $reset+$gdb_black) {
$result = ($reset+$gdb_black)-$now;
$event = 'black';
} elsif (($now < $reset+$gdb_grey) || (($accepted > 0) && ($now < $accepted + $gdb_white))) {
greylist_update($reset,$now,$ip,$sender,$recipient);
$result = 0;
$event = 'white';
} elsif ($reset || $accepted) {
greylist_update($now,0,$ip,$sender,$recipient);
dict_add_grey(@_);
$result = $gdb_black;
$event = 'old';
} else {
greylist_update($now,0,$ip,$sender,$recipient);
dict_add_grey(@_);
$result = $gdb_black;
$event = 'new';
}
#md_syslog('info', "greylist: $event; $result; $ip; $sender; $recipient") if (defined($gdb_log) && $gdb_log);
greylist_log($event,[$result,$ip,$sender,$recipient]);
}
debug_log(3,'greylist_check: %u %s',$result,$event) if ($result >= 0);
return ($result,ucfirst($event));
}
# White-lsits host in greylist db.
sub greylist_white_host($) {
my ($ip) = @_;
return 0 if (check_internal_whitelist($ip));
return 0 unless (defined($gdb_host_white) && ($gdb_host_white > 0));
$ip = greylist_strip_host($ip);
debug_log(1,"greylist_white_host: $ip");
my $now = time();
my $t = ($now - $gdb_host_white) + 1;
sql_execute_multi(
['INSERT OR IGNORE INTO hostlist (hl_host,hl_stamp) VALUES (?,?)',$ip,$now],
['UPDATE hostlist SET hl_touch=? WHERE hl_host=? AND hl_touch<?',$now,$ip,$t],
);
}
# Resets host record(s) in the grey list.
sub greylist_reset_host($) {
my $ip = greylist_strip_host(@_);
debug_log(1,"greylist_reset_host: $ip");
sql_execute('UPDATE hostlist SET hl_touch=0 WHERE hl_host=?',$ip);
}
# Resets record(s) in the grey list.
sub greylist_reset {
my ($ip,$sender,$recipient) = @_;
my $r = greylist_reset_host($ip);
my $now = time();
if ($sender || $recipient) {
$r += sql_execute('UPDATE greylist SET gl_reset=?,gl_accepted=? WHERE gl_host=? AND gl_sender=? AND gl_recipient=?',$now,0,$ip,$sender,$recipient);
} else {
$r += sql_execute('UPDATE greylist SET gl_reset=?,gl_accepted=? WHERE gl_host=?',$now,0,$ip);
}
return $r;
}
# Check if host currently exceeds limits in dictionary list
sub dict_check_host {
return 0 unless ($dc_time_window && ($dc_limit || $dc_limit_time));
my $host = greylist_strip_host(@_);
my $now = time();
if ($dc_limit) {
my $time = $now - $dc_time_window;
my $cnt = sql_select_one('SELECT COUNT(dc_stamp) FROM dictionary WHERE dc_host=? AND dc_stamp>?',$host,$time);
return $cnt if ($cnt && $cnt > $dc_limit);
}
if ($dc_limit_time) {
my ($lth,$ltl,$ltt);
foreach my $winh ((-1,24,12,6,3,1,0.5,0.25,0.125)) {
my $res;
if ($winh>0) {
my $win = int($winh*60*60);
#debug_log(0,'dict_check_host limitpertime ?1 %s %u %u (%f)',$host,$win,$ltt,$winh);
last unless ($win > $dc_time_window);
next unless ($win < $ltt);
$win = $now - $win;
#debug_log(0,'dict_check_host limitpertime ?2 %s %u %u %u (%f)',$host,$win,$lth,$ltl,$winh);
last if ($win > $lth);
next if ($win < $ltl);
$res = sql_select_one_row('SELECT MIN(dc_stamp),MAX(dc_stamp),COUNT(dc_stamp) FROM dictionary WHERE dc_host=? AND dc_stamp>?',$host,$win);
} else {
$res = sql_select_one_row('SELECT MIN(dc_stamp),MAX(dc_stamp),COUNT(dc_stamp) FROM dictionary WHERE dc_host=? AND dc_stamp>0',$host);
}
#debug_log(0,'dict_check_host limitpertime %s (%f)',$host,$winh);
last unless ($res && $#$res==2 && $res->[0] && $res->[1] && $res->[2]);
my $time = $now - $res->[0];
last unless ($time && $time>$dc_time_window);
$ltl = $res->[0];
$lth = $res->[1];
$ltt = $time;
#debug_log(0,'dict_check_host limitpertime %s %i %i (%f)',$host,$time,$res->[2],$winh);
my $calc = $time ? $res->[2]/$time : $res->[2];
next unless ($calc && $calc > $dc_limit_time);
#debug_log(0,'dict_check_host limitpertime %s %s %u / %u = %f (%f)',
# ($calc && $calc > $dc_limit_time) ? '!' : '-',
# $host,$res->[2],$time,$calc,$winh);
return $calc;
}
}
return 0;
}
#***********************************************************************
# Received-lines checks.
#***********************************************************************
# Check if received line says someones HELO pretended to be ours or our backups IP
sub check_received_helo($$$$) {
my ($bip,$bhost,$ip,$helo) = @_;
$bip = address_strip($bip);
$bhost = address_strip($bhost);
$ip = address_strip($ip);
$helo = address_strip($helo);
debug_log(3,"check_received_helo: $bip, $bhost, $ip, $helo");
if (!check_internal_whitelist($ip) && !check_external_whitelist($ip) &&
!check_black_nets($helo) && !check_black_nets($ip) &&
(check_mail_backup($helo,'') || check_our_helo($helo)) && check_mail_backup($bip,$bhost)) {
debug_log(3,"check_received_helo: Bad HELO $helo [$ip] at $bhost");
return 1;
}
return 0;
}
# Checks hosts found in receive-headers
sub check_received_lines($$) {
my ($sender,$head) = @_;
debug_log(3, "check_received_lines: $sender");
return (0,'','') unless ($head);
return (0,'','') unless (load_modules('Mail::Field','Mail::Field::Received'));
#my @rr = ();
#foreach my $rl ($head->get('Received')) { push @rr, $rl; }
#my @pr = ();
my $st = time();
my @recheads = Mail::Field->extract('Received',$head);
debug_log(4, "check_received_lines: %u",$#recheads+1);
foreach my $rechead (@recheads) {
if (time() - $st > 120) {
debug_log(-1,'check_received_lines: timeout');
last;
}
my %rec = %{$rechead->parse_tree()};
debug_log(5,'check_received_lines: = '.$rec{'whole'});
#push @pr, $rec{'whole'}."\n";
next if (!defined($rec{'from'}));
my $ip = "";
my $host = "";
my $helo = "";
my $from = "";
my $byhost = "";
my $byip = "";
$ip = $rec{'from'}{'address'} if (defined($rec{'from'}{'address'}));
$host = $rec{'from'}{'domain'} if (defined($rec{'from'}{'domain'}));
$helo = $rec{'from'}{'HELO'} if (defined($rec{'from'}{'HELO'}));
$from = $rec{'from'}{'from'} if (defined($rec{'from'}{'from'}));
#$pr[$#pr] = "'$ip' > '$byip'\n$pr[$#pr]";
if (defined($rec{'by'})) {
$byhost = $rec{'by'}{'domain'} if (defined($rec{'by'}{'domain'}));
if (defined($rec{'by'}{'comments'})) {
foreach my $cm (@{$rec{'by'}{'comments'}}) {
if ($cm =~ /^\((\d+\.\d+\.\d+\.\d+)\)$/) {
$byip = $1;
last;
}
}
}
}
debug_log(5,"speci_received_helo: rec $rec{'whole'}");
if ($ip =~ /^\[?\d+\.\d+\.\d+\.\d+\]?$/ && check_mail_backup('',$byhost) &&
$rec{'whole'} =~ /^\s*from\s+([^\(\)\[\]\s]+\s+)?\(([^\)]+)\)\s+\[(\d+\.\d+\.\d+\.\d+)\]\s+by\s+(\S+)\s+with\s+e?smtp\s+id\s+\S+;\s+[A-Z][a-z][a-z],\s+\d\d?\s+[A-Z][a-z][a-z]\s+\d+\s+\d\d?\:\d\d:\d\d\s+[+-]?\d+/) {
debug_log(5,"speci_received_helo: was helo=$helo ip=$ip byhost=$byhost");
$host = $1;
$helo = $2;
$ip = $3;
$byhost = $4;
$host =~ s/\s+$//;
debug_log(5,"speci_received_helo: has helo=$helo ip=$ip byhost=$byhost");
}
debug_log(5,"speci_received_helo...");
if (check_received_helo($byip,$byhost,$ip,$helo)) {
debug_log(5, "check_received_lines: helo, $ip, $host, $helo, $from, $buip, $byhost");
stats_log('reject','received_helo',[$helo,$ip]);
return (1,"Forged HELO/EHLO ($helo) is not appreciated!");
}
debug_log(5, "check_received_lines: chk, $ip, $host, $helo, $from, $byip, $byhost");
# Should we really check this line?
if ((!$ip || !check_black_nets($ip)) && ($ip || $host || $from) &&
!check_internal_whitelist($ip) && !check_external_whitelist($ip,$host)) {
my ($ok,$msg) = check_relay($SLVars{QI},$ip,$host,'REJECT','received_',1);
debug_log(5, "check_received_lines: rlc, $ok, $ip, $host, $helo, $from");
return (1,$msg) if ($ok eq 'REJECT');
my($bad, $hit, $log) = check_external_blacklist($ip,$host,'',$from,$sender);
if ($bad) {
debug_log(2, "check_received_lines: blc, $ip, $host, $from, ".$log);
stats_log('reject',"received_$log",$hit);
return (1,"We do not want mail from $hit!");
}
}
debug_log(5,'check_received_lines: -');
}
#if (load_modules('File::Temp qw(tempfile unlink0)')) {
# my ($tfh,$tfn) = tempfile($SLVars{QI}.'_XXXXX',DIR=>'/tmp',SUFFIX=>'.recvrep',UNLINK=>0);
# print $tfh $head->as_string;
# print $tfh join("\n",'',"================",@rr,"================",@pr,'');
# close($tfh);
#}
return (0,'');
}
my @countries;
sub add_a_country {
my ($country,$unc) = @_;
return unless ($country);
if (@countries && $countries[$#countries] =~ /^\(?$country\)?$/i) {
$countries[$#countries] = $country unless ($unc);
return;
}
push @countries, $unc ? "($country)" : $country;
}
# Get countries from headers
sub get_received_countries($) {
my ($entity) = @_;
my $st = time();
@countries = ();
my $head = $entity->head;
return scalar @countries unless ($head);
my $mod = $head->modify(0);
my $hdrs = $head->header;
$head->modify($mod);
return scalar @countries unless ($hdrs && @{$hdrs});
while (@{$hdrs}) {
if (time() - $st > 120) {
debug_log(-1,'get_received_countries: timeout');
last;
}
my $hdrl = pop @{$hdrs};
$hdrl =~ s/[\r\n]+//gs;
my $olog = 0;
my $unc = 0;
#debug_log(0, "get_received_countries: H %s",$hdrl);
if ($hdrl =~ /^(?:X-)?Received:\s*from[\s\r\n]+([^\r\n]*?)[\s\r\n]+by/i) {
$hdrl = $1;
} elsif ($hdrl =~ /^(?:X-)?Received:\s*from[\s\r\n]+([^\r\n]*?)(?:\([^\)]*\))?\s*;/i) {
$hdrl = $1;
} elsif ($hdrl =~ /^(?:X-)?(?:OB-)?(?:Received|Facebook):\s*from[\s\r\n]+([^\r\n]*?)[\s\r\n]+by/i) {
$hdrl = $1;
$unc = 1;
} elsif ($hdrl =~ /^(?:X-)?(?:Client|(?:[a-z]+-?)?[a-z]{4,5}-?posting-?host|(?:Originating|(?:MD)?Remote|Note-?Sending|Yahoo-?Post|Mailer)-?IP):\s*(.*?)[\s\r\n]*$/i) {
$hdrl = $1;
$unc = 1;
} elsif ($hdrl =~ /^(?:X-)?PHP-Script: \S+\.php for (.*)$/i) {
$hdrl = $1;
$unc = 1;
} elsif ($hdrl =~ /^(?:X-)?Loom-IP: (\S+)/i) {
$hdrl = $1;
$unc = 1;
} else {
next;
#next if ($hdrl =~ /^(?:X-)?(?:Received(?:-SPF)?|Authentication-Results|X-SpamAssassin|References|In-Reply-To|(?:HTTP-)?User-?Agent|SMTP-From|Message-ID|Mailer(?:-Component)?|Scanned-By|Geo|Gr[ae]ylist|\S+Version):/i);
#$olog = $hdrl;
}
my $country;
foreach my $brd (['\[','\]'],['\(','\)'],['(?:^|[\s,;])','(?:[\s,;]|$)'],['<','>'],['\{','\}'],['\b','\b']) {
while ($hdrl =~ /^(.*$brd->[0])(\d+\.\d+\.\d+\.\d+)($brd->[1].*?)$/) {
my $ip = $2;
$hdrl = "$1?$3";
if ($olog && $olog ne '-') {
debug_log(0, "get_received_countries: h %s",$olog);
$olog = '-';
}
#debug_log(0, "get_received_countries: m %s#%s",$brd->[0],$brd->[1]);
#debug_log(0, "get_received_countries: A %s",$ip);
next if ($olog);
$country = get_ip_country($ip);
last if ($country);
}
last if ($country);
}
next unless ($country);
#debug_log(0, "get_received_countries: C %s",$country);
add_a_country($country,$unc);
}
return scalar @countries;
}
#***********************************************************************
# Mail address checks +.
#***********************************************************************
sub check_against_smtp_server {
my ($sender,$rcpt_addr,$rcpt_host) = @_;
return md_check_against_smtp_server($sender,$rcpt_addr,$MyFilterHostName,$rcpt_host);
}
sub check_against_smtp_server_cached {
my ($sender,$rcpt_addr,$rcpt_host) = @_;
my $snd = address_strip($sender);
my $rcpt = address_strip($rcpt_addr);
my $host = address_strip($rcpt_host);
my $now = time();
my $res = sql_select_one_row('SELECT smtp_stamp,smtp_result,smtp_text FROM smtpcheck WHERE smtp_from=? AND smtp_to=? AND smtp_host=?',
$snd,$rcpt,$host);
if ($res && $res->[0] && $res->[1]) {
#debug_log(0,'check_against_smtp_server_cached %u %s %s %s %s %s',$now-$res->[0],$snd,$rcpt,$host,$res->[1],$res->[2]);
return ($res->[1],$res->[2]) if ($res->[1] eq 'CONTINUE' && $res->[0] > $now-$smtp_cache_good);
return ($res->[1],$res->[2]) if ($res->[1] eq 'TEMPFAIL' && $res->[0] > $now-$smtp_cache_fail);
return ($res->[1],$res->[2]) if ($res->[1] eq 'REJECT' && $res->[0] > $now-$smtp_cache_bad);
}
my ($ok,$msg) = check_against_smtp_server($sender,$rcpt_addr,$rcpt_host);
if ($ok ne 'CONTINUE' && $ok ne 'REJECT' &&
$res && $res->[0] && $res->[1] &&
$res->[1] eq 'CONTINUE' && $res->[0] > $now-$smtp_cache_good_error) {
debug_log(-1,'check_against_smtp_server_cached: Returning cached CONTINUE due to error checking <%s> against [%s]: %s %s',$rcpt_addr,$rcpt_host,$ok,$msg);
return ($res->[1],$res->[2]);
}
#debug_log(0,'check_against_smtp_server_cached - %s %s %s %s %s',$snd,$rcpt,$host,$ok,$msg);
#sql_command("INSERT OR IGNORE INTO smtpcheck (smtp_from,smtp_to,smtp_host) VALUES ($snd,$rcpt,$host)");
#sql_command("UPDATE smtpcheck SET smtp_stamp=$now,smtp_result=$result,smtp_text=$text WHERE smtp_from=$snd AND smtp_to=$rcpt AND smtp_host=$host");
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO smtpcheck (smtp_from,smtp_to,smtp_host,smtp_stamp,smtp_result,smtp_text) VALUES (?,?,?,?,?,?) '.
'ON DUPLICATE KEY UPDATE smtp_stamp=VALUES(smtp_stamp),smtp_result=VALUES(smtp_result),smtp_text=VALUES(smtp_text)',
$snd,$rcpt,$host,$now,$ok,$msg);
} else {
sql_execute('REPLACE INTO smtpcheck (smtp_from,smtp_to,smtp_host,smtp_stamp,smtp_result,smtp_text) VALUES (?,?,?,?,?,?)',
$snd,$rcpt,$host,$now,$ok,$msg);
}
return ($ok,$msg);
}
sub expand_against_smtp_servers {
my @addrs = ();
debug_log(9,'expand_against_smtp_server collect');
foreach my $ao (@_) {
my %ai = (addr=>$ao,server=>'',done=>0,expn=>0,expanded=>0,cache=>0);
my $aa = address_strip_p($ao);
$ai{oldaddress} = $aa;
if ($RecipientMailers{$ao} && @{$RecipientMailers{$ao}} && ${$RecipientMailers{$ao}}[2] =~ /^e?smtp$/i) {
$ai{server} = ${$RecipientMailers{$ao}}[1];
$ai{address} = ${$RecipientMailers{$ao}}[2];
}
if ($aa =~ /^(.*)\@([^@]*)$/) {
my $adomain = lc($2);
$ai{address} = $aa unless ($ai{address});
$ai{server} = $storingservers{$adomain} unless ($ai{server} || !defined($storingservers{$adomain}));
}
push @addrs, \%ai;
}
return @addrs unless ($expnservers);
return @addrs unless (load_modules('Net::SMTP'));
debug_log(5,'expand_against_smtp_server check');
my $smtp;
my $server;
my $did = 0;
my $start = time();
my $now = time();
my $elc = 0;
do {
foreach my $ai (sort { $a->{server} cmp $b->{server} } @addrs) {
next if ($ai->{done});
$ai->{done} = 1;
next if ($ai->{expanded} >= 5);
next unless ($ai->{server});
next unless ($ai->{server} =~ /^$expnservers$/i);
debug_log(5,'expand_against_smtp_server check %s %s',$ai->{address},$ai->{server});
my $res = sql_select_one_row('SELECT expn_stamp,expn_newaddress FROM expncheck WHERE expn_address=?',lc($ai->{address}));
#debug_log(0,'expand_against_smtp_server %i (%s) <%s> <%s>',$now-$res->[0],$ai->{oldaddress},$ai->{address},$res->[1]) if ($res && $res->[0]);
my ($adomain,$aaddress);
if ($res && $res->[0] && ($now-$res->[0]<$expn_cache)) {
$ai->{cache} ++;
next unless ($res->[1]);
next if (lc($ai->{address}) eq lc($res->[1]));
next unless ($res->[1] =~ /^(.*)\@(.*)$/);
$adomain = $2;
$aaddress = $res->[1];
debug_log(2,'expand_against_smtp_server cached %s %s %s',$ai->{oldaddress},$ai->{address},$aaddress);
} else {
my $eerr = 1;
last if (time()-$start > 20);
if (!$smtp || $server ne $ai->{server}) {
$smtp->quit if ($smtp);
$server = $ai->{server};
debug_log(1,'expand_against_smtp_server connect %s',$server);
$smtp = Net::SMTP->new(Host=>$server,Hello=>$MyFilterHostName,Timeout=>10);
debug_log(-1,'expand_against_smtp_server connect failed: %s',$server) unless ($smtp);
}
if ($smtp) {
debug_log(2,'expand_against_smtp_server expand %s %s %s',$ai->{oldaddress},$server,$ai->{address});
my @expansions = $smtp->expand($ai->{address});
if ($smtp->ok) {
$eerr = 0;
next unless (@expansions);
$ai->{expn} ++;
next if ($#expansions);
next unless ($expansions[0] =~ /<(\S+)\@(\S+)>/);
my $auser = $1;
$adomain = $2;
$aaddress = "$auser\@$adomain";
next if (lc($ai->{address}) eq lc($aaddress));
$now = time();
debug_log(2,'expand_against_smtp_server expanded %s %s %s %s',$ai->{oldaddress},$server,$ai->{address},$aaddress);
}
}
if ($eerr) {
debug_log(-1,'expand_against_smtp_server: error checking <%s> (%s) against [%s]',$ai->{address},$ai->{oldaddress},$ai->{server});
next unless ($res && $res->[0] && ($now-$res->[0]<$expn_cache_error));
$ai->{cache} ++;
next unless ($res->[1]);
next if (lc($ai->{address}) eq lc($res->[1]));
next unless ($res->[1] =~ /^(.*)\@(.*)$/);
$adomain = $2;
$aaddress = $res->[1];
debug_log(-1,'expand_against_smtp_server: Returning cached <%s> due to error checking <%s> (%s) against [%s]',$aaddress,$ai->{address},$ai->{oldaddress},$ai->{server});
}
}
debug_log(1,'expand_against_smtp_server expn %s %s %s %s',$ai->{oldaddress},$server,$ai->{address},$aaddress);
debug_log(1,'expand_against_smtp_server stat %u %s %u %u',$expn_local,$adomain,($adomain !~ /^$OurDomains$/i),($expn_local && $adomain !~ /^$OurDomains$/i));
next if ($expn_local && $adomain !~ /^$OurDomains$/i);
$adomain = lc($adomain);
#next if ($storingservers{$adomain} && lc($storingservers{$adomain}) eq lc($ai->{server}));
$ai->{expanded} ++;
$ai->{address} = $aaddress;
$ai->{domain} = $adomain;
if (defined($storingservers{$adomain})) {
$did ++;
$ai->{done} = 0;
$ai->{server} = $storingservers{$adomain};
}
}
$elc ++;
} while ($did && (time()-$start<20) && $elc<20);
$now = time();
foreach my $ai (@addrs) {
$ai->{expanded} = 0 if (lc($ai->{oldaddress}) eq lc($ai->{address}));
$ai->{address} = '' unless ($ai->{expanded});
next unless ($ai->{expn});
debug_log(5,'expand_against_smtp_server cache %s %s',$ai->{oldaddress},$ai->{address});
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO expncheck (expn_address,expn_newaddress,expn_stamp) VALUES (?,?,?) '.
'ON DUPLICATE KEY UPDATE expn_newaddress=VALUES(expn_newaddress),expn_stamp=VALUES(expn_stamp)',
lc($ai->{oldaddress}),$ai->{address},$now);
} else {
sql_execute('REPLACE INTO expncheck (expn_address,expn_newaddress,expn_stamp) VALUES (?,?,?)',lc($ai->{oldaddress}),$ai->{address},$now);
}
}
$smtp->quit if ($smtp);
return @addrs;
}
# Check a mail address against a mail server
sub check_mail_address {
my ($a,$s) = @_;
my ($ok,$msg,$code,$dsn) = check_against_smtp_server('<>',$a,$s);
return (-1,'') unless ($ok);
my $txt = "$code $dsn $msg";
$txt =~ s/\s\s+/ /g;
$txt =~ s/^\s+//;
$txt =~ s/\s+$//;
# Disregard some REJECTs because they aren't really rejecting the recipient address.
return (3,$txt) if ($ok eq 'REJECT' && ($code !~ /^55[0134]$/ || $msg =~ /(sender|mail from|return|<>)/i));
return (1,'') if ($ok eq 'CONTINUE');
return (0,$txt) if ($ok eq 'REJECT');
return (2,'');
}
# Check a mail address against it's MX server(s)
sub check_mail_address_mx_i($) {
my ($ra) = @_;
return (4,'') if ($ra =~ /^<?>?$/);
return (-1,'') unless (load_modules('Net::DNS'));
my $d = lc($ra);
$d =~ s/^.*@([^@>]*)>?$/$1/;
return (5,'') if (!$d);
my @mx = get_mxes($d);
my @rinfs = ();
foreach my $mp (sort { $a->{p} <=> $b->{p} } @mx) {
my ($ok,$rinf) = check_mail_address($ra,$mp->{x});
return (0,$rinf) unless ($ok);
return (1,$rinf) if ($ok == 1);
push @rinfs, $rinf if ($rinf);
}
return (8,join('; ',@rinfs));
}
# Caches the result in the greylist database.
sub check_mail_address_mx($) {
my ($a) = @_;
debug_log(5,'check_mail_address_mx: ini, %s',$a);
my $addr = address_strip($a);
my $rc = 1;
my $now = time();
my $cache = sql_select_one_row('SELECT sc_stamp,sc_result,sc_text,sc_count FROM sendercheck WHERE sc_address=?',$addr);
my ($ores,$res,$txt) = (-1,0,'');
if ($cache && @{$cache} && $cache->[0]) {
my $ct;
$cache->[1] = 0 unless ($cache->[1]);
if (!$cache->[1]) {
$cache->[3] = 0 unless ($cache->[3]);
$ct = $sc_cache_invalid + ($sc_cache_invalid_add * ($cache->[3] - 1));
$ct = $sc_cache_invalid_max if ($ct > $sc_cache_invalid_max);
} elsif ($cache->[1] == 1) {
$ct = $sc_cache_valid;
} else {
$ct = $sc_cache_unknown;
}
$rc = ($now - $cache->[0] > $ct);
$res = $cache->[1];
$txt = $cache->[2];
$txt = '' unless ($txt);
$ores = $res;
debug_log(2,'check_mail_address_mx: gfc, %u, %u, %u, %u, %s, %s',$rc,$ct,$cache->[3],$res,$txt,$addr);
}
if ($rc) {
($res,$txt) = check_mail_address_mx_i($a);
$res = 0 unless ($res);
$txt = '' unless ($txt);
debug_log(1,'check_mail_address_mx: cas, %u, %s, %s',$res,$txt,$addr);
my $cnts = '1';
$cnts = 'sc_count+1' if ($ores == $res);
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO sendercheck (sc_address,sc_stamp,sc_result,sc_text,sc_count) VALUES (?,?,?,?,?) '.
"ON DUPLICATE KEY UPDATE sc_stamp=VALUES(sc_stamp),sc_result=VALUES(sc_result),sc_text=VALUES(sc_text),sc_count=$cnts",
$addr,$now,$res,$txt,1);
} else {
sql_execute_multi(
['INSERT OR IGNORE INTO sendercheck (sc_address) VALUES (?)',$addr],
["UPDATE sendercheck SET sc_stamp=?,sc_result=?,sc_text=?,sc_count=$cnts WHERE sc_address=?",$now,$res,$txt,$addr],
);
}
}
return ($res,$txt);
}
# Check mail address according to map
sub check_mail_address_mx_map {
my $map = shift;
my $a = address_strip_nc(shift);
debug_log(5,'check_mail_address_mx_map: 1 %s %s',$a,$map);
my $mf = read_list_file($map);
return (-1,'unchecked') unless ($mf && @{$mf});
foreach my $l (@{$mf}) {
my $line = $l;
$line =~ s/[\r\n]+//gs;
next unless ($line);
next if ($line =~ /^[#;]/);
debug_log(5,'check_mail_address_mx_map: 2 %s %s',$a,$line);
if ($line =~ /^\s*(\S+)\s+(\S+)\s*$/s) {
my $o = $1;
my $n = $2;
$o = ".*\\\@$o" if ($o !~ /\@/);
debug_log(4,'check_mail_address_mx_map: 3 %s %s %s',$a,$o,$n);
next unless ($a =~ /^$o$/i);
my $a1 = $a;
my $a2 = $a;
$a1 =~ s/\@[^@]*$//;
$a2 =~ s/^.*\@//;
my $c = sprintf($n,$a1,$a2);
my ($res,$txt) = check_mail_address_mx($c);
debug_log(1,'check_mail_address_mx_map: 4 %s %s %u %s',$a,$c,$res,$txt);
return ($res,$txt);
}
}
return (-1,'unchecked');
}
# Check if sender has valid MX
# Cache result in database
sub mail_address_mx_check {
my ($a) = @_;
return 0 if ($sender !~ /^<?>?$/);
return 0 unless (load_modules('Net::validMX'));
my $msd = address_strip($a);
$msd =~ s/^.*\@//;
return 0 unless ($msd);
my $now = time();
my $cache = sql_select_one_row('SELECT mx_stamp,mx_error FROM mxcheck WHERE mx_domain=?',$msd);
if ($cache && @{$cache} && $cache->[0]) {
my $age = $now-$cache->[0];
if ($cache->[1]) {
debug_log(3,'mail_address_mx_check: %s, %s, %s, %u, %s','Nac',$a,$msd,$age,$cache->[1]);
return (1,$cache->[1]) if ($age <= $mx_cache_invalid);
} else {
debug_log(3,'mail_address_mx_check: %s, %s, %s, %u','Acc',$a,$msd,$age);
return 0 if ($age <= $mx_cache_valid);
}
}
debug_log(3,'mail_address_mx_check: %s, %s, %s','Chk',$a,$msd);
my ($vmx,$vmxr) = Net::validMX::check_valid_mx($a);
$vmxr = '' if ($vmx);
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO mxcheck (mx_domain,mx_stamp,mx_error) VALUES (?,?,?) '.
'ON DUPLICATE KEY UPDATE mx_stamp=VALUES(mx_stamp),mx_error=VALUES(mx_error)',
$msd,$now,$vmxr);
} else {
sql_execute_multi(
['INSERT OR IGNORE INTO mxcheck (mx_domain) VALUES (?)',$msd],
['UPDATE mxcheck SET mx_stamp=?,mx_error=? WHERE mx_domain=?',$now,$vmxr,$msd],
);
}
return 0 if ($vmx);
debug_log(3,'mail_address_mx_check: %s, %s, %s, %s','Bad',$a,$msd,$vmxr);
return (2,$vmxr);
}
@new_recipients = ();
sub list_recipients {
@new_recipients = @Recipients unless (defined(@new_recipients));
return @new_recipients;
}
sub recipients_hash {
my %rh = ();
foreach my $rcpt (@_) {
$rh{lc(address_strip_p($rcpt))} = $rcpt;
}
return \%rh;
}
sub do_add_recipients {
@new_recipients = @Recipients unless (defined(@new_recipients));
my $rh = recipients_hash(@new_recipients);
my $ch = 0;
foreach my $rcpt (@_) {
next if ($rh->{lc(address_strip_p($rcpt))});
my $rs = $rcpt;
$rs =~ s/^([^<].*?[^>])$/<$1>/;
push @new_recipients, $rs;
$ch ++;
stats_log('modified','modified_recipients',['',$rcpt]);
}
return $ch;
}
sub do_del_recipients {
@new_recipients = @Recipients unless (defined(@new_recipients));
my $rh = recipients_hash(@new_recipients);
my $ch = 0;
foreach my $rcpt (@_) {
my $rs = lc(address_strip_p($rcpt));
next unless (defined($rh->{$rs}));
delete $rh->{$rs};
$ch ++;
stats_log('modified','modified_recipients',[$rcpt,'']);
}
return 0 unless ($ch);
@new_recipients = values %{$rh};
return $ch;
}
sub do_replace_recipients_ex {
@new_recipients = @Recipients unless (defined(@new_recipients));
my $rh = recipients_hash(@new_recipients);
my $ch = 0;
my $opts = shift @_;
while (@_) {
my $oldp;
my $delp = shift @_;
my $addp = shift @_;
my $cc = 0;
if ($opts->{rcpex}) {
foreach my $del (keys %{$rh}) {
next unless ($del =~ /^$delp$/i);
delete $rh->{$del};
$cc ++;
$oldp = $del unless ($oldp);
}
} else {
my $del = lc(address_strip_p($delp));
if (defined($rh->{$del})) {
delete $rh->{$del};
$cc ++;
$oldp = $del;
}
}
next unless ($cc || $opts->{oradd});
if ($addp =~ /(?:^\@|\@$|\%)/) {
unless ($oldp) {
debug_log(-1,'do_replace_recipients_ex <> -> <%s>',$addp);
next;
}
my ($au,$ad,$ai,$ap) = address_split_nc($oldp);
if ($addp =~ /^\@/) {
$addp = "$au$ap$addp";
} elsif ($addp =~ /\@$/) {
$addp = "$addp\@$ad";
} elsif ($addp =~ /\%/) {
$addp = sprintf($addp,$au,$ad,$ai,$ap);
}
}
debug_log(1,'do_replace_recipients_ex <%s> =~ "%s" -> <%s>',$oldp,$delp,$addp);
my $add = lc(address_strip_p($addp));
unless (defined($rh->{$add})) {
$addp =~ s/^([^<].*?[^>])$/<$1>/;
$rh->{$add} = $addp;
$cc ++;
}
$ch += $cc;
stats_log('modified','modified_recipients',[$delp,$addp]) if ($cc);
}
return 0 unless ($ch);
return $ch if ($opts->{dbg});
@new_recipients = values %{$rh};
return $ch;
}
sub do_replace_recipients {
return do_replace_recipients_ex({},@_);
}
sub forward_recipients {
my $fwdl = read_list_file('forwards');
return 0 unless ($fwdl && @{$fwdl});
@new_recipients = @Recipients unless (defined(@new_recipients));
my $rh = recipients_hash(@new_recipients);
my $ch = 0;
foreach my $l (@{$fwdl}) {
next unless ($l =~ /^\s*(\S+?)[\s:=]+(\S+?)[\s\r\n]*$/);
my $alias = $1;
my $forward = $2;
$alias .= "\@$OurDomains" unless ($alias =~ /\@/);
my $cc = do_replace_recipients_ex({rcpex=>1},$alias=>$forward);
debug_log(1,'forward_recipients %s %s',$alias,$forward) if ($cc);
$ch += $cc;
}
return $ch;
}
sub expand_recipients {
return 0 unless ($expnservers);
return 0 unless (load_modules('Net::SMTP'));
@new_recipients = @Recipients unless (defined(@new_recipients));
my $rh = recipients_hash(@new_recipients);
my $ch = 0;
foreach my $expn (expand_against_smtp_servers(@new_recipients)) {
next unless ($expn->{expanded});
debug_log(1,'expand_recipients %s %s',$expn->{addr},$expn->{address});
do_replace_recipients_ex({},$expn->{addr}=>$expn->{address});
}
}
sub sync_recipients {
my ($entity) = @_;
return 1 unless (defined(@new_recipients));
#foreach my $rcpt (@Recipients) { debug_log(0,'sync_recipients O %s',$rcpt); }
#foreach my $rcpt (@new_recipients) { debug_log(0,'sync_recipients N %s',$rcpt); }
my $orh = recipients_hash(@Recipients);
my $nrh = recipients_hash(@new_recipients);
my $ch = 0;
while (my ($rx,$rs) = each %{$orh}) {
next if (defined($nrh->{$rx}));
debug_log(1,'sync_recipients del %s',$rs);
delete_recipient($rs);
$ch ++;
}
while (my ($rx,$rs) = each %{$nrh}) {
next if (defined($orh->{$rx}));
debug_log(1,'sync_recipients add %s',$rs);
add_recipient($rs);
$ch ++;
}
return 1 unless ($ch);
if ($#Recipients || $#new_recipients) {
do_action_insert_header($entity,"X-Redirected",sprintf('%u -> %u',$#Recipients+1,$#new_recipients+1));
} else {
do_action_insert_header($entity,"X-Redirected",sprintf('%s -> %s',address_strip_p($Recipients[0]),address_strip_p($new_recipients[0])));
}
return 1 if (@new_recipients);
return 0;
}
sub has_recipient_in {
my @res = ();
my $res = 0;
for (my $i=0;$i<@_;$i++) {
$re[$i] = 0
}
my $rcptl = defined(@new_recipients) ? \@new_recipients : \@Recipients;
foreach my $rcpt (@{$rcptl}) {
for (my $i=0;$i<@_;$i++) {
debug_log(7,'has_recipient_in ? %s %u %s',$rcpt,$i,$_[$i]);
if ($rcpt =~ /^<?$_[$i]>?$/i) {
debug_log(5,'has_recipient_in ! %s %u %s',$rcpt,$i,$_[$i]);
$res[$i] ++;
$res ++;
}
}
}
return wantarray ? @res : $res;
}
sub pass_abuse {
return 0 unless ($PassAbuse);
return 0 unless (has_recipient_in('abuse\@[^\@]+'));
return 1;
}
sub wants_extra_headers {
return has_recipient_in($WantsExtraHeaders) unless ($PassAbuse);
return has_recipient_in($WantsExtraHeaders,'abuse\@[^\@]+');
}
sub wants_reports_or_headers {
my @res = has_recipient_in($WantsReports,$WantsExtraHeaders,'abuse\@[^\@]+');
$res[1] = ($res[1] || ($PassAbuse && $res[2]));
return ($res[0],$res[1]);
}
#***********************************************************************
# HTML CLeaning stuff.
#***********************************************************************
# All the ready made cleaners/sanitizers/whatever are probably more
# efficient than this. OTH, they are also more harmful, removing way
# too much for our users tastes.
# Hopefully this custom stuff can strike a better balance...
# Variables...
my $hc_base_href;
my $hc_last_href;
my $hc_changed;
my @hc_reports;
my $hc_htmlout;
my $hc_styleout;
my @hc_skip = ();
my $hc_style;
my $hc_main_entity;
my %hc_cids = undef;
#sub hc_elog {
# my $x1 = shift;
# my $e = shift;
# my $mid = '?';
# my $cid = '?';
# my $ct = '?';
# if ($e && $e->head) {
# $mid = $e->head->get('Message-ID') if ($e->head->get('Message-ID'));
# $cid = $e->head->get('Content-ID') if ($e->head->get('Content-ID'));
# $ct = $e->head->mime_attr('Content-Type') if ($e->head->mime_attr('Content-Type'));
# }
# debug_log(0,"hgpt: ($x1) '$mid/$cid' = '$ct'");
#}
# Note correct, but it'll (hopefully) do...
sub hc_find_part_type {
my $cid = shift;
my $entity = shift;
return undef unless ($cid && $$cid && $entity && $entity->head);
#hc_elog('hfpte',$entity);
my $c = $entity->head->get('Content-ID');
$c =~ s/^\s*(.*?)\s*$/$1/s;
$c = address_strip_nc($c);
#debug_log(0,"hgpt: (hfpt) 'cid:$$cid' = '$c' ?");
if ($c && ($c eq $$cid)) {
my $ct = $entity->head->mime_attr('Content-Type');
my $et = $entity->effective_type;
my $fn = $entity->head->recommended_filename;
#debug_log(0,"hgpt: (hfptf) 'cid:$$cid' -> ct='$ct' et='$et' fn='$fn'");
$ct = $et unless ($ct);
return ($ct,$fn);
}
foreach my $pe ($entity->parts) {
#hc_elog('hfptp',$entity);
#debug_log(0,"hgpt: (hfpt) p?");
next unless ($pe->head);
#next if ($pe->head->get('Message-ID'));
#debug_log(0,"hgpt: (hfpt) p!");
my ($r,$f) = hc_find_part_type($cid,$pe);
return ($r,$f) if (defined($r));
}
return undef;
}
sub hc_get_part_type {
my $cid = shift;
return '' unless ($cid && $hc_main_entity);
#hc_elog('hgpt',$hc_main_entity);
my ($rt,$rf) = hc_find_part_type(\$cid,$hc_main_entity);
$rt = '' unless ($rt);
$rf = '' unless ($rf);
return ($rt,$rf);
}
# Splits URL into parts
sub hc_split_url {
my $u = shift;
my $nb = shift;
$nb = 0 unless ($nb);
$u = '' unless(defined($u));
$u =~ s/^\s*(.*?)\s*$/$1/s;
my $p = 0;
my ($lp,$lh,$ld,$lf,$lq) = ('','','','');
if ($u =~ /^\#/) {
$lf = $u;
$u = '';
} else {
$u = "$hc_base_href$u" if ($hc_base_href && !$nb && $u !~ /^[^\s:]+:/);
if ($u =~ /^([^\s:]+):(.*)$/) {
$lp = $1;
$u = $2;
$p = 1;
}
if ($u =~ /^(.*?)\?(.*)$/) {
$lq = $2;
$u = $1;
} elsif ($u =~ /^(.*?)\/\*(.*)$/) {
$lq = $2;
$u = $1;
}
if ($p) {
if ($u =~ /^\/\/([^\/]*)(\/.*|)$/) {
$lh = $1;
$u = $2;
}
} else {
if ($u =~ /^([^\/]*)(\/.*|)$/) {
$lh = $1;
$u = $2;
}
}
if ($u =~ /^(.*)\/([^\/]*)$/) {
$ld = $1;
$lf = $2;
} else {
$lf = $u;
}
}
return ($lp,$lh,$ld,$lf,$lq);
}
# Used for validating a URL
sub hc_validate_url_i {
my ($text,$what) = @_;
$text =~ s/\\/\//gs;
$text =~ s/^[\r\n\t]*(.*?)[\r\n\t]*$/$1/s;
$text =~ s/[\r\n]+//gs;
return undef if ($text eq '#');
return undef if ($text =~ /[\x00-\x1F\x7F\xFF]/);
return undef if ($text =~ /\"/); #"
return undef if (($what =~ /c/) && ($text =~ /[\(\)\{\}\'\"]/)); #"
my $extx = '([^-A-Z0-9_.,;?%\/]|$)';
my ($ulp,$ulh,$uld,$ulf,$ulq) = hc_split_url($text);
#print "$ulp|$ulh|$uld|$ulf|$ulq\n";
return $text if ($what =~ /l/ && $ulp eq '' && $ulh eq '' && $uld eq '' && $ulq eq '' && $ulf =~ /^\#\S+$/);
return undef unless ($ulp =~ /^(mailto|news|https?|ftp|cid)$/i);
if ($what =~ /l/) {
return $text if (lc($ulp) eq 'mailto' && $ulf =~ /^\s*<?[^\@]+\@[^\@]+>?\s*$/);
return $text if (lc($ulp) eq 'news' && $ulq eq '');
}
if ($what =~ /[Mic]/ && $ulq eq '') {
if ($ulp =~ /^([cm])id$/i) {
my $us = $1;
my $ud = $uld;
$ud = '' if (lc($us) eq 'm');
my $uf = "$ud$ulf";
#print "? cid:$uf\n";
if ($uf =~ /^[-_.:;()\$\@\/!%0-9a-zA-Z]+$/) {
my ($cidt,$cidf) = hc_get_part_type($uf);
#debug_log(0,"hvu: 'cid:$uf' -> '$cidt' @ '$cidf'");
if ($cidt) {
return undef if ($cidt =~ /^application\//i);
return undef if ($cidt =~ /(java|script)/i);
return "cid:$uf" if ($what =~ /i/ && $cidt =~ /^image\//i);
return "cid:$uf" if ($what =~ /c/ && $cidt =~ /^text\//i);
}
if ($cidf) {
return undef if (($what =~ /l/) && ($cidf =~ /\..*\.$bad_exts\.*$extx/i));
return undef if (($what =~ /[ic]/) && ($cidf =~ /\.$bad_exts\.*$extx/i));
return undef if (($what =~ /[ci]/) && ($cidf =~ /\.$bad_css_exts\.*$extx/i));
}
return "cid:$uf" if ($what =~ /l/);
return undef if ($cidt);
return "cid:$uf";
}
return undef;
#return "cid:$uf" if (($uf =~ /^[-_.:;()\$\@\/!%0-9a-zA-Z]+$/) &&
# ($uf !~ /\.$bad_exts\.*$extx/i) &&
# (($what !~ /c/) || ($uf !~ /\.$bad_css_exts\.*$extx/i)));
}
}
return undef if ($what =~ /M/);
if ($ulf ne '' & $ulq eq '') {
return undef if (($what =~ /l/) && ($ulf =~ /\..*\.$bad_exts\.*$extx/i));
return undef if (($what =~ /[ic]/) && ($ulf =~ /\.$bad_exts\.*$extx/i));
return undef if (($what =~ /[ci]/) && ($ulf =~ /\.$bad_css_exts\.*$extx/i));
}
return $text if ($ulp =~ /^(https?|ftp)$/i);
return undef;
}
sub hc_validate_url {
my $r = hc_validate_url_i(@_);
if (defined($r) && $r =~ /^cid:(.+)$/i) {
$hc_cids{lc($1)} = $r;
}
return $r;
}
# Used for validating style definitions
sub hc_validate_css {
my ($text,$what) = @_;
my $css;
my $pre = '';
my $suf = '';
if ($what =~ /a/i) {
$css = CSS::Tiny->read_string("x { $text }");
} else {
my $txt = $text;
if ($txt =~ /^(\s*<!-*\s*)(.*?)$/s) {
$pre = $1;
$txt = $2;
}
if ($txt =~ /^(.*?)(\s*-*>\s*)$/s) {
$txt = $1;
$suf = $2;
}
$css = CSS::Tiny->read_string($txt);
}
return (0,$text) unless ($css);
my $ch = 0;
while (my ($t,$ah) = each %{$css}) {
while (my ($a,$v) = each %{$ah}) {
if ($v =~ /^\s*url\s*\((.*)\)(.*?)$/) {
my $u = $1;
my $y = $2;
$u =~ s/^\"(.*)\"$/$1/s;
$u =~ s/^\'(.*)\'$/$1/s;
my $l = hc_validate_url($u,'lic');
$ch = 1 if (!$l || $l ne $u);
if ($l) {
$css->{$t}->{$a} = "url(\"$l\")$y";
} else {
delete $css->{$t}->{$a};
}
}
}
}
if ($ch) {
$text = $css->write_string;
if ($what =~ /a/i) {
$text =~ s/^\s*x\s+\{\s*//s;
$text =~ s/\s*\}\s*$//s;
$text =~ s/\n\s*/ /gs;
}
$text = "$pre$text$suf";
$text =~ s/\n*$/\n/s if ($what !~ /a/i);
}
return ($ch,$text);
}
# outputs to result
sub hc_output {
return 0 if (@hc_skip);
if ($hc_style) {
$hc_styleout .= join('',@_);
} else {
$hc_htmlout .= join('',@_);
}
return 1;
}
# outputs accumulated css
sub hc_output_css {
my ($ch,$css) = hc_validate_css($hc_styleout,'b');
$hc_styleout = '';
$hc_changed ++ if ($ch);
hc_output($css);
}
# outputs and inc changed
sub hc_output_changed {
$hc_changed ++;
return hc_output(@_);
}
# Hook for plain text
sub hc_handle_text {
my $self = shift;
my $text = shift;
return hc_output($text) if ($hc_style);
return 0 if (@hc_skip);
return hc_output($text) unless ($hc_last_href);
my $hrx = $hc_last_href;
my $hrxt = HTML::Entities::encode_entities($hrx);
my $txt = HTML::Entities::decode_entities($text);
$hc_last_href = undef;
$txt =~ s/^\s*//s;
$txt =~ s/\s.*$//s;
return hc_output($text) unless ($txt);
return hc_output($text) unless ($txt =~ /^(ftp:|https?:|www\.)/);
#return hc_output($text) if ($txt =~ /^\s*$hrx(\s|$)/i);
#return hc_output($text) if ($text =~ /^\s*$hrxt(\s|$)/i);
my ($ulp,$ulh,$uld,$ulf,$ulq) = hc_split_url($hrx);
#print "$ulp|$ulh|$uld|$ulf|$ulq\n";
my ($tlp,$tlh,$tld,$tlf,$tlq) = hc_split_url($txt,1);
if ($tlf && lc("$tld/$tlf") eq lc($uld)) {
$tld .= '/'.$tlf;
$tlf = '';
}
$tlp = $ulp if ($tlp eq '');
if (($ulp =~ /^https?$/i) && ($tlp =~ /^https?$/i) && (lc($tlp) ne lc($ulp))) {
$text =~ s/^(\s*)$tlp/$1$ulp/i;
$tlp = $ulp;
$hc_changed ++;
}
#print "$tlp|$tlh|$tld|$tlf|$tlq\n";
return hc_output_changed("[obs: $hrxt] $text") if ($ulq && !$tlq && ($ulq =~ /(ftp|https?):/i));
return hc_output_changed("[obs: $hrxt] $text") if (lc($tlp) ne lc($ulp));
return hc_output_changed("[obs: $hrxt] $text") if (lc($tlh) ne lc($ulh));
return hc_output($text) if ($tld eq '' && $tlf eq '' && $tlq eq '');
return hc_output_changed("[obs: $hrxt] $text") if (lc($tld) ne lc($uld));
return hc_output_changed("[obs: $hrxt] $text") if (lc($tlf) ne lc($ulf) && $ulf !~ /^(index|default)\.(html?|php\d?|pl|cgi|fcgi)$/i);
return hc_output($text) if ($tlq eq '' && $tlf eq '');
return hc_output($text) if (lc($tlq) eq lc($ulq) && $tlf eq '');
return hc_output_changed("[obs: $hrxt] $text") if (lc($tlf) ne lc($ulf));
return hc_output($text) if ($tlq eq '');
return hc_output($text) if (lc($tlq) eq lc($ulq));
return hc_output_changed("[obs: $hrxt] $text");
}
# Hook for start tags
sub hc_handle_start {
my $self = shift;
my $text = shift;
my $tag = shift;
my $attr = shift;
my $rar = 0;
my $rnc = 0;
my $skip = 0;
my $style = 0;
if ($hc_style) {
$hc_style ++ if ($tag eq 'style');
return;
}
if ($tag =~ /^(embed|bgsound|object|applet|link)$/) {
$hc_changed ++;
return;
}
#if ($tag eq 'link') {
# my $xx = 1;
# if (defined($attr->{href}) && ($attr->{href} ne '')) {
# my $href = hc_validate_url($attr->{href},'M');
# if ($href) {
# $xx = 0;
# $rar = 1 if ($href ne $attr->{href});
# }
# }
# if ($xx) {
# $hc_changed ++;
# return;
# }
#}
return if ($tag =~ /^(noscript)$/);
if ($tag =~ /^(script|frameset|iframe|frame|styledef)$/) {
$skip = 1;
}
unless (@hc_skip || $skip) {
if (($tag eq 'a' || $tag eq 'area' || $tag eq 'base') &&
defined($attr->{href}) && ($attr->{href} ne '')) {
my $href = hc_validate_url($attr->{href},'l');
if (!$href || $href ne $attr->{href}) {
$rar ++;
$rnc ++ if ($tag eq 'base');
if ($href) {
$attr->{href} = $href;
} else {
delete $attr->{href};
}
}
if ($tag eq 'a') {
$hc_last_href = $href;
} elsif ($tag eq 'base') {
$hc_base_href = $href;
delete $attr->{href};
$rar ++;
$rnc ++;
}
} elsif ($attr->{href}) {
delete $attr->{href};
$rar ++;
}
if (($tag eq 'img' || ($tag eq 'input' && $attr->{type} && lc($attr->{type}) eq 'image')) &&
defined($attr->{src}) && ($attr->{src} ne '')) {
my $src = hc_validate_url($attr->{src},'i');
if (!$src || $src ne $attr->{src}) {
$rar ++;
if ($src) {
$attr->{src} = $src;
} else {
$attr->{alt} = sprintf('[%s]',$attr->{src}) unless ($attr->{alt});
delete $attr->{src};
}
}
} elsif ($attr->{src}) {
delete $attr->{src};
$rar ++;
}
if ($tag eq 'style') {
if ($attr->{type} && lc($attr->{type}) ne 'text/css') {
$skip = 1;
} else {
foreach my $a (keys %{$attr}) {
if ($a ne 'type') {
$rar ++;
my %a = (type=>'text/css');
$attr = \%a;
last;
}
}
$style = 1;
}
}
}
if ($skip) {
$hc_changed ++;
push @hc_skip, $tag unless ($text =~ /\/>\s*$/);
return;
}
return if (@hc_skip);
if ($attr->{style}) {
my ($cc,$ct) = hc_validate_css($attr->{style},'a');
if ($cc) {
$rar ++;
$attr->{style} = $ct;
}
}
foreach my $a (keys %{$attr}) {
if ($a =~ /^(on|cite)/i) {
$rar ++;
delete $attr->{$a};
}
}
if ($rar) {
$hc_changed ++ if ($rar > $rnc);
my $e = ($text =~ /\/>\s*$/);
$text = "<$tag";
while (my ($a,$v) = each %{$attr}) {
$a = HTML::Entities::encode_entities($a);
$text .= " $a";
if ($v ne "\x01") {
$v = HTML::Entities::encode_entities($v);
if ($v =~ /^[a-zA-Z0-9]+$/) {
$text .= "=$v";
} else {
$text .= "=\"$v\"";
}
}
}
$text .= ' /' if ($e);
$text .= '>';
}
hc_output($text);
$hc_style += $style;
}
# Hook for end tags
sub hc_handle_end {
my $self = shift;
my $text = shift;
my $tag = shift;
if (@hc_skip && $tag eq $hc_skip[$#hc_skip]) {
pop @hc_skip;
return;
}
return if (@hc_skip);
if ($tag =~ /^(embed|bgsound|object|applet|link)$/) {
$hc_changed ++;
return;
}
return if ($tag =~ /^(noscript)$/);
if ($tag eq 'a') {
$hc_last_href = undef;
} elsif ($tag eq 'style') {
$hc_style -- if ($hc_style);
hc_output_css() unless ($hc_style);
}
return if ($hc_style);
$hc_changed ++ if ($text !~ /^<\s*\/\Q$tag\E\s*>$/i);
return hc_output($text) if ($text =~ /^<\/\Q$tag\E>$/i);
return hc_output("</$tag>");
}
# Hook for declarations
sub hc_handle_declaration {
my $self = shift;
my $text = shift;
my $tag = shift;
return if (@hc_skip);
if (($tag ne 'doctype') || ($hc_htmlout !~ /^\s*$/s)) {
$hc_changed ++;
return;
}
hc_output($text);
}
# Hook for comments
sub hc_handle_comment {
my $self = shift;
my $text = shift;
my $txt = $text;
$txt =~ s/^\s*<!?-*(.*?)-*>\s*$/$1/s;
hc_output($text) if ($hc_style || $txt !~ /[<>]/);
}
# The actual HTML cleaning
sub html_cleaning_thingy {
my $html = join("\n",@_);
$hc_changed = 0;
$hc_last_href = undef;
$hc_htmlout = '';
$hc_styleout = '';
$hc_style = 0;
@hc_skip = ();
my $hssp = HTML::Parser->new();
return (0,$html) unless ($hssp);
$hssp->unbroken_text(1);
$hssp->closing_plaintext(1);
$hssp->boolean_attribute_value("\x01");
$hssp->handler( text => \&hc_handle_text,'self, text');
$hssp->handler( start => \&hc_handle_start,'self, text, tagname, attr');
$hssp->handler( end => \&hc_handle_end,'self, text, tagname');
$hssp->handler( declaration => \&hc_handle_declaration,'self, text, tagname');
$hssp->handler( comment => \&hc_handle_comment,'self, text');
if ($html =~ /^\s*[^<\s]{1,5}\s*(<!DOCTYPE.*)$/s) {
$html = $1;
$hc_changed ++;
}
if ($hssp->parse($html)) {
$hssp->eof;
$html = $hc_htmlout if ($hc_changed);
}
$hc_last_href = undef;
$hc_htmlout = '';
$hc_styleout = '';
$hc_style = 0;
@hc_skip = ();
return ($hc_changed,$html);
}
# Creates a cleaning report in temp dir
sub html_cleaning_report {
return unless (defined($dbh_report) && $dbh_report);
my $html = shift;
my $nhtm = shift;
my $octeh = shift;
my $ncteh = shift;
my $diffs = '';
if ($dbh_report_diff && load_modules('Text::Diff')) {
my $x1 = $html;
my $x2 = $nhtm;
$x1 =~ s/^\s*(.*?)\s*$/$1\n/s;
$x2 =~ s/^\s*(.*?)\s*$/$1\n/s;
eval {
my $diff = diff(\$x1,\$x2,{STYLE=>'Unified',CONTEXT=>0});
$diffs .= "\n$diff" if ($diff);
};
eval {
my $diff = diff(\$x1,\$x2,{STYLE=>'Table',CONTEXT=>0});
$diffs .= "\n$diff" if ($diff);
};
}
my $tfn = './HTML_CLEANING_REPORT.'.@hc_reports;
return unless (open(TFH,'>',$tfn));
debug_log(2,'html_cleaning_report %s',$tfn);
push @hc_reports, $tfn;
print TFH "Content-Transfer-Encoding: '$octeh' -> '$ncteh'\n" if ($ncteh);
print TFH "==========================\nOriginal\n--------------------------\n$html\n";
print TFH "==========================\nNew\n--------------------------\n$nhtm\n";
print TFH "==========================\nDiff\n--------------------------$diffs\n" if ($diffs);
close(TFH);
}
sub move_html_cleaning_reports {
my ($todir) = @_;
debug_log(7,'move_html_cleaning_reports %s',$todir);
foreach my $rf (@hc_reports) {
my $nf = $rf;
$nf =~ s/^.*\///;
debug_log(3,'move_html_cleaning_reports %s %s',$nf,$todir);
copy_or_link($rf,"$todir/$nf");
unlink($rf);
}
@hc_reports = ();
}
# Clears some vars and optionally deletes cleaning reports
sub html_cleaning_clear {
my ($delrep) = @_;
debug_log(7,'html_cleaning_clear');
if ($delrep) {
foreach my $rf (@hc_reports) {
unlink($rf);
}
}
$hc_last_href = undef;
@hc_reports = ();
$hc_htmlout = '';
$hc_styleout = '';
@hc_skip = ();
$hc_main_entity = undef;
%hc_cids = undef;
}
#***********************************************************************
# Attachment replacement stuff.
#***********************************************************************
my @replaced_attachments = ();
my $replace_attachments_path = '';
my $replace_all_attachments = 0;
my $do_replace_attachments = 0;
sub catch_replace_attachments {
my ($recipient,$chkdom) = @_;
debug_log(7,'catch_replace_attachments cd:%i %s',$chkdom,$recipient);
return undef unless ($chkdom);
return undef unless ($attachments_domain);
#debug_log(0,'catch_replace_attachments %s =~ %s',$recipient,"/^<?(.+)\%(.+)\@$attachments_domain>?$/i");
return undef unless ($recipient =~ /^<?(.+)\%(.+)\@$attachments_domain>?$/i);
my $naddr = "$1\@$2";
debug_log(0,'catch_replace_attachments %s -> %s',$recipient,$naddr);
return $naddr;
}
sub check_replace_attachments {
my ($entity,$chkdom) = @_;
my @dra = $do_replace_attachments ? split(/;/,$do_replace_attachments) : ();
$do_replace_attachments = 0;
my %chrcpt = ();
foreach my $rcpt (@Recipients) {
if (my $naddr = catch_replace_attachments($rcpt,$chkdom)) {
my $oaddr = lc($rcpt);
$oaddr =~ s/^<//;
$oaddr =~ s/>$//;
do_replace_recipients($rcpt,$naddr);
$chrcpt{$oaddr} = $naddr;
debug_log(0,'check_replace_attachments d %s -> %s',$rcpt,$naddr);
push @dra, 'domain,all';
} elsif ($attachments_recipients && $rcpt =~ /^<?$attachments_recipients>?$/i) {
push @dra, 'rcpt';
debug_log(0,'check_replace_attachments r %s',$rcpt);
} else {
debug_log(7,'check_replace_attachments - %s',$rcpt);
}
}
if (%chrcpt && $entity && $entity->head && load_modules('Email::Address')) {
debug_log(0,'check_replace_attachments H');
foreach my $hn ('To','Cc') {
my $hv = $entity->head->get($hn);
next unless ($hv);
my @ao = Email::Address->parse($hv);
next unless (@ao);
my @an = ();
my $ch = 0;
foreach my $a (@ao) {
next unless ($a);
#debug_log(0,'check_replace_attachments < %s',$a->format);
if ($chrcpt{lc($a->address)}) {
$a->address($chrcpt{lc($a->address)});
$ch ++;
}
if ($chrcpt{lc($a->phrase)}) {
$a->phrase($chrcpt{lc($a->phrase)});
$ch ++;
}
if ($chrcpt{lc($a->comment)}) {
$a->comment($chrcpt{lc($a->comment)});
$ch ++;
}
#debug_log(0,'check_replace_attachments > %s',$a->format);
push @an, $a->format;
}
next unless ($ch);
my $hr = join(', ',@an);
debug_log(0,'check_replace_attachments %s: %s -> %s',$hn,$hv,$hr);
do_action_change_header($entity,$hn,$hr);
}
}
$do_replace_attachments = join(';',@dra) if (@dra);
debug_log(0,'check_replace_attachments %s',$do_replace_attachments) if ($do_replace_attachments);
return $do_replace_attachments;
}
# Save attachment to uniquely named (for msg) dir.
sub save_replaced_attachment {
my ($entity,$fname,$type) = @_;
return 0 unless ($entity);
return 0 unless ($attachments_path && $attachments_url);
return 0 unless (-d $attachments_path);
my $grp = (stat(_))[5];
debug_log(0,'sra: %s',$fname);
unless ($replace_attachments_path) {
do {
$replace_attachments_path = sprintf('%x.%x.%x.%s.%x',rand(0xFFFF),time(),$$,$SLVars{QI},rand(0xFFFF));
} while (-e "$attachments_path/$replace_attachments_path");
return 0 unless (mkdir("$attachments_path/$replace_attachments_path"));
chown(-1,$grp,"$attachments_path/$replace_attachments_path");
chmod(0755,"$attachments_path/$replace_attachments_path");
}
return 0 unless ($replace_attachments_path && (-d "$attachments_path/$replace_attachments_path"));
debug_log(0,'sra: %s -> %s/',$fname,$replace_attachments_path);
$fname = '' unless (defined($fname));
$fname =~ s/^.*[\/\\]//s;
$fname =~ s/\r\n+//gs;
$fname =~ s/^\s+//;
$fname =~ s/\s+$//;
my $sname = $fname;
$fname =~ s/\s+/_/g;
$fname =~ s/[^-_.,;=a-zA-Z0-9]//g;
$fname =~ s/^\.+//;
$fname = 'unknown' if ($fname eq '');
$sname =~ s/[\x00-\x19\x7E-\xFF]/#/g;
$sname =~ s/"/'/g;
if ($fname =~ /^(index|default)\./i || (-e "$attachments_path/$replace_attachments_path/$fname")) {
my $fcnt = 0;
my $fext = '';
if ($fname =~ /^(.*)(\.[-_a-zA-Z0-9]+?)$/) {
$fext = $2;
$fname = $1;
}
do {
$fcnt++
} while ((-e "$attachments_path/$replace_attachments_path/$fname$fcnt$fext") ||
(-e "$attachments_path/$replace_attachments_path/$fname$fcnt$fext.meta") ||
(-e "$attachments_path/$replace_attachments_path/$fname$fcnt$fext.head"));
$fname .= "$fcnt$fext";
}
debug_log(0,'sra: %s -> %s/%s',$fname,$replace_attachments_path,$fname);
my $path = $entity->bodyhandle->path;
return 0 unless (defined($path));
return 0 unless (copy_or_link($path,"$attachments_path/$replace_attachments_path/$fname"));
chmod(0644,"$attachments_path/$replace_attachments_path/$fname");
chown(-1,$grp,"$attachments_path/$replace_attachments_path/$fname");
if ($attachments_meta) {
my $mpath = "$attachments_path/$replace_attachments_path";
$mpath .= "/$attachments_meta" if ($attachments_meta !~ /^\.[\/\\]?$/);
unless (-e $mpath) {
mkdir($mpath);
chmod(0755,$mpath);
chown(-1,$grp,$mpath);
}
if (($type || $sname) && open(AMF,'>',"$mpath/$fname.meta")) {
if ($type && $sname) {
print AMF "Content-Type: $type; name=\"$sname\"\r\n";
print AMF "Content-Disposition: attachment; filename=\"$sname\"\r\n";
} elsif ($type) {
print AMF "Content-Type: $type\r\n";
} elsif ($sname) {
print AMF "Content-Disposition: attachment; filename=\"$sname\"\r\n";
}
close(AMF);
chmod(0644,"$mpath/$fname.meta");
chown(-1,$grp,"$mpath/$fname.meta");
}
if (open(AMF,'>',"$mpath/$fname.head")) {
print AMF $entity->head->as_string;
close(AMF);
chmod(0644,"$mpath/$fname.head");
chown(-1,$grp,"$mpath/$fname.head");
}
}
debug_log(0,'sra: %s -> %s',"$attachments_path/$replace_attachments_path/$fname");
return $fname;
}
# Move attachment to disk and make a note of it.
sub replace_attachment {
my ($entity,$fname,$type) = @_;
return 0 unless ($entity);
return 0 unless ($attachments_path && $attachments_url);
return undef unless (load_modules('MIME::Entity','Encode'));
my $newname = save_replaced_attachment($entity,$fname,$type);
return 0 unless ($newname);
my %att = (
orgname=>$fname,
newname=>$newname
);
$att{entname} = HTML::Entities::encode_entities($fname) if (load_modules('HTML::Entities'));
debug_log(0,'ra: %s -> %s = %s',$fname,$newname,$att{entname});
$modhead{'Replaced attachment(s).'} ++;
push @replaced_attachments, \%att;
return action_drop();
}
# Move attachment to disk if it should be done.
sub maybe_replace_attachment {
my($entity,$fname,$type) = @_;
return 0 unless ($do_replace_attachments);
return 0 unless ($entity);
return 0 if ($type =~ /^multipart\//i);
my $bdyh = $entity->bodyhandle;
return 0 unless ($bdyh && $bdyh->path);
my $size = (stat($bdyh->path))[7];
return 0 unless ($size);
#debug_log(0,'maybe_replace_attachment hard limit: %u %u',$attachments_hard_limit,$size);
unless (($attachments_hard_limit && $size > $attachments_hard_limit) ||
($do_replace_attachments && $do_replace_attachments =~ /hard/i)) {
debug_log(0,'maybe_replace_attachment %s',$do_replace_attachments) if ($do_replace_attachments);
return 0 unless ($do_replace_attachments);
return 0 if ($attachments_min_size && $size <= $attachments_min_size);
unless ($attachments_max_size && $size > $attachments_max_size) {
return 0 unless ($replace_all_attachments || $do_replace_attachments =~ /all/i);
if (defined(%hc_cids)) {
my $cid = $entity->head ? $entity->head->get('Content-ID') : 0;
return 0 if ($cid && $hc_cids{lc($cid)});
}
}
}
if ($entity->head) {
my $disp = lc($entity->head->mime_attr("Content-Disposition"));
$disp = 'attachment' if (!$disp && $entity->head->recommended_filename);
return 0 if ($disp eq 'inline');
unless ($type =~ /^application\/octet-?stream$/i || $disp eq 'attachment') {
return 0 if ($entity->head->get('Content-ID'));
return 0 if ($type =~ /^text\//i && !$disp);
}
}
debug_log(5,'maybe_replace_attachment !',$do_replace_attachments);
return 1 if (replace_attachment($entity,$fname,$type));
debug_log(-1,'maybe_replace_attachment: error saving attachment (%s)',$fname);
return 0;
}
# Make a note with URLs to attachments moved to disk.
sub make_attachment_replacement_note {
my ($dotext,$dohtml) = @_;
return undef unless ($attachments_path && $attachments_url);
return undef unless ($replace_attachments_path);
return undef unless (@replaced_attachments);
unless (defined($dotext) || defined($dohtml)) {
$dotext = 1;
$dohtml = 1;
}
return undef unless ($dotext || $dohtml);
return undef unless (load_modules('MIME::Entity','Encode'));
my $text = "Bifogade filer / Attached files:\n\n";
my $html = "<html><head><title>Bifogade filer / Attached files:</title></head>\<body><b>Bifogade filer / Attached files:</b><ul>\n";
foreach my $att (@replaced_attachments) {
my $url = sprintf("%s/%s/%s",$attachments_url,$replace_attachments_path,$att->{newname});
$text .= "$url\n";
$html .= sprintf("<li><a href=\"%s\">%s</a></li>\n",$url,$att->{entname}?$att->{entname}:$att->{orgname});
}
$html .= '</ul><hr /></body></html>';
my ($msgtext,$msghtml);
if ($dotext) {
$msgtext = MIME::Entity->build(
Type => 'text/plain',
Data => encode('iso-8859-1',$text),
Encoding => '-SUGGEST',
Charset => 'iso-8859-1',
Top => 0,
Disposition => 'inline',
);
debug_log(0,'marn: t=%u',length($msgtext));
return $msgtext unless ($dohtml);
}
if ($dohtml) {
$msghtml = MIME::Entity->build(
Type => 'text/html',
Data => encode('iso-8859-1',$html),
Encoding => '-SUGGEST',
Charset => 'iso-8859-1',
Top => 0,
Disposition => 'inline',
);
debug_log(0,'marn: h=%u',length($msghtml));
return $msghtml unless ($dotext);
}
my $msg = MIME::Entity->build(
Type => 'multipart/alternative',
Top => 0,
Disposition => 'inline',
'X-ID' => $replace_attachments_path,
);
return undef unless ($msg);
$msg->add_part($msgtext);
$msg->add_part($msghtml);
$msg->preamble([]);
$msg->epilogue([]);
debug_log(0,'marn: m');
return $msg;
}
# Add a part with URLs to attachments moved to disk.
sub add_attachment_replacement_note {
my ($entity,$dotext,$dohtml,$offset) = @_;
my $msg = make_attachment_replacement_note($dotext,$dohtml);
return undef unless ($msg);
my $grp = (stat("$attachments_path/$replace_attachments_path"))[5];
if (open(AMF,'>',"$attachments_path/$replace_attachments_path/.envelope")) {
print AMF "MsgID: $SLVars{QI}\n".
"RelayAddr: $RelayAddr\n".
"RelayHost: $RelayHostname\n".
"RelayHelo: $Helo\n".
"Sender: $Sender\n".
"Recipients:\n\t".join("\n\t",@Recipients)."\n";
close(AMF);
chown(-1,$grp,"$attachments_path/$replace_attachments_path/.envelope") if ($grp);
chmod(0644,"$attachments_path/$replace_attachments_path/.envelope");
}
if (open(AMF,'>',"$attachments_path/$replace_attachments_path/.header")) {
print AMF $entity->head->as_string;
close(AMF);
chown(-1,$grp,"$attachments_path/$replace_attachments_path/.header") if ($grp);
chmod(0644,"$attachments_path/$replace_attachments_path/.header");
}
if (open(AMF,'>',"$attachments_path/$replace_attachments_path/.note")) {
print AMF $msg->as_string;
close(AMF);
chown(-1,$grp,"$attachments_path/$replace_attachments_path/.note") if ($grp);
chmod(0644,"$attachments_path/$replace_attachments_path/.note");
}
$offset = -1 unless (defined($offset));
debug_log(0,'aarn: %u %s',$offset,$replace_attachments_path);
push @AddedParts, [$msg,$offset];
action_rebuild();
return $msg;
}
#***********************************************************************
# Misc content checking/changing.
#***********************************************************************
$did_quarantine = 0;
sub quarantine_misc_info {
my $qd = shift;
$qd = get_quarantine_dir() unless ($qd);
if (defined($info) && $info && open(QIF,'>>',"$qd/MSG.$QuarantineCount")) {
print QIF "$info\n";
close(QIF);
}
if (!(-f "$qd/HASH") && open(QIF,'>',"$qd/HASH")) {
my $hash = make_message_hash();
print QIF "$hash\n";
close(QIF);
}
if (!(-f "$qd/RELAY") && open(QIF,'>',"$qd/RELAY")) {
my $country = get_ip_location($RelayAddr);
my $iposhead = get_ip_os_head($RelayAddr);
print QIF "Addr: $RelayAddr\n";
print QIF "Host: $RelayHostname\n";
print QIF "Helo: $Helo\n";
print QIF "Orig: $country\n";
print QIF "Syst: $iposhead\n";
print QIF synthesize_received_header();
close(QIF);
}
}
sub do_action_quarantine {
my ($flag,$entity,$info,$msg) = @_;
$msg = '' unless (defined($msg));
my $r = action_quarantine($entity,$msg);
pop @Warnings unless ($msg);
my $qd = get_quarantine_dir();
$did_quarantine = 1;
quarantine_misc_info($qd,$info);
copy_or_link('./INPUTMSG', "$qd/INPUTMSG") unless (-f "$qd/INPUTMSG");
create_file("$qd/FLAG.$flag");
$qd =~ s/^.*\///;
stats_log('quarantine',$flag,$qd,make_message_hash());
return $r;
}
sub do_action_quarantine_entire_message {
my ($flag,$msg) = @_;
my $r = action_quarantine_entire_message($msg);
my $qd = get_quarantine_dir();
$did_quarantine = 1;
quarantine_misc_info($qd);
create_file("$qd/FLAG.$flag");
$qd =~ s/^.*\///;
stats_log('quarantine',$flag,$qd,make_message_hash());
return $r;
}
sub do_action_bounce {
return action_bounce(reject_answer(@_));
}
sub do_action_tempfail {
return action_tempfail(tempfail_answer(@_));
}
# make hash of message
sub update_line_hash {
my ($h,$he,$nt,$hashes,$sha,$md5) = @_;
$h =~ s/[\r\n]+//gs;
if ($$he) {
$hashes->[0] .= 'B' unless ($he>1);
$$he ++;
$md5->add("$h\n") if ($md5);
$sha->add("$h\n") if ($sha);
} elsif ($h eq '') {
$$he ++;
$md5->add("$h\n") if ($md5);
$sha->add("$h\n") if ($sha);
} elsif ($h =~ /^\s/) {
next if ($$nt);
#debug_log(0,'make_data_hash h %s',$h);
$md5->add("$h\n") if ($md5);
$sha->add("$h\n") if ($sha);
} elsif ($h =~ /^(Content-\S+|Subject):.*$/) {
#debug_log(0,'make_data_hash H %s',$h);
$md5->add("$h\n") if ($md5);
$sha->add("$h\n") if ($sha);
$h = $1;
$h =~ s/(^|[-_])(.)[^-_]*/$2/gs;
$hashes->[0] .= ucfirst(lc($h));
} else {
$$nt = 1;
}
}
sub make_data_hash {
my ($md5,$sha);
$sha = Digest::SHA->new() if (load_modules('Digest::SHA'));
$md5 = Digest::MD5->new() if (load_modules('Digest::MD5'));
return '' unless ($md5 || $sha);
my @hashes = ('');
my $nt = 0;
my $he = 0;
while ($#_>0) {
my $hh = shift @_;
my $ha = ref($hh) eq 'ARRAY' ? $hh : [$hh];
while (@{$ha}) {
my $h = shift @{$ha};
#debug_log(0,'make_data_hash l %s',$h);
update_line_hash($h,\$he,\$nt,\@hashes,$sha,$md5);
}
}
return '' unless (@_);
my $dfn = shift @_;
return '' unless (open(F,'<',$dfn));
#debug_log(0,'make_data_hash f %s',$dfn);
while (my $h = <F>) {
update_line_hash($h,\$he,\$nt,\@hashes,$sha,$md5);
}
close(F);
push @hashes, $sha->hexdigest if ($sha);
push @hashes, $md5->hexdigest if ($md5);
#debug_log(0,'make_data_hash h %s',join('|',@hashes));
return join('|',@hashes);
}
my $input_message_hash;
sub make_message_hash {
#debug_log(0,'make_data_hash m');
$input_message_hash = make_data_hash('./INPUTMSG') unless ($input_message_hash);
return join('|',$input_message_hash,@_) if (@_);
return $input_message_hash;
}
sub make_entity_hash {
my ($entity) = @_;
#debug_log(0,'make_data_hash e?');
return '' unless ($entity && $entity->bodyhandle && $entity->bodyhandle->path);
#debug_log(0,'make_data_hash e');
my @head = ();
if ($entity->head) {
my $mod = $entity->head->modify(0);
@head = @{$entity->head->header};
$entity->head->modify($mod);
}
return make_data_hash(@head,'',$entity->bodyhandle->path);
}
sub make_spam_hash {
return make_message_hash(check_internal_whitelist($RelayAddr) ? 'L' : "RA$RelayAddr");
}
# Handle boilerplates... Hopefully there aren't any...
sub handle_boilerplates {
my $entity = shift;
my $abpbp = 0;
my $bpfl = read_list_file('boilerplates');
if ($bpfl && @{$bpfl}) {
my $snda = address_strip($Sender);
my @bpa = ();
foreach my $l (@{$bpfl}) {
my $line = $l;
$line =~ s/[\r\n]+//g;
next if ($line =~ /^\#/);
if ($line =~ /^(\S+\@\S+)\s+(\S.*?)\s*$/i) {
my $pat = lc($1);
my $tbi = $2;
if ($snda =~ /^$pat$/) {
#debug_log(1,"Boilerplate: '$snda' =~ '$pat'!");
push @bpa, $tbi;
}
}
}
if (@bpa) {
my $dabp = 0;
foreach my $tbi (@bpa) {
my $tbpf = '';
#debug_log(1,"Boilerplate: X '$tbi'");
if ($tbi =~ /^\s*(.*?)\s*\:\s*(.*?)\s*$/) {
$tbpf = $1;
$tbi = $2;
}
my $aatb = 0;
if ($entity->head) {
my @bphs = $entity->head->get('X-Boiler');
foreach my $bph (@bphs) {
$bph =~ s/[\r\n]+//g;
#debug_log(1,"Boilerplate: H '$bph'?");
if ($bph =~ /^\s*\[$MyFilterHostName\]\s+[BHTbht]\s*,\s+(\S+)\s*$/) {
#debug_log(1,"Boilerplate: H '$bph'.");
if ($1 == $tbi) {
#debug_log(1,"Boilerplate: H '$bph'!");
$aatb = 1;
last;
}
}
}
}
next if ($aatb);
$tbpf =~ s/a//gi;
#debug_log(1,"Boilerplate: R $tbpf /etc/mail/$tbi");
my $tbifl = read_text_file($tbi);
next unless ($tbifl && @{$tbifl});
my $tb = '';
my $th = '';
foreach my $l (@{$tbifl}) {
my $line = $l;
$line =~ s/[\r\n]+//g;
$tb .= "$line\n";
$th .= "$line\n";
}
#debug_log(1,"Boilerplate: C $tbi");
next unless ($tb && $th);
if ($tbi =~ /^\.html?$/i) {
$tbpf .= 'h';
$tb =~ s/<br ?\/?>/\n/gsi;
$tb =~ s/<hr =\/?>/-----------------------------------\n/gsi;
$tb =~ s/<[^>]*>//gs;
} else {
$tbpf .= 't';
$th =~ s/&/&/gs;
$th =~ s/</</gs;
$th =~ s/>/>/gs;
while ($th =~ s/^(|.*\n)---+(|\n.*)$/$1<hr>$2/gs) {}
$th =~ s/[\r\n]+$//;
$th =~ s/^[\r\n]+//;
$th =~ s/\n/<br>\n/gs;
while ($th =~ s/<br>[\s\r\n]*<hr>/\n<hr>/gs) {};
while ($th =~ s/<hr>[\s\r\n]*<br>[\s\r\n]*/<hr>\n/gs) {};
$th = "<p>$th<\/p>";
$th =~ s/^<p>[\s\r\n]*<hr>/<hr><p>/si;
}
#debug_log(1,"Boilerplate: A $tbpf $tbi ");
my $bprt;
if ($tbpf =~ /b/i) {
#if ($tpbf =~ /h/i) {
# append_text_boilerplate($entity,$tb,0) unless (append_html_boilerplate($entity,$th,0));
#} else {
# append_html_boilerplate($entity,$th,0) unless (append_text_boilerplate($entity,$tb,0));
#}
my $abpbpt = append_text_boilerplate($entity,$tb,0);
my $abpbph = append_html_boilerplate($entity,$th,0);
$abpbp = (($abpbpt || $abpbph) && !($abpbpt && $abpbph));
do_action_insert_header($entity,'X-Boiler',"[$MyFilterHostName] B, $tbi",0);
$dabp = 1;
$rbm = 1;
} elsif ($tbpf =~ /h/i) {
$bprt = action_add_part($entity, "text/html", "-suggest",$th,'','inline');
do_action_insert_header($entity,'X-Boiler',"[$MyFilterHostName] H, $tbi",0);
$dabp = 1;
} elsif ($tbpf =~ /t/i) {
$bprt = action_add_part($entity, "text/plain", "-suggest",$tb,'','inline');
do_action_insert_header($entity,'X-Boiler',"[$MyFilterHostName] T, $tbi",0);
$dabp = 1;
}
if ($bprt) {
$bprt->head->mime_attr("Content-Type.name" => undef);
$bprt->head->mime_attr("Content-Type.charset" => 'ISO-8859-1');
$bprt->head->mime_attr("Content-Disposition.filename" => undef);
$bprt->head->delete('X-Mailer');
$bprt->head->delete('MIME-Version');
}
}
if ($dabp) {
$modhead{'Added boiler plate(s).'} ++;
debug_log(1,"Boilerplate: added boiler plate(s).");
}
}
}
if ($abpbp && $entity->is_multipart && ($entity->parts <= 1)) {
# Make into singlepart.
if ($entity->make_singlepart() == 'DONE') {
action_rebuild();
debug_log(1,"Boilerplate: made singlepart.");
}
}
return $abpbp;
}
# Wave flags
sub wave_flags {
my ($entity) = @_;
return unless ($entity && $entity->head);
my %flags = ();
my $flagdefs = read_list_file('flags');
return unless ($flagdefs && @{$flagdefs});
foreach my $l (@{$flagdefs}) {
my $line = $l;
next if ($line =~ /^\s*[#;]/);
next if ($line =~ /^[\s\r\n]*$/);
debug_log(7,'wave_flags < "%s"',$line);
my $flg = '';
my $hdrn = '';
my $hdrv = '';
my $fdef = '';
if ($line =~ /^\s*(\S+):\s*(\S+)\s+(.*?)[\s\r\n]*$/s) {
$hdrn = $1;
$hdrv = $2;
$fdef = $3;
$hdrv =~ s/_+/ /g;
$hdrv =~ s/^\s+//;
$hdrv =~ s/\s+$//;
} elsif ($line =~ /^\s*(\S+)\s+(.*?)[\s\r\n]*$/s) {
$flg = $1;
$fdef = $2;
} else {
next;
}
debug_log(5,'wave_flags $ %s "%s"',$flg,$fdef);
next if ($flags{lc($flg)});
if ($fdef =~ /^header\s+(\S+)\s+(.*?)\s*$/i) {
my $expr = $2;
my $htag = $1;
my $hval = '';
if ($htag =~ /^envelope[-_]to$/i) {
foreach my $rcpt (@Recipients) {
$hval .= address_strip_nc($rcpt)."\n";
}
} elsif ($htag =~ /^envelope[-_]from$/i) {
$hval = address_strip_nc($Sender);
} elsif ($htag =~ /^(\S+):(\S*)$/) {
$hval = decode_header($entity->head->mime_attr("$1.$2"));
$hval =~ s/[\r\n]+//gs;
$hval =~ s/\s+/ /g;
} else {
foreach my $hv ($entity->head->get($htag)) {
$hv =~ s/[\r\n]+//gs;
$hv =~ s/\s+/ /g;
$hv =~ s/^\s+//;
$hv =~ s/\s+$//;
$hval .= "$hv\n";
}
}
$hval =~ s/^[s\r\n]+//;
$hval =~ s/[s\r\n]+$//;
next if ($hval eq '');
debug_log(4,'wave_flags = "%s" ? "%s"',$hval,$expr);
if (!$expr) {
next if ($hval);
if ($flg) {
debug_log(3,'wave_flags + %s',$flg);
$flags{lc($flg)} = $flg;
}
if ($hdrn && $hdrv ne '') {
debug_log(3,'wave_heads + %s: %s',$hdrn,$hdrv);
do_action_insert_header($entity,$hdrn,$hdrv);
}
next;
}
next unless ($hval);
$expr = "/$expr/si" unless ($expr =~ /^\/.*\/\S*$/);
debug_log(4,'wave_flags = "%s" ~ "%s"',$hval,$expr);
next unless eval("\$hval =~ $expr");
if ($flg) {
debug_log(3,'wave_flags + %s',$flg);
$flags{lc($flg)} = $flg;
}
if ($hdrn && $hdrv ne '') {
debug_log(3,'wave_heads + %s: %s',$hdrn,$hdrv);
do_action_insert_header($entity,$hdrn,$hdrv);
}
}
}
return unless (%flags);
debug_log(5,'wave_flags > %s',join(', ',values %flags));
do_action_insert_header($entity,'X-Filter-Flags',join(',',values %flags));
}
sub replace_overlong_headers {
my ($entity,$sender) = @_;
return 0 unless ($fix_headers);
my @prepend = ();
my @append = ();
my @tags = $entity->head->tags;
my %tagmax = (
'' => 8192,
'subject' => 512,
'from' => 4096,
'reply-to' => 4096,
'to' => 6144,
'cc' => 6144,
);
my $ch = 0;
foreach my $tag (@tags) {
my @ahl = $entity->head->get($tag);
next unless (@ahl);
for (my $i=$#ahl;$i>=0;$i--) {
my $max = $tagmax{lc($tag)};
$max = $tagmax{''} unless ($max);
#debug_log(0,'replace_overlong_headers %u %s[%u] %u',$max,$tag,$i,length($ahl[$i]));
next unless (length($ahl[$i])>$max);
debug_log(1,'replace_overlong_headers %u %s[%u]: %s',$max,$tag,$i,$ahl[$i]);
if ($tag =~ /^(To|Cc)$/i) {
do_action_change_header($entity,$tag,'...:;',$i+1);
push @append, "$tag: ".decode_header($ahl[$i]);
} elsif ($tag =~ /^(From|Reply-To|Sender|Errors-To)$/i) {
debug_log(1,'replace_overlong_headers from 1');
my $addr = get_address_from_header($entity,$tag);
$addr = $sender if (!$addr || $addr !~ /^<?.+\@[^\@]+>?$/ || length($addr)>$max);
$addr = '? <>' unless ($addr);
do_action_change_header($entity,$tag,mqpcs('UTF-8',$addr),$i+1);
push @prepend, "$tag: ".decode_header($ahl[$i]);
} elsif ($tag =~ /^(Subject|Date)$/i) {
my $dval = decode_header($ahl[$i]);
do_action_change_header($entity,$tag,mqpcs('UTF-8',substr($dval,0,76).'...'),$i+1);
push @prepend, "$tag: ".$dval;
} elsif ($tag =~ /^(Received)$/i) {
do_action_change_header($entity,$tag,'(header too long)',$i+1);
} else {
my $dval = decode_header($ahl[$i]);
do_action_delete_header($entity,$tag,$i+1);
do_action_insert_header($entity,"X-$tag",mqpcs('UTF-8',substr($dval,0,76).'...'));
push @append, "$tag: ".$dval;
}
$ch ++;
}
}
if ($ch) {
debug_log(1,'replace_overlong_headers %u',$ch);
if (@prepend) {
debug_log(1,'replace_overlong_headers prepend');
action_add_part($entity,"text/plain","-suggest",join("\n",@prepend),"LongHeadersP.txt","inline",0);
action_rebuild();
}
if (@append) {
debug_log(1,'replace_overlong_headers append');
action_add_part($entity,"text/plain","-suggest",join("\n",@append),"LongHeadersA.txt","inline",-1);
action_rebuild();
}
stats_log('modified','modified_headers','overlong');
}
return $ch;
}
my %macros_long_name = ('_'=>'mail_relay','j'=>'domain','i'=>'QID','c'=>'hop_count','p'=>'pid','r'=>'protocol');
my $macros_hide = '(mail_mailer|j|i|p|r|daemon_name|if_name|mail_addr|if_addr|_)';
my $macros_head = '(c|r|total_rate|client_rate|load_avg|msg_size)';
my $macros_log = '(msg_size|load_avg|c|p|r|nbadrcpts|client_connections|client_rate|total_rate)';
my $macros_nlog = '(daemon_name|if_name|mail_host|_|if_addr|mail_relay|j|mail_mailer|i|mail_addr)';
sub macros_text {
my ($fmt) = @_;
my $txt = '';
my @log = ();
while (my ($omac,$oval) = each %SendmailMacros) {
#debug_log(0,'macros_text %s = %s',$omac,$oval);
next unless (defined($oval) && $oval ne '' && defined($omac) && $omac ne '');
next if ($omac =~ /^$macros_hide$/i && $fmt !~ /[AaLl]/);
next if ($fmt =~ /[Hh]/ && $omac !~ /^$macros_head$/i);
next if ($fmt =~ /[Ll]/ && $omac =~ /^$macros_nlog$/i);
#next if ($fmt =~ /[Ll]/ && $omac !~ /^$macros_log$/i);
my $mac = $omac;
my $val = $oval;
$mac = $macros_long_name{$mac} if (defined($macros_long_name{$mac}));
$val =~ s/^[\s\r\n]+//s;
$val =~ s/[\s\r\n]+$//s;
if ($fmt =~ /[Ll]/) {
push @log, [$mac,$val];
} else {
next if ($mac =~ /^$macros_hide$/i && $fmt !~ /[Aa]/);
next if ($mac =~ /^.$/ && $fmt !~ /[Aa]/);
$mac =~ s/_+/ /g unless ($mac =~ /^_+$/);
$mac = ucfirst($mac);
$mac = "SM $mac" if ($fmt =~ /[Pp]/);
if ($fmt =~ /[Hh]/) {
$txt .= "; " if ($txt);
$txt .= "$mac: ".mqp($val);
} else {
$txt .= "$mac: $val";
$txt .= "\n";
}
}
}
return @log if ($fmt =~ /[Ll]/);
return $txt;
}
sub macros_stats_log {
my @log = macros_text('L');
stats_log('sendmail_macros',@_,@log) if (@log);
}
#***********************************************************************
# Anti-virus stuff.
#***********************************************************************
# dynamically configure virus scanners to be used
my %AntiVirusBypass = ();
sub set_antivirus_features {
foreach my $fk (keys %AntiVirusBypass) {
next unless ($AntiVirusBypass{$fk});
$Features{$fk} = $AntiVirusBypass{$fk};
$AntiVirusBypass{$fk} = 0;
$VirusScannerRoutinesInitialized = 0;
undef @VirusScannerMessageRoutines;
undef @VirusScannerEntityRoutines;
}
my $la;
my $sp;
while (my ($vf,$vv) = each %AntiVirusConfig) {
my $vd = 0;
if ($vv->{la} && !$vd) {
#debug_log(0,'set_antivirus_features Virus:%s la=%s',$vf,$vv->{la});
$la = get_load_average() unless (defined($la));
if (defined($la) && $la >= $vv->{la}) {
md_syslog('info', "Virus scanner $vf disabled due to load average $la >= $vv->{la}!");
$vd ++;
}
}
if ($vv->{sp} && !$vd) {
#debug_log(0,'set_antivirus_features Virus:%s sp=%s',$vf,$vv->{sp});
$sp = get_swap_percentage() unless (defined($sp));
if (defined($sp) && $sp >= $vv->{sp}) {
md_syslog('info', "Virus scanner $vf disabled due to swap percentage $sp >= $vv->{sp}!");
$vd ++;
}
}
if ($vd) {
$warnhead{"Virus scanner $vf disabled."} ++;
#debug_log(0,'set_antivirus_features Virus:%s = 0',$vf);
if ($Features{"Virus:$vf"}) {
$Features{"Virus:$vf"} = 0;
$VirusScannerRoutinesInitialized = 0;
undef @VirusScannerMessageRoutines;
undef @VirusScannerEntityRoutines;
}
} else {
#debug_log(0,'set_antivirus_features Virus:%s = %s',$vf,$vv->{fn});
unless ($Features{"Virus:$vf"}) {
$Features{"Virus:$vf"} = $vv->{fn};
if ($Features{"Virus:$vf"}) {
md_syslog('info', "Virus scanner $vf reenabled.");
$VirusScannerRoutinesInitialized = 0;
undef @VirusScannerMessageRoutines;
undef @VirusScannerEntityRoutines;
}
}
}
}
foreach my $fk (keys %Features) {
next unless ($fk =~ /^Virus:(.+)$/);
my $vf = $1;
next unless ($Features{$fk});
next unless (check_virus_bypass($vf,$RelayAddr,$RelayHostname,$Sender,\@Recipients));
md_syslog('info', "Virus scanner $vf disabled due to bypass setting!");
$AntiVirusBypass{$fk} = $Features{$fk};
$Features{$fk} = 0;
$VirusScannerRoutinesInitialized = 0;
undef @VirusScannerMessageRoutines;
undef @VirusScannerEntityRoutines;
}
$Features{"Virus:FileScan"} = 0; # Never allow this!
my $on = 0;
while (my ($vf,$vv) = each %Features) {
next unless ($vf =~ /^Virus:.+/);
next unless ($vv);
$on ++;
}
return $on;
}
sub get_cached_virus_result {
my ($hash,$aloc,$ent,$vsc,$vircache) = @_;
return (0,'','','') unless ($hash && $vircache);
if (list_file_changed('antivirus','\s*\=') || list_file_changed('antivirus','\s*\=')) {
debug_log(0,'get_cached_virus_result clear');
sql_execute('DELETE FROM virusresults');
}
debug_log(7,'get_cached_virus_result find %u %u %u',$aloc,$ent,$vsc,$hash);
my $start = time();
my $now = time();
while ($now-$start<30) {
my $res = sql_select_one_row(
'SELECT vir_code,vir_category,vir_action,vir_name FROM virusresults WHERE vir_hash=? AND vir_local=? AND vir_entity=? AND vir_scanners>=? AND vir_stamp>? AND (vir_stamp>? OR vir_action!=?)',
$hash,$aloc,$ent,$vsc,$now-$vircache,$now-60,'tempfail');
return (0,'','','') unless ($res && @{$res});
return ($res->[0],$res->[1],$res->[2],$res->[3]) if ($res->[1] && $res->[2]);
debug_log(0,'get_cached_virus_result wait');
sleep(2);
$now = time();
}
return (0,'','','');
}
# Check message or entity for virus
sub remember_virus_thingy {
my ($hash,$aloc,$ient,$vsc,$scode,$scat,$sact,$vnam) = @_;
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO virusresults (vir_hash,vir_local,vir_entity,vir_scanners,vir_stamp,vir_code,vir_category,vir_action,vir_name) VALUES (?,?,?,?,?,?,?,?,?) '.
'ON DUPLICATE KEY UPDATE vir_stamp=VALUES(vir_stamp),vir_code=VALUES(vir_code),vir_category=VALUES(vir_category),vir_action=VALUES(vir_action),vir_name=VALUES(vir_name)',
$hash,$aloc,$ient,$vsc,time(),$scode,$scat,$sact,$vnam);
} else {
sql_execute_multi(
['INSERT OR IGNORE INTO virusresults (vir_hash,vir_local,vir_entity,vir_scanners) VALUES (?,?,?,?)',
$hash,$aloc,$ient,$vsc],
['UPDATE virusresults SET vir_stamp=?,vir_code=?,vir_category=?,vir_action=?,vir_name=? WHERE vir_hash=? AND vir_local=? AND vir_entity=? AND vir_scanners=?',
time(),$scode,$scat,$sact,$vnam,$hash,$aloc,$ient,$vsc],
);
}
return 1;
}
sub thingy_contains_virus {
my ($entity) = @_;
my $vsc = set_antivirus_features();
return (wantarray ? (0,'ok','ok','') : 0) unless ($vsc);
my $aloc = address_is_local($RelayAddr);
my $vircache = $aloc ? $vircache_local : $vircache_external;
my $hash = !$vircache ? '' : defined($entity) ? make_entity_hash($entity) : make_message_hash();
my ($code,$category,$action,$virname) = get_cached_virus_result($hash,$aloc,defined($entity)?1:0,$vsc,$vircache);
if ($category && $action && $category ne 'swerr') {
debug_log(3,'thingy_contains_virus %s cached %s %s %s %s',defined($entity)?'entity':'message',$code,$category,$action,$virname);
return (wantarray ? ($code,$category,$action,$virname) : $code);
}
initialize_virus_scanner_routines();
my $vsr = defined($entity) ? \@VirusScannerEntityRoutines : \@VirusScannerMessageRoutines;
return (wantarray ? (0,'ok','ok','') : 0) unless ($vsr && @{$vsr});
debug_log(5,'thingy_contains_virus %s scan',defined($entity)?'entity':'message');
$code = 0;
$category = 'ok';
$action = 'ok';
$virname = '';
push_status_tag("Running virus scanner");
my ($scode,$scat,$sact);
for (my $i=0;$i<@{$vsr};$i++) {
if (defined($entity)) {
($scode,$scat,$sact) = $vsr->[$i]->($entity); #$scanner($entity);
} else {
($scode,$scat,$sact) = $vsr->[$i]->(); #&$scanner();
}
debug_log(3,'thingy_contains_virus %u %i %s %s %s',$i+1,$scode,$scat,$sact,$VirusName?$VirusName:'-');
if ($scat eq "virus") {
pop_status_tag();
remember_virus_thingy($hash,$aloc,defined($entity)?1:0,$vsc,$scode,$scat,$sact,$VirusName) if ($hash);
return (wantarray ? ($scode,$scat,$sact,$VirusName) : $scode);
}
#next if ($scode == 1 && $scat eq 'not-installed' && $sact eq 'tempfail');
if ($scat ne 'ok' && $action ne 'quarantine') {
$code = $scode;
$category = $scat;
$action = $sact;
$virname = $VirusName;
}
}
pop_status_tag();
debug_log(3,'thingy_contains_virus * %i %s %s',$code,$category,$action);
return (wantarray ? ($code,$category,$action,$virname) : $code) unless ($hash);
remember_virus_thingy($hash,$aloc,defined($entity)?1:0,$vsc,$code,$category,$action,$virname) if ($hash);
return (wantarray ? ($code,$category,$action,$virname) : $code);
}
# string with enabled virus scanners
sub get_antivirus_string {
my $avs = '';
foreach my $vscan (keys %Features) {
next unless ($vscan =~ /^Virus:(.*)$/);
next unless ($Features{$vscan});
my $vs = $1;
next if ($vs eq 'CLAMAV' && $Features{'Virus:CLAMD'});
next if ($vs eq 'FPROT' && $Features{'Virus:FPROTD'});
$avs .= ', ' if ($avs);
$avs .= $vs;
}
$avs =~ s/, ([^,]+)$/ & $1/;
return $avs;
}
sub antivirus_map_init_vals {
my %vals = ();
($vals{type},$vals{code},$vals{category},$vals{action},$vals{virusname}) = @_;
$vals{clean} = ($vals{category} eq 'ok' && $vals{action} eq 'ok') ? 1 : 0;
$vals{vals} = '';
while (my ($k,$v) = each %vals) {
next unless ($k && $v);
next if ($k eq 'vals');
$vals{vals} .= ' ' if ($vals{vals});
$vals{vals} .= "$k:$v";
}
#debug_log(0,'amiv c %s',$vals->{vals});
return \%vals;
}
sub antivirus_map_check_line {
my ($l,$vals) = @_;
#debug_log(0,'amcl l %s',$l) unless ($vals->{clean});
while ($l =~ /^\s*(\S+?):(\S+)\s*(.*?)$/) {
my $what = lc($1);
my $regex = $2;
$l = $3;
my $matchx = 0;
#debug_log(0,'amcl s %s %s',$what,$regex) unless ($vals->{clean});
if ($what eq 'map') {
my ($mapf,$mapn);
if ($regex =~ /^(\S+):(.*)$/) {
$mapf = $1;
$mapn = $2;
} else {
$mapf = $regex;
$mapn = '\S+';
}
$mapn =~ s/\*$/*?/;
#debug_log(0,'amcl x %s %s',$mapf,$mapn) unless ($vals->{clean});
my $maps = read_list_file($mapf);
if ($maps && @{$maps}) {
foreach my $ll (@{$maps}) {
my $mapl = $ll;
$mapl =~ s/^\s+//;
$mapl =~ s/\s+$//;
#debug_log(0,'amcl xl %s %s',$mapn,$mapl) unless ($vals->{clean});
if ($mapl =~ /^$mapn\s+(.+?)$/i) {
$regex = $1;
#debug_log(0,'amcl lx r:"%s" n:"%s" l:%s',$regex,$mapn,$mapl) unless ($vals->{clean});
if ($vals->{virusname} =~ /$regex/) {
#debug_log(0,'amcl e %s %s %s',$mapf,$mapn,$regex) unless ($vals->{clean});
$matchx ++;
last;
}
}
}
}
} elsif (defined($vals->{$what}) && $vals->{$what} ne '' && $vals->{$what} =~ /^$regex$/i) {
$matchx ++;
}
unless ($matchx) {
$match = 0;
last;
}
$match += $matchx;
}
#debug_log(0,'amcl r %u %s',$match,$l) unless ($vals->{clean});
return ($match,$l);
}
sub antivirus_map_catact {
my $vals = antivirus_map_init_vals(@_);
#return (0,'ok','ok') if ($vals->{code} == 1 && $vals->{virusname} eq '' &&
# $vals->{action} eq 'tempfail' && $vals->{category} eq 'not-installed');
debug_log(1,'amca %s',$vals->{vals}) unless ($vals->{clean});
#return (0,$vals->{category},$vals->{action}); # Not ready? Or just useless? Who knows?
my $virmap = read_list_file('antivirus','\s*\=');
return (0,$vals->{category},$vals->{action}) unless ($virmap && @{$virmap});
my $category;
my $action;
my $hits = 0;
foreach my $ll (@{$virmap}) {
my $line = $ll;
debug_log(1,'amca l %s',$line) unless ($vals->{clean});
next unless ($line =~ /^\s*\=\s*(.*?)[\r\n\s]*$/);
my ($match,$l) = antivirus_map_check_line($1,$vals);
next unless ($match);
debug_log(1,'amca m %s',$l);
$l =~ s/^\s*//s;
$l =~ s/\s*$//s;
my ($ncat,$nact,$l) = split(/\s*,\s*/,$l,3);
if ($ncat && !$category) {
$category = $ncat;
debug_log(1,'amca nc %s',$ncat);
}
if ($nact && !$action) {
$action = $nact;
debug_log(1,'amca na %s',$nact);
}
debug_log(-1,'antivirus_map_catact ? %s',$l) if (defined($l) && $l ne '');
$hits ++;
last if ($action && $category);
}
$category = $vals->{category} unless ($category);
$action = $vals->{action} unless ($action);
debug_log(1,'amca %u %s %s',$hits,$category,$action) unless ($vals->{clean});
return ($hits,$category,$action);
}
#***********************************************************************
# SpamAssassin stuff.
#***********************************************************************
sub spam_scanned_header {
my ($results,$pass) = @_;
$spimfo = $MyFilterHostName;
if (defined($results)) {
$spimfo .= ' using SpamAssassin '.$results->{saver} if ($results->{saver});
my @spimfo = ();
push @spimfo, 'hard limit '.$results->{req} if (defined($results->{req}) && !$pass);
#push @spimfo, 'learned as '.$results->{learned} if ($results->{learned});
push @spimfo, 'calculated on bounce' if ($results->{bounced});
$spimfo .= ' ('.join(', ',@spimfo).')' if (@spimfo);
}
return $spimfo;
}
sub spam_info_header {
my ($results,$spampass) = @_;
return '-' unless (defined($results));
my $namehead = '';
if ($results->{snames} && (length($results->{snames}) > 44) && load_modules('Text::Wrap')) {
my $twco = $Text::Wrap::columns; my $twbo = $Text::Wrap::break; my $twho = $Text::Wrap::huge; my $twso = $Text::Wrap::separator;
$Text::Wrap::columns = 74;
$Text::Wrap::break = ',';
$Text::Wrap::huge = 'overflow';
$Text::Wrap::separator = ",\n";
my $nht = wrap("\t","\t",$results->{snames});
$nht = "\t$nht" if ($nht !~ /^\t/);
$namehead = ";\n$nht";
$Text::Wrap::columns = $twco; $Text::Wrap::break = $twbo; $Text::Wrap::huge = $twho; $Text::Wrap::separator = $twso;
} elsif ($results->{snames}) {
$namehead = '; '.$results->{snames};
}
my @basehead = (sprintf('%03.1f',$results->{hits}));
push @basehead, @{$spampass} if ($spampass && @{$spampass});
return sprintf('%s%s',join(', ',@basehead),$namehead);
}
sub spamassassin_header {
my ($results,$fmt) = @_;
my @hdr1 = ();
push @hdr1, $results->{sa_version}.'/'.$results->{sa_subversion} if ($results->{sa_version} || $results->{sa_subversion});
push @hdr1, 'Score: '.$results->{sa_score} if ($results->{sa_score});
push @hdr1, 'AWL: '.$results->{sax_awl} if ($results->{sax_awl});
push @hdr1, 'Languages: '.$results->{sa_languages} if ($results->{sa_languages});
push @hdr1, 'Learned: '.$results->{learned} if ($results->{learned});
push @hdr1, 'Bayes: '.$results->{sa_bayes} if ($results->{sa_bayes});
my @hdr = ();
push @hdr, join('; ',@hdr1) if (@hdr1);
push @hdr, $results->{sa_tokensummary} if ($results->{sa_tokensummary} && $results->{sa_tokensummary} !~ /^\s*Bayes not run.?\s*$/i);
push @hdr, 'Ham tokens: '.mqp($results->{sa_hammytokens}) if ($results->{sa_hammytokens} && $results->{sa_hammytokens} !~ /^\s*Tokens not available.?\s*$/i);
push @hdr, 'Spam tokens: '.mqp($results->{sa_spammytokens}) if ($results->{sa_spammytokens} && $results->{sa_hammytokens} !~ /^\s*Tokens not available.?\s*$/i);
push @hdr, 'VirScan: '.mqp($results->{sah_virus}) if ($results->{sah_virus} && lc($results->{sah_virus}) ne 'no');
@hdr1 = ();
push @hdr1, sprintf('%uc %uw',$results->{sa_extracttextchars},$results->{sa_extracttextwords}) if ($results->{sa_extracttextchars});
push @hdr1, sprintf('<%s>',$results->{sa_extracttextflags}) if ($results->{sa_extracttextflags});
push @hdr1, sprintf('[%s]',$results->{sa_extracttexttools}) if ($results->{sa_extracttexttools});
push @hdr, join(' ','Extracted:',@hdr1) if (@hdr1);
return '-' unless (@hdr);
return join("\n\t",@hdr);
}
sub spamassassin_report {
my ($results,$type) = @_;
#debug_log(0,'spamassassin_report');
return '' unless (defined($results) && @{$results->{results}});
my @results = sort { $a->[0] <=> $b->[0] } @{$results->{results}};
my $tit = sprintf('Spam test results (%u hits, %05.3f points)',scalar @results,$results->{hits});
debug_log(3,'spamassassin_report %s %u %s',$type,scalar @results,$tit);
if ($type =~ /^[Hh]/ && load_modules('HTML::Entities')) {
#debug_log(0,'spamassassin_report H');
my $tab = "<table border=1 cellpadding=1><caption>$tit</caption><tr valign=\"baseline\"><th>Score</th><th>Rule</th><th>Description</th></tr>";
for (my $i=0;$i<@results;$i++) {
$results[$i]->[1] =~ s/[\r\n]+//gs;
$results[$i]->[2] =~ s/^[\r\n]+//s;
$results[$i]->[2] =~ s/[\r\n]+$//s;
$tab .= sprintf('<tr valign="top" class="%s"><td align="right">%03.1f</td><td align="left">%s</td><td align="left">%s</td></tr>',
,$i%2?'even':'odd',$results[$i]->[0],
HTML::Entities::encode_entities($results[$i]->[1]),
HTML::Entities::encode_entities($results[$i]->[2]),
);
}
$tab =~ s/[\r\n]+/<br>/gs;
$tab .= "</table>\n";
#debug_log(0,'spamassassin_report H %s',$tab);
return $tab;
}
#debug_log(0,'spamassassin_report ?');
return '' unless (load_modules('Text::ASCIITable'));
#debug_log(0,'spamassassin_report A');
my $tab = Text::ASCIITable->new();
return '' unless ($tab);
#debug_log(0,'spamassassin_report T');
$tab->setCols('Score','Rule','Description');
$tab->setOptions({headingText=>$tit,drawRowLine=>1}) if ($type =~ /^[Ff]/);
$tab->setOptions({hide_HeadRow=>1,hide_HeadLine=>1,hide_FirstLine=>1,hide_LastLine=>1,drawRowLine=>0}) if ($type =~ /^[Cc]/);
foreach my $row (@results) {
$row->[0] = sprintf('%05.3f',$row->[0]);
#debug_log(0,'spamassassin_report row %s',join('|',@{$row}));
$tab->addRow($row);
}
my $out = ($type =~ /^[Cc]/) ? $tab->draw(undef,undef,undef,[' ',' ',' ']) : $tab->draw;
$out =~ s/[\r\n]+$/\n/s;
#debug_log(0,'spamassassin_report %s %s',$type,$out);
return $out;
}
sub spamassassin_info_report {
my ($results,$spec,$pre) = @_;
return '' unless (defined($results) && @{$results->{results}});
$spec = '' unless (defined($spec));
my $pre = 'SA ' unless (defined($pre));
my $info = '';
$info .= $pre.'Result: '.$results->{result}."\n" if (defined($results->{result}));
$info .= $pre.'Score: '.$results->{hits}."\n" if (defined($results->{hits}));
$info .= $pre.'Limit: '.$results->{req}."\n" if (defined($results->{req}));
$info .= $pre.'Languages: '.$results->{sa_languages}."\n" if ($results->{sa_languages});
$info .= $pre.'Learned: '.$results->{learned}."\n" if ($results->{learned});
my @binfo = ();
push @binfo, $results->{sa_bayes} if ($results->{sa_bayes});
push @binfo, $results->{sa_tokensummary} if ($results->{sa_tokensummary});
$info .= $pre.'Bayes: '.join('; ',@binfo)."\n" if (@binfo);
$info .= $pre.'Ham tokens: '.$results->{sa_hammytokens}."\n" if ($results->{sa_hammytokens});
$info .= $pre.'Spam tokens: '.$results->{sa_spammytokens}."\n" if ($results->{sa_spammytokens});
$info .= $pre.'VirScan: '.$results->{sah_virus}."\n" if ($results->{sah_virus} && lc($results->{sah_virus}) ne 'no');
$info .= $pre."Bounced: yes\n" if ($results->{bounced});
$info .= $pre.'Names: '.join(', ',@{$results->{names}})."\n" if ($spec =~ /[Hh]/ && @{$results->{names}});
$info .= $pre.'Extract count: '.sprintf('%u chars, %u words',$results->{sa_extracttextchars},$results->{sa_extracttextwords})."\n" if ($results->{sa_extracttextchars});
$info .= $pre.'Extract flags: '.$results->{sa_extracttextflags}."\n" if ($results->{sa_extracttextflags});
$info .= $pre.'Extract tools: '.$results->{sa_extracttexttools}."\n" if ($results->{sa_extracttexttools});
$info .= $pre.'Extract types: '.$results->{sa_extracttexttypes}."\n" if ($results->{sa_extracttexttypes});
$info .= $pre.'Extract extensions: '.$results->{sa_extracttextextensions}."\n" if ($results->{sa_extracttextextensions});
return $info;
}
sub hiloscore_report {
my ($entity,$report,$iposhead,$authresults) = @_;
return unless ($hilo_entries);
return if (defined($hilo_keep) && $hilo_keep<1);
my $hits = defined($report->{hits}) ? $report->{hits} : 0;
my $req = defined($report->{req}) ? $report->{req} : 0;
my $names = defined($report->{names}) ? join(',',@{$report->{names}}) : '';
return if ($names =~ /^(|.*,)GTUBE(|,.*)$/);
if ($hilo_entries > 0) {
my $km = $hilo_entries+$hilo_margin;
my @tmp = ($hits);
my $tmq = '';
if ($hilo_keep) {
$tmq = ' AND hilo_stamp>?';
push @tmp, (time()-$hilo_keep);
}
my $cc = sql_select_one("SELECT count(hilo_score) FROM hiloscores WHERE hilo_score>?$tmq",@tmp);
$cc = 0 unless ($cc);
$cc = sql_select_one("SELECT count(hilo_score) FROM hiloscores WHERE hilo_score<?$tmq",@tmp) if ($cc > $km);
$cc = 0 unless ($cc);
return if ($cc > $km);
}
return unless (open(MF,'<','./INPUTMSG'));
my $eml = '';
while (my $l = <MF>) {
$l =~ s/[\r\n]+//gs;
$eml .= "$l\n";
last if (length($l) > 1024*1024);
}
close(MF);
debug_log(3,'hiloscore_report %03.1f %u',$hits,$cc);
my $info = '';
my $country = get_ip_location($RelayAddr);
my $time = time_string(time_since_stamp());
$info .= "MF Version: $FilterVersion\n";
$info .= "MD Version: ".md_version()."\n";
eval { $info .= "SA Version: ".Mail::SpamAssassin->Version()."\n"; };
$info .= "\n";
$info .= "Relay Addr: $RelayAddr\n" if ($RelayAddr);
$info .= "Relay Host: $RelayHostname\n" if ($RelayHostname && $RelayHostname !~ /^\[$RelayAddr\]$/);
$info .= "Relay Helo: $Helo\n" if ($Helo);
$info .= "Relay Orig: $country\n" if ($country);
$info .= "Relay OS: $iposhead\n" if ($iposhead);
$info .= "\n";
$info .= "Mail From: $Sender\n" if ($Sender);
foreach my $rcpt (@Recipients) {
$info .= "Rcpt To: $rcpt\n" if ($rcpt);
}
if ($entity && $entity->head) {
my $subj = $entity->head->get('Subject');
if (defined($subj) && $subj !~ /^\s*$/) {
$subj = mqpcs('utf8',decode_header($subj));
$info .= "Subject: $subj\n";
}
}
if ($GreyListAction) {
my $msgi = msgl_info_str($entity->head->get('Message-ID'),$Sender,@Recipients) if ($entity && $entity->head);
$msgi = " ($msgi)" if ($msgi);
$info .= "Grey List: $GreyListAction$msgi\n";
}
if ($FoundSuspected || $FoundVirus) {
$info .= "\n";
$info .= "Scan Found: Virus\n" if ($FoundVirus);
$info .= "Scan Found: Suspect\n" unless ($FoundVirus);
}
if (@$authresults) {
$info .= "\n";
foreach my $ari (@{$authresults}) {
$info .= "Auth Check: $ari\n";
}
}
$info .= "\n";
$info .= spamassassin_info_report($report);
$info .= "\n";
$info .= "Msg Size: ".(-s './INPUTMSG')."\n";
$info .= "Check Time: $time\n" if ($time);
sql_execute('INSERT INTO hiloscores (hilo_stamp,hilo_score,hilo_spam,hilo_names,hilo_report,hilo_info,hilo_message) VALUES (?,?,?,?,?,?,?)',
time(),$hits,($hits>$req),$names,spamassassin_report($report,'compact'),$info,$eml);
}
# run spamassassin
my $nospamassassin = 0;
my %spamassassin_extra_hits = ();
my $forcespamcheck = 0;
my $wantsspamcheck = 0;
sub spamassassin_hit {
my ($name,$score,$desc) = @_;
return 0 unless ($name);
$score = 0 unless ($score);
debug_log(1,'spamassassin_hit %s %04.2f %s',$name,$score,$desc);
$spamassassin_extra_hits{uc($name)} = {score=>$score,desc=>$desc,name=>$name};
return scalar keys %spamassassin_extra_hits;
}
sub spamassassin_virus_hit {
my $vals = antivirus_map_init_vals(@_);
#debug_log(0,'savh %s',$vals->{vals}) unless ($vals->{clean});
my $virmap = read_list_file('antivirus','\s*\@');
return 0 unless ($virmap && @{$virmap});
#debug_log(0,'spamassassin_virus_hit r %u',scalar @{$virmap}) unless ($vals->{clean});
my $hits = 0;
foreach my $ll (@{$virmap}) {
my $line = $ll;
debug_log(1,'spamassassin_virus_hit l %s',$ll) unless ($vals->{clean});
next unless ($line =~ /^\s*\@\s*(.*?)[\r\n\s]*$/);
my $l = $1;
my $match = 0;
my ($match,$l) = antivirus_map_check_line($1,$vals);
next unless ($match);
debug_log(1,'spamassassin_virus_hit m %s',$l);
next unless ($l =~ /^\s*(=?)([-0-9.]*)(\s.*)?$/);
my $scpre = $1;
my $score = $2;
$l = $3;
$line =~ s/[\r\n]+//gs;
debug_log(1,'spamassassin_virus_hit m %s',$line);
my ($rule,$desc);
if ($l && $l =~ /^\s*(\S+)(\s.*)?$/) {
$rule = $1;
$desc = $2;
$desc =~ s/^\s+//s;
$desc =~ s/\s+$//s;
}
$rule = $vals->{virusname} unless ($rule);
$rule = 'VirusScanHit' unless ($rule);
$desc = "Virus scanner found something." unless ($desc);
$rule =~ s/[\s\/]/./g;
debug_log(1,'spamassassin_virus_hit r %03.1f %s %s',$score,$rule,$desc);
spamassassin_hit($rule,$score,$desc) unless ($score eq '-');
$wantsspamcheck ++;
$hits ++;
last if ($scpre eq '=');
}
return $hits;
}
sub spamassassin_log_callback {
my ($level,$msg) = @_;
debug_log(0,'SALog: < %s %s',$level,$msg);
if ($level =~ /warn/i) {
$level = 'warning';
} elsif ($level =~ /err/i) {
$level = 'err';
} elsif ($level =~ /info/i) {
$level = 'info';
} elsif ($level =~ /de?bu?g/i) {
$level = 'debug';
} else {
$level = 'notice';
}
debug_log(0,'SALog: > "%s" "%s"',$level,$msg);
}
sub init_spamassassin_module {
unless ($nospamassassin || $Features{"SpamAssassin"}) {
$Features{"SpamAssassin"} = load_modules('Mail::SpamAssassin ()') unless ($Features{"SpamAssassin"});
$nospamassassin = 1 unless ($Features{"SpamAssassin"});
if (!$nospamassassin && load_modules('Mail::SpamAssassin::Logger::Callback','Mail::SpamAssassin::Logger')) {
Mail::SpamAssassin::Logger::Callback::SetCallback(\&spamassassin_log_callback);
eval {
Mail::SpamAssassin::Logger::remove('stderr');
Mail::SpamAssassin::Logger::add(method=>'Callback');
Mail::SpamAssassin::Logger::add_facilities('info');
};
}
}
return spam_assassin_init();
}
sub init_spamassassin_client {
return load_modules('Mail::SpamAssassin::Client');
}
sub init_spamassassin {
return ($spamdsocket || ($spamdhost && $spamdport))
? init_spamassassin_client(@_)
: init_spamassassin_module(@_);
}
my %saclient = ();
sub check_with_spamassassin_client {
my ($call,$notdefault,$message) = @_;
debug_log(5,'spam: SpamAssassin Client %s',$call);
my $user = $notdefault ? $call : 'mdf';
my $salarm;
unless (defined($saclient{$user})) {
return {errmsg=>'sc load error',errlev=>'f'} unless (load_modules('Mail::SpamAssassin::Client'));
$salarm = 0;
eval {
$saclient{$user} = new Mail::SpamAssassin::Client({username=>$user,socketpath=>$spamdsocket,port=>$spamdport,host=>$spamdhost});
local $SIG{ALRM} = sub { die "timeout\n" };
$salarm = alarm($SATimeout?$SATimeout:15*60);
$saclient{$user} = 0 unless ($saclient{$user} && $saclient{$user}->ping);
};
alarm($salarm) if (defined($salarm));
}
return {errmsg=>'sc connect failure',errlev=>'t'} unless ($saclient{$user});
unless ($message) {
return {errmsg=>'sc internal error',errlev=>'t'} unless (open(MSG,'<','./INPUTMSG'));
my @msg = <MSG>;
close(MSG);
my @sah = ();
push @sah, "Return-Path: $Sender\n";
push @sah, split(/^/m,synthesize_received_header());
push @sah, sprintf("Apparently-To: %s\n",join(", ",@Recipients));
unshift @msg, @sah;
my $msg = join('',@msg);
$message = \$msg;
}
#my $tmpfn = sprintf('/tmp/%010u%010u',time(),$$);
#if (open(TMPF,'>',"$tmpfn.eml")) {
# print TMPF $$message;
# close(TMPF);
# debug_log(0,'> %s',"$tmpfn.eml");
#}
debug_log(2,'spam: SpamAssassin Client process');
my $sares;
my $salarm = 0;
eval {
local $SIG{ALRM} = sub { die "timeout\n" };
$salarm = alarm($SATimeout?$SATimeout:15*60);
$sares = $saclient{$user}->process($$message);
};
alarm($salarm) if (defined($salarm));
if ($@) {
my $msg = $@;
$msg =~ s/[\r\n\s]+$//s;
$msg =~ s/^[\r\n\s]+//s;
$msg =~ s/[\r\n]+$/; /s;
$msg =~ s/\s+/ /;
do_action_quarantine_entire_message('error',"Copied to quarantine due to SpamAssassin error.");
return {errmsg=>"sc $msg",errlev=>'t'};
}
return {errmsg=>'no result',errlev=>'t'} unless ($sares && %{$sares});
my %scanresults = ();
$scanresults{hits} = $sares->{score};
$scanresults{req} = $sares->{threshold};
$sares->{message} =~ s/\r?\n\r?\n.*$//s;
my $ch;
foreach my $l (split/\r?\n/,$sares->{message}) {
if ($l =~ /^\s+.*/) {
next unless ($ch);
$l =~ s/^\t// unless ($ch eq 'summary');
$l = "$l\n" if ($ch eq 'summary');
$scanresults{"sa_$ch"} .= $l;
next;
}
$ch = 0;
next unless ($l =~ /^X-Spam-([a-z]+):\s*(.*)$/i);
next if (defined($scanresults{"sa_$1"}));
$ch = lc($1);
$l = $2;
$l = "$l\n" if ($ch eq 'summary');
$scanresults{"sa_$ch"} = $l;
}
$scanresults{sa_summary} =~ s/\s+(-?\d\.\d \S)/\n$1/gs;
foreach my $k (keys %scanresults) {
$scanresults{$k} =~ s/[ \t]+/ /gs if ($k =~ /^sa_/);
}
$scanresults{hits} = $scanresults{'sa_score'} if (defined($scanresults{'sa_score'}));
$scanresults{req} = $scanresults{'sa_required'} if (defined($scanresults{'sa_required'}));
$scanresults{'sah_clamav-result'} = $scanresults{'sa_virus'} if ($scanresults{'sa_virus'});
$scanresults{saver} = $scanresults{'sa_version'} if (defined($scanresults{'sa_version'}));
if (defined($scanresults{'sa_autolearn'})) {
$scanresults{learned} = $scanresults{'sa_autolearn'};
$scanresults{learned} = '' unless ($scanresults{learned} =~ /^(?:h|sp)am$/i);
}
#if (open(TMPF,'>',"$tmpfn.res")) {
# foreach my $k (keys %scanresults) {
# print TMPF "$k: $scanresults{$k}\n";
# }
# close(TMPF);
# debug_log(0,'> %s',"$tmpfn.res");
#}
delete $scanresults{errlev} if (exists $scanresults{errlev});
return \%scanresults;
}
sub check_with_spamassassin_module {
my ($call,$noautolearn,$message) = @_;
debug_log(5,'spam: SpamAssassin Module %s',$call);
my $sao = init_spamassassin_module();
return {errmsg=>'sa init error',errlev=>'f'} unless ($sao);
if ($message) {
return {errmsg=>'sa internal error',errlev=>'t'} unless (open(MF,'>','./INPUTMSG.sax'));
debug_log(1,'spam: displace INPUTMSG');
print MF $$message;
close(MF);
return {errmsg=>'sa internal error',errlev=>'t'} unless (rename('./INPUTMSG','./INPUTMSG.real'));
unless (rename('./INPUTMSG.sax','./INPUTMSG')) {
rename('./INPUTMSG.real','./INPUTMSG');
return {errmsg=>'sa internal error',errlev=>'t'};
}
}
my %scanresults = (req=>$sao->{conf}->{required_score});
my $orgautolearn;
if ($noautolearn) {
$orgautolearn = $sao->{conf}->{bayes_auto_learn};
$sao->{conf}->{bayes_auto_learn} = 0;
}
debug_log(2,'spam: SpamAssassin Module run');
my ($sastatus,$sam);
my $salarm = 0;
eval {
local $SIG{ALRM} = sub { die "timeout\n" };
$salarm = alarm($SATimeout?$SATimeout:15*60);
$sam = spam_assassin_mail();
$sastatus = $sao->check($sam) if ($sam);
};
alarm($salarm) if (defined($salarm));
if ($@) {
my $msg = $@;
$msg =~ s/[\r\n\s]+$//s;
$msg =~ s/^[\r\n\s]+//s;
$msg =~ s/[\r\n]+$/; /s;
$msg =~ s/\s+/ /;
return {errmsg=>"sa $msg",errlev=>'t'};
}
if (defined($sastatus)) {
$scanresults{hits} = $sastatus->get_hits;
$scanresults{req} = $sastatus->get_required_hits();
$scanresults{learned} = $sastatus->get_autolearn_status();
$scanresults{learned} = '' unless ($scanresults{learned} =~ /^(?:h|sp)am$/i);
foreach my $tga (('summary','score','version','subversion','tests','testsscores','languages','bayes','hammytokens:10','spammytokens:10','tokensummary')) {
my $tag = $tga;
my $val;
if ($tag =~ /^(.+?):(.+)$/) {
$tag = $1;
my $par = $2;
$val = $sastatus->get_tag($tag,$par);
} else {
$val = $sastatus->get_tag($tag);
}
next unless ($val);
next if ($val =~ /\snot\s(run|available)\.?$/);
$scanresults{"sa_$tag"} = $val if ($val);
}
foreach my $tga (('ClamAV-Result')) {
my $val = $sastatus->get($tga);
next unless (defined($val));
next if ($val =~ /^[\s\r\n]*$/);
my $tag = lc($tga);
$scanresults{"sah_$tag"} = $val;
}
$sastatus->finish();
}
$scanresults{saver} = Mail::SpamAssassin->Version();
$sam->finish() if ($sam);
$sao->{conf}->{bayes_auto_learn} = $orgautolearn if (defined($orgautolearn));
if ($message) {
debug_log(1,'spam: restore INPUTMSG');
unlink('./INPUTMSG');
rename('./INPUTMSG.real','./INPUTMSG');
}
delete $scanresults{errlev} if (exists $scanresults{errlev});
return \%scanresults;
}
sub check_with_spamassassin_ex {
my ($call,$noautolearn,$message,$noassassin) = @_;
return undef if ($noassassin && !%spamassassin_extra_hits);
my $scanresults = $noassassin ? {} : ($spamdsocket || ($spamdhost && $spamdport))
? check_with_spamassassin_client($call,$noautolearn,$message,$noassassin)
: check_with_spamassassin_module($call,$noautolearn,$message,$noassassin);
return {errmsg=>'internal error',errlev=>'f'} unless ($scanresults);
debug_log(5,'spam: SpamAssassin done');
$scanresults->{hits} = 0 unless (defined($scanresults->{hits}));
$scanresults->{req} = 999 unless (defined($scanresults->{req}));
$scanresults->{names} = [] unless (defined($scanresults->{names}));
$scanresults->{snames} = '' unless (defined($scanresults->{snames}));
$scanresults->{saver} = 0 unless (defined($scanresults->{saver}));
$scanresults->{learned} = '' unless (defined($scanresults->{learned}));
$scanresults->{results} = [] unless (defined($scanresults->{results}));
$scanresults->{stars} = '' unless (defined($scanresults->{stars}));
my %scores = ();
if ($scanresults->{sa_testsscores}) {
foreach my $score (split(/,/,$scanresults->{sa_testsscores})) {
if ($score =~ /^(.*)=(.*?)$/) {
$scores{$1} = $2;
}
}
}
if ($scanresults->{sa_summary}) {
$scanresults->{sa_summary} =~ s/\n\s+/ /gs;
foreach my $l (split(/[\r\n]+/,$scanresults->{sa_summary})) {
if ($l =~ /^\s*(-?\d+\.\d+)\s+(\S+)\s*(.*?)\s*$/) {
my $score = $1;
my $rule = $2;
my $desc = $3;
$score = $scores{$rule} if (defined($scores{$rule}));
push @{$scanresults->{results}}, [$score,$rule,$desc];
$scanresults->{results}->[$#{$scanresults->{results}}]->[2] = '' unless ($scanresults->{results}->[$#{$scanresults->{results}}]->[2]);
} elsif ($l =~ /^\s*(\S+.*?)\s*$/) {
$scanresults->{results}->[$#{$scanresults->{results}}]->[2] .= "\n" if ($scanresults->{results}->[$#{$scanresults->{results}}]->[2]);
$scanresults->{results}->[$#{$scanresults->{results}}]->[2] .= $1;
}
}
}
$scanresults->{'sax_awl'} = $scores{'AWL'} if ($scores{'AWL'} && !defined($scanresults->{'sax_awl'}));
push @{$scanresults->{names}}, split(/\s*,\s*/,$scanresults->{sa_tests}) if ($scanresults->{sa_tests});
debug_log(2,'spam: SpamAssassin %05.3f %u %s',$scanresults->{hits},$scanresults->{req},$scanresults->{sa_testsscores});
if (%spamassassin_extra_hits) {
$scanresults->{hits} = 0 unless (defined($scanresults->{hits}));
foreach my $sehi (values %spamassassin_extra_hits) {
$scanresults->{hits} += $sehi->{score};
push @{$scanresults->{names}}, $sehi->{name};
push @{$scanresults->{results}}, [$sehi->{score},$sehi->{name},$sehi->{desc}];
debug_log(1,'spam: extra hit %s %05.3f %s',$sehi->{name},$sehi->{score},$sehi->{desc});
}
}
if ($scanresults->{hits} >= 40) {
$scanresults->{stars} = "*" x 40;
} elsif (int($scanresults->{hits}) > 0) {
$scanresults->{stars} = "*" x int($scanresults->{hits});
}
$scanresults->{snames} = join(',',@{$scanresults->{names}}) if (@{$scanresults->{names}});
$scanresults->{result} = ($scanresults->{hits} > $scanresults->{req}) ? 'spam' : 'ham';
return $scanresults;
}
sub check_with_spamassassin {
my ($noautolearn,$call) = @_;
$call = 'check' unless ($call);
return check_with_spamassassin_ex($call,$noautolearn);
}
sub check_with_spamassassin_bounced {
my ($message) = @_;
spamassassin_hit('SCORED_ON_BOUNCED',0,'Calculated on bounced message');
my $scanresults = check_with_spamassassin_ex('bounce',1,$message);
$scanresults->{bounced} = 1;
delete $spamassassin_extra_hits{'SCORED_ON_BOUNCED'};
return $scanresults;
}
sub check_without_spamassassin {
spamassassin_hit('NO_SPAMASSASSIN',0,'SpamAssassin was not used');
my $scanresults = check_with_spamassassin_ex('without',1,undef,1);
$scanresults->{noassassin} = 1;
delete $spamassassin_extra_hits{'NO_SPAMASSASSIN'};
return $scanresults;
}
# read and parse a bounce
my $bounceo;
my $bouncef;
sub read_bounce_msg {
my ($msgf) = @_;
$msgf = './INPUTMSG' unless (defined($msgf));
return $bounceo if ($bouncef && $bouncef eq $msgf);
$bounceo = undef;
$bouncef = $msgf;
return $bounceo unless (load_modules('Mail::DeliveryStatus::BounceParser'));
my $imbfh;
return undef unless (open($imbfh,'<',$msgf));
debug_log(5,'bounce: parse');
$bounceo = eval { Mail::DeliveryStatus::BounceParser->new($imbfh); };
close($imbfh);
debug_log(5,'bounce: parsed %s',$bounceo ? 'ok' : 'fail');
return $bounceo;
}
sub collect_bouncing_addresses {
return 0 unless ($BncCollect);
return 0 unless ($Sender =~ /^<?>?$/);
my $bounce = read_bounce_msg();
return 0 unless ($bounce && $bounce->is_bounce);
my $bc = 0;
foreach my $rep ($bounce->reports) {
next unless ($rep);
my $prob = $rep->get('std_reason');
next unless ($prob && $prob !~ /no_problem/i);
my $errm = $rep->get('reason');
my $seve = 1;
if ($prob eq 'user_unknown') {
$seve = 4;
} elsif ($prob eq 'domain_error') {
$seve = 3;
} elsif ($prob eq 'unknown') {
if ($errm eq '550 unrouteable address') {
$seve = 3;
} else {
$seve = 2
}
}
next unless ($seve > 0);
my $addr = lc($rep->get('email'));
stats_log('bounce',[@Recipients],$Subject,$addr,$prob,$errm,$bounce->orig_message_id,$seve);
my $now = time();
my @cmds = ();
push @cmds, ['INSERT OR IGNORE INTO bouncing (bnc_address,bnc_stamp) VALUES (?,?)',$addr,$now];
push @cmds, $BncExpire ?
['UPDATE bouncing SET bnc_severity=?,bnc_problem=?,bnc_reason=?,bnc_stamp=? WHERE bnc_address=? AND (bnc_severity<=? OR bnc_stamp<?)',$seve,$prob,$errm,$now,$addr,$seve,$now-$BncExpire] :
['UPDATE bouncing SET bnc_severity=?,bnc_problem=?,bnc_reason=?,bnc_stamp=? WHERE bnc_address=? AND bnc_severity<=?',$seve,$prob,$errm,$now,$addr,$seve];
push @cmds, ['UPDATE bouncing SET bnc_count=bnc_count+1,bnc_stamp=? WHERE bnc_address=?',$now,$addr];
sql_execute_multi(@cmds);
debug_log(3,'bounce: coll %s %s %s "%s"',$seve,$addr,$prob,$errm);
my $hinf = "$seve <$addr> $prob ($errm)";
$hinf =~ s/\r\n]+/; /gs;
do_action_insert_header($entity,"X-Bounce",$hinf);
$bc ++;
}
return $bc;
}
sub extract_bounced_msg {
my ($bounce) = @_;
return '' unless ($bounce);
debug_log(4,'bounce: extract');
return $bounce->orig_message->as_string if ($bounce->orig_message);
return $bounce->orig_header->as_string."\n*\n" if ($bounce->orig_header);
debug_log(4,'bounce: fake');
my $orig = '';
$orig .= 'To: '.join(',',$bounce->addresses)."\n" if ($bounce->addresses);
$orig .= 'Message-Id: '.$bounce->orig_message_id."\n" if ($bounce->orig_message_id);
foreach my $rep ($bounce->reports) {
foreach my $tag ($rep->tags) {
next if ($tag eq 'Raw');
my @val = $rep->get($tag);
foreach my $v (@val) {
$tag = ucfirst(lc($tag));
$tag =~ s/_/-/g;
$tag =~ s/(-[a-z])/uc($1)/ge;
$orig .= "X-Bounce-$tag: $v\n";
}
}
}
if ($orig) {
$orig .= 'From: '.$Recipients[0]."\n";
$orig .= "\n*\n";
}
return $orig;
}
# Report SA results.
sub spamassassin_result_report {
my ($report) = @_;
my $resrep = spamassassin_info_report($report,'h');
push @result_reports, $resrep if ($resrep);
$resrep = spamassassin_report($report,'fancy');
push @result_reports, $resrep if ($resrep);
}
sub spamassassin_quarantine_report {
my ($results) = @_;
return unless (open OUTFILE, ">" . get_quarantine_dir() . "/SPAM_REPORT" );
print OUTFILE spamassassin_info_report($results,'h','');
print OUTFILE macros_text('AP');
print OUTFILE "Report:\n";
print OUTFILE spamassassin_report($results,'compact');
close OUTFILE;
}
sub not_check_for_spam_wrtsl {
my ($ds,$sst,$sml,$sms) = @_;
return 1 unless ($sst);
if ($sml) {
my $lav = get_load_average();
if ($lav > $sml) {
md_syslog('info', "SpamAssassin scan of $ds mail disabled due to load average >= $sml!");
return 1;
}
}
if ($sms) {
my $spv = get_swap_percentage();
if ($spv > $sms) {
md_syslog('info', "SpamAssassin scan of $ds mail disabled due to swap percentage >= $sms!");
return 1;
}
}
return 0;
}
sub not_check_for_spam {
my ($entity,$verified) = @_;
return 0 if ($is_result_query || $forcespamcheck);
my $relay_host_name = defined($RelayHostname) ? $RelayHostname : '';
$wantsspamcheck = 1 if (!$wantsspamcheck &&
check_spamassassin_not_bypass($RelayAddr,$relay_host_name,$Sender,\@Recipients,$entity,make_spam_hash()));
return 'internal' if (check_internal_whitelist($RelayAddr) && !check_any_relay_option($Helo,'outsider') &&
not_check_for_spam_wrtsl('internal',$SAScanLocal,$SALocalMaxLoad,$SALocalMaxSwap) &&
(!mail_is_outbound(@Recipients) || not_check_for_spam_wrtsl('outbound',$SAScanOutBound,$SAOutboundMaxLoad,$SAOutboundMaxSwap)));
return 'white' if (check_recipients_white('spam',\@Recipients));
return 'bypass' if (check_spamassassin_bypass($RelayAddr,$relay_host_name,$Sender,\@Recipients,$verified,$entity,make_spam_hash()));
return 'auth' if (check_authenticated() &&
not_check_for_spam_wrtsl('authenticated',$SAScanLocal,$SALocalMaxLoad,$SALocalMaxSwap) &&
(!mail_is_outbound(@Recipients) || not_check_for_spam_wrtsl('outbound',$SAScanOutBound,$SAOutboundMaxLoad,$SAOutboundMaxSwap)));
return 'history' if (!($wantsspamcheck || check_internal_whitelist($RelayAddr) || mail_is_outbound(@Recipients)) && check_no_spam($RelayAddr,$verified,0));
return 0;
}
# Check if message is spam.
sub check_for_spam {
my $entity = shift;
my $verified = shift;
my $ipos = shift;
my $iposver = shift;
my $iposhead = shift;
my $ipcountry = shift;
my $authresults = shift;
$ipos = '' unless ($ipos);
$iposver = '' unless ($iposver);
my $noassassin = 0;
my $gdbhostreset = 0;
my $all_recipients = "";
foreach my $currecipient(@Recipients) {
$all_recipients .= "," if ($all_recipients ne "");
$all_recipients .= $currecipient;
}
if ((-s './INPUTMSG' > $SASizeLimit) ||
(-s './INPUTMSG' > $mailtoobig)) {
$noassassin = 'size';
$forcespamcheck = 0;
} elsif (check_spam_time_exceeded()) {
$noassassin = 'time';
}
my $nospamcheck = not_check_for_spam($entity,$verified);
# Spam checks if SpamAssassin is installed
unless ($nospamcheck || $noassassin) {
$noassassin = 'noassassin' unless (init_spamassassin());
}
#$nospamcheck = 0; #Force for debug...
if ($nospamcheck) {
debug_log(1,'nospamcheck %s %s',$nospamcheck,$noassassin) unless ($nospamcheck eq 'internal');
push @result_reports, 'Not checked for SPAM.' if ($is_result_query);
spam_log('-',[$nospamcheck,$noassassin],[$ipos,$iposver],$ipcountry);
do_action_insert_header($entity,"X-Spam-Info","passed ($nospamcheck)") if (wants_extra_headers());
} else {
my $report;
if ($noassassin && !$forcespamcheck) {
debug_log(0,'noassassin %s',$noassassin);
$report = check_without_spamassassin();
} else {
if ($is_result_query) {
debug_log(1,'spam: running spamassassin query');
$report = check_with_spamassassin(1);
} else {
debug_log(2,"spam: running spamassassin");
if (check_internal_whitelist($RelayAddr)) {
$report = check_with_spamassassin(1,'local');
} else {
$report = check_with_spamassassin();
}
if (defined($report) && $report->{hits} <= $report->{req} && $Sender =~ /^<?>?$/ && $report->{snames} =~ /ANY_BOUNCE_MESSAGE/) {
my $bmsg = extract_bounced_msg(read_bounce_msg('./INPUTMSG'));
if ($bmsg) {
debug_log(2,"spam: running spamassassin bounce");
my $breport = check_with_spamassassin_bounced(\$bmsg);
if (defined($breport) && $breport->{hits} > $report->{hits}) {
$report = $breport;
debug_log(1,'spam: scored bounced');
}
}
}
}
}
if ($report && $report->{errlev} && !$is_result_query) {
debug_log(0,'Spam check error: %s, %s',$report->{errlev},$report->{errmsg});
if ($report->{errlev} eq 't') {
do_action_tempfail($report->{errmsg});
} elsif ($report->{errlev} eq 'r') {
do_action_bounce($report->{errmsg});
}
return (1,0);
}
return (1,0) unless (defined($report) && defined($report->{hits}) && defined($report->{req}));
spamassassin_result_report($report);
unless ($is_result_query) {
hiloscore_report($entity,$report,$iposhead,$authresults);
unless (check_internal_whitelist($RelayAddr)) {
# Report to releydb
report_relay($RelayAddr,$verified,$report->{hits});
# Report to nospamdb
report_no_spam($RelayAddr,$verified,$report->{hits});
# Reset greylist triplet(s)?
if (defined($greylist) && $greylist && defined($gdb_reset) && $report->{hits} > $gdb_reset) {
if ($gdb_reset_host) {
debug_log(2,"check_for_spam, reset greylist for data $RelayAddr");
greylist_reset($RelayAddr,"","");
} else {
foreach my $currecipient(@Recipients) {
debug_log(2,"check_for_spam, reset greylist for data $Sender at $RelayAddr to $currecipient");
greylist_reset($RelayAddr,$Sender,$currecipient);
}
}
} elsif ($report->{hits} > $gdb_host_reset) {
$gdbhostreset = 0;
greylist_reset_host($RelayAddr);
}
}
my $insider = (check_internal_whitelist($RelayAddr) && !check_any_relay_option($Helo,'outsider'));
if ($insider && $SAReportLocal && $report->{hits} > ((defined($SAReportLocalScore) && $SAReportLocalScore =~ /^[+-]?\d+$/) ? $SAReportLocalScore : $report->{req})) {
debug_log(0,'check_for_spam: report locally generated spam (%03.1f, %i, %i)',$report->{hits},$SAReportLocalScore,$report->{req});
report_spam_result($entity,'Local Spam');
}
my @spampass = ();
push @spampass, 'abuse', if (pass_abuse());
push @spampass, 'local', if ($insider && $SAPassLocal);
debug_log(0,'check_for_spam: spam pass (%s)',join(',',@spampass)) if (@spampass);
if (($report->{hits} > $report->{req}) && !@spampass) {
stats_log('reject','spam',[$report->{hits},$report->{req}]);
if ($report->{hits} < $report->{req}*2) {
debug_log(3,"check_for_spam: quarantine message");
do_action_quarantine_entire_message('stopped',"Message seems to be SPAM.");
spamassassin_quarantine_report($report);
}
debug_log(3,"check_for_spam: bounce message");
msgl_add($entity->head->get('Message-ID'),1,$Sender,@Recipients) if ($entity && $entity->head);
remember_spam_hash(make_spam_hash(),$report) if ($spamdb && ($insider || $report->{hits} > $report->{req}*2));
do_action_bounce(sprintf("Message seems to be spam (%03.1f/%i)",$report->{hits},$report->{req}));
} else {
do_action_insert_header($entity,"X-Spam-Scanned-By",spam_scanned_header($report,scalar @spampass));
do_action_insert_header($entity,"X-Spam-Info",spam_info_header($report,\@spampass));
#my $addsareport = 0;
#my $addsaheader = 0;
#foreach my $currecipient(@Recipients) {
# $addsareport ++ if ($currecipient =~ /^<?$WantsReports>?$/i);
# $addsaheader ++ if ($currecipient =~ /^<?$WantsExtraHeaders>?$/i);
#}
#if (defined(@new_recipients)) {
# foreach my $currecipient(@new_ecipients) {
# $addsareport ++ if ($currecipient =~ /^<?$WantsReports>?$/i);
# $addsaheader ++ if ($currecipient =~ /^<?$WantsExtraHeaders>?$/i);
# }
#}
my ($addsareport,$addsaheader) = wants_reports_or_headers();
#debug_log(0,'check_for_spam sar=%u sah=%u',$addsareport,$addsaheader);
do_action_insert_header($entity,"X-SpamAssassin",spamassassin_header($report)) if ($addsareport || $addsaheader);
if ($report->{hits} > 0) {
# We add a header which looks like this:
# X-Spam-Score: 6.8 (******)
#do_action_insert_or_change_header($entity,"X-Spam-Score", "$hits ($score)",1);
do_action_insert_or_change_header($entity,"X-Spam-Score",sprintf('%03.1f (%s)',$report->{hits},$report->{stars},1)) unless ($insider);
# If you find the SA report useful, add it, I guess...
if ($addsareport) {
$modhead{'Added SA report.'} ++;
action_add_part($entity, "text/html", "-suggest",
spamassassin_report($report,'html'),
"SpamAssassinReport.html", "inline");
}
} else {
# Delete any existing X-Spam-Score header?
do_action_delete_header($entity,"X-Spam-Score") unless ($insider);
}
remember_spam_hash(make_spam_hash(),$report) if ($spamdb && $insider);
}
spam_log($report->{hits},$report->{req},$report->{names},[$ipos,$iposver,@spampass],$ipcountry,[$report->{learned},$report->{bounced},$report->{sax_awl}]);
}
}
return ($nospamcheck,$gdbhostreset);
}
#***********************************************************************
# Authenticity verification stuff.
#***********************************************************************
my @verified_results = ();
sub set_verified_result {
my $ent = shift;
my $msg = shift;
my $res = sprintf($msg,@_);
push @verified_results, sprintf('%s:%s %s',$MyFilterHostName,$SLVars{QI},mqp($res));
return $res;
}
sub add_verified_results {
my $ent = shift;
my $c = 0;
my %had = ();
my $dad = (wants_extra_headers());
foreach my $vh (@verified_results) {
next if ($had{$vh});
$had{$vh} = 1;
do_action_insert_header($ent,'X-Auth-Result',$vh) if ($dad);
$c ++;
}
@verified_results = ();
return $c;
}
sub put_verified_header_ex {
my $c = shift;
my $h = shift;
return $h unless (@_);
$h =~ s/^\s*\((.*)\)\s*$/$1/s;
my $x = '';
if ($c eq ',' && $h =~ /^(.*?)(;.*)$/) {
$x = $2;
$h = $1;
}
my @h = ();
foreach my $i (split(/$c/,$h)) {
$i =~ s/^\s+//;
$i =~ s/\s+$//;
push @h, $i unless ($i eq '-');
}
while (@_) {
my $a = shift @_;
$a =~ s/[\r\n]+//gs;
$a =~ s/^\s*\(\s*(.*?)\s*\)\s*$/$1/s;
$a =~ s/^\s+//s;
$a =~ s/\s+$//s;
next unless ($a);
next if (grep(/$a/i,@h));
push @h, $a;
}
$c .= ' ' if ($c eq ';');
return sprintf(' (%s%s)',join($c,@h),$x) if (@h);
return " (-$x)" if ($x);
return '';
}
sub set_verified_header_ex {
return put_verified_header_ex(',',@_);
}
sub add_verified_header_ex {
return put_verified_header_ex(';',@_);
}
sub find_out_pra {
my ($entity) = @_;
my $mod = $entity->head->modify(0);
my %vals = ();
foreach my $hl (@{$entity->head->header}) {
#debug_log(0,'find_out_pra l "%s"',$hl);
if ($hl =~ /^Resent-From:\s*(\S.*?)\s*$/si) {
unless ($vals{'Resent-From'}) {
$vals{'Resent-From'} = $1;
debug_log(5,'find_out_pra h Resent-From="%s"',$1);
}
} elsif ($hl =~ /^(Received|Return-Path):/i) {
if ($vals{'Resent-From'}) {
debug_log(5,'find_out_pra h $1',$1);
last;
}
} elsif ($hl =~ /^Resent-Sender:\s*(\S.*?)\s*$/si) {
$vals{'Resent-Sender:'} = $1;
debug_log(5,'find_out_pra h Resent-Sender="%s"',$1);
last;
} elsif ($hl =~ /^(Sender|From):\s*(\S.*?)\s*$/si) {
my $hdr = ucfirst(lc($1));
if ($vals{$hdr}) {
$vals{"!$hdr"} = 1;
debug_log(5,'find_out_pra h %s=!',$hdr);
} else {
$vals{$hdr} = $2;
debug_log(5,'find_out_pra h %s="%s"',$hdr,$2);
}
}
}
$entity->head->modify($mod);
return wantarray ? ('','') : '' unless (load_modules('Mail::Address'));
foreach my $hdr (('Resent-Sender','Resent-From','Sender','From')) {
next unless ($vals{$hdr});
next if ($vals{"!$hdr"});
debug_log(5,'find_out_pra a %s="%s"',$hdr,$vals{$hdr});
my @a = Mail::Address->parse($vals{$hdr});
last unless (@a);
foreach my $a (@a) {
next unless ($a && $a->address);
debug_log(5,'find_out_pra r %s=%s',$hdr,$a->address);
return wantarray ? ($hdr,$a->address) : $a->address;
}
last;
}
return wantarray ? ('','') : '';
}
sub get_verify_check_header_ex {
my ($entity,$h) = @_;
$h = '' unless ($h);
return $h unless (defined($entity) && defined($entity->head));
my %tf = ();
foreach my $tag ($entity->head->tags) {
if ($tag =~ /^(X-)?(list-.*|.*mailing-?list.*)$/i) {
$tf{'list'} = 1;
} elsif ($tag =~ /^(X-)?(.*newsgroups.*|path)$/i) {
$tf{'news'} = 1;
} elsif ($tag =~ /^(X-)?(Delivered-To|Envelope-To|BeenThere|Return-Path)$/i) {
$tf{'forward'} = 1;
}
}
my $val = $entity->head->get('Precedence');
$tf{$val} = 1 if ($val && $val =~ /^(junk|bulk|list)[\s\r\n]*$/i);
return set_verified_header_ex($h,keys %tf);
}
my $dkimsignature = undef;
sub verify_dk_dkim_signature_init {
return $dkimsignature if ($dkimsignature);
return undef if (-s './INPUTMSG' > $mailtoobig);
#debug_log(0,'verify_dk_dkim_signature_init');
return undef unless (load_modules('Mail::DKIM::Verifier'));
$dkimsignature = Mail::DKIM::Verifier->new();
unless ($dkimsignature) {
debug_log(-1,'verify_dk_dkim_signature: create error%s',$tstex);
return undef;
}
unless (open(DFH,'<','./INPUTMSG')) {
debug_log(-1,'verify_dk_dkim_signature: open error%s',$tstex);
return undef;
}
while (my $l = <DFH>) {
$l =~ s/[\r\n]+//gs;
eval { $dkimsignature->PRINT("$l\015\012"); };
}
close(DFH);
eval { $dkimsignature->CLOSE; };
return $dkimsignature;
}
sub verify_dk_dkim_signature_do {
my ($ws) = @_;
#debug_log(0,'verify_dk_dkim_signature_do: %s',$ws);
my $dkv = verify_dk_dkim_signature_init();
return (undef) unless ($dkv);
my $dkr = 'error';
my $dkd = 'error';
eval { $dkr = $dkv->result; };
eval { $dkd = $dkv->result_detail; };
#debug_log(5,'verify_dk_dkim_signature_do: %s %s',$ws,$dkd);
my $sig = ($dkr eq 'none') ? undef : $dkv->signature;
my $dkp;
my $dka;
my $dkh;
if ($ws eq 'dkim' && (!defined($sig) || $sig->isa('Mail::DKIM::Signature'))) {
$dkh = 'from';
$dka = $dkv->message_originator;
eval { $dkp = $dkv->fetch_author_policy unless ($dkr eq 'pass'); };
} elsif ($ws eq 'dk' && (!defined($sig) || $sig->isa('Mail::DKIM::DkSignature'))) {
$dkh = 'sender';
$dka = $dkv->message_sender;
eval { $dkp = $dkv->fetch_sender_policy unless ($dkr eq 'pass'); };
} else {
return ($dkv,$dkr,$dkd);
}
return ($dkv,$dkr,$dkd,$ws,$dka?$dka->address:'',$dkh) unless ($dkp);
my $flg = $dkp->flags;$flg = '' unless ($flg);
my $plr = '';
eval { $dkp->apply($dkv); };
#debug_log(3,'verify_dk_dkim_signature_do: %s %s %s (%s)',$ws,$dkd,$plr,$dkp->policy);
return ($dkv,$dkr,$dkd,$ws,$dka?$dka->address:'',$dkh,$dkp,$dkp->policy,$plr,$flg =~ /y/i?1:0,$dkp->is_implied_default_policy);
}
sub verify_dk_dkim_signature {
my ($ws,$wss,$entity,$reslog,$checkthis) = @_;
#debug_log(0,'verify_dk_dkim_signature: %s %s',$ws,$wss);
return ('unchecked','',[]) unless ($checkthis);
return ('unchecked','',[]) if (-s './INPUTMSG' > $mailtoobig);
my ($dkv,$dkr,$dkd,$dkw,$dka,$dkh,$dkp,$pls,$plr,$plt,$pln) = verify_dk_dkim_signature_do($ws);
return ('temperror','',[]) unless ($dkv);
return ('nothing','',[]) unless ($dkw && $dkw eq $ws);
return ('nothing','',[]) if ($pln && $ws ne 'dkim' && $dkr eq 'none');
my @src = ();
if ($dkh && $dka) {
debug_log(5,'verify_dk_dkim_signature: %s %s %s',$ws,$dkh,$dka);
push @src, {source=>"header.$dkh",address=>$dka};
}
my $tstex = get_verify_check_header_ex($entity);
$tstex = set_verified_header_ex($tstex,'testing') if ($plt);
if ($plr) {
debug_log(3,'verify_dk_dkim_signature: %s %s %s%s',$ws,$dkr,$plr,$tstex);
push @{$reslog}, set_verified_result($entity,'%s%s %s %s',$wss,$tstex,$plr,$dkd);
return ('pass',$tstex,\@src,0,"$plr $dkd",$pls) if ($plr eq 'accept');
return ('fail',$tstex,\@src,0,"$plr $dkd",$pls) if ($plr eq 'fail');
if ($plr eq 'neutral') {
return ('pass',$tstex,\@src,0,"$plr $dkd",$pls) if ($dkr eq 'pass');
return ('permerror',$tstex,\@src,0,"$plr $dkd",$pls) if ($dkr eq 'invalid');
return ('softfail',$tstex,\@src,0,"$plr $dkd",$pls) if ($dkr eq 'fail');
return ('neutral',$tstex,\@src,0,"$plr $dkd",$pls);
}
} else {
debug_log(3,'verify_dk_dkim_signature: %s %s%s',$ws,$dkr,$tstex);
push @{$reslog}, set_verified_result($entity,'%s%s %s',$wss,$tstex,$dkd);
return ('pass',$tstex,\@src,0,$dkd) if ($dkr eq 'pass');
return ('fail',$tstex,\@src,0,$dkd) if ($dkr eq 'fail');
return ('permerror',$tstex,\@src,0,$dkd) if ($dkr eq 'invalid');
return ('neutral',$tstex,\@src,0,$dkd) if ($dkr eq 'none');
}
debug_log(-1,'verify_dk_dkim_signature: unhandled result(s) %s %s %s',$ws,$dkr,$plr);
return ('temperror',$tstex,\@src);
}
sub verify_dk_signature {
my ($entity,$reslog) = @_;
return verify_dk_dkim_signature('dk','DomainKey',$entity,$reslog,$dkcheck);
}
sub verify_dkim_signature {
my ($entity,$reslog) = @_;
return verify_dk_dkim_signature('dkim','DKIM',$entity,$reslog,$dkimcheck);
}
# Seems to be PGP signed?
sub verify_pgp_signature_signed {
my ($entity,$recurse) = @_;
my $met = $entity->effective_type;
if ($met eq 'multipart/signed') {
my $p = $entity->head->mime_attr('content-type.protocol');
if (defined($p) && $p =~ /^application\/pgp/i) {
debug_log(3,'verify_pgp_signature_signed: MIME signature',$p);
return 'm';
} else {
debug_log(3,'verify_pgp_signature_signed: no MIME signature (%s)',$p);
}
} elsif ($met eq 'text/plain') {
my $bh = $entity->bodyhandle;
if ($bh) {
my $bio = $bh->open('r');
if ($bio) {
my $bbl = 0;
my $ael = 0;
my $ddl = 0;
my $fpt = 0;
my $olr = 0;
my $slr = 0;
while (my $l = $bio->getline) {
if ($fpt == 0 && $l =~ /^-+BEGIN PGP SIGNED MESSAGE-+[\r\n]*$/) {
$fpt ++;
} elsif ($fpt == 1 && $l =~ /^-+BEGIN PGP SIGNATURE-+[\r\n]*$/) {
$fpt ++;
} elsif ($fpt == 2 && $l =~ /^-+END PGP SIGNATURE-+[\r\n]*$/) {
$slr = 0;
$olr = 0;
$fpt ++;
} elsif ($fpt == 0 || $fpt == 3) {
$ddl ++ if ($l =~ /^-{5,5}.*?-{5,5}$/ || $l =~ /^_{5,5}.*?_{5,5}$/);
if ($fpt == 0) {
$bbl++;
} else {
$ael ++;
}
if ($l =~ /^[\r\n]*$/) {
$slr ++;
if ($slr > 99) {
$fpt = 4;
last;
}
} else {
$olr ++;
if ($olr > 29) {
$fpt = 5;
last;
}
}
}
}
$bio->close;
if ($fpt == 3) {
debug_log(3,'verify_pgp_signature_signed: ASCII signature?');
return ($ddl || $bblk>10 || $ael>10) ? 't?' : 't';
} else {
debug_log(3,'verify_pgp_signature_signed: no ascii signature (%u)',$fpt);
}
} else {
debug_log(-1,'verify_pgp_signature_signed: body open error');
}
} else {
debug_log(-1,'verify_pgp_signature_signed: no body');
}
} elsif ($recurse && $met eq 'multipart/mixed') {
debug_log(3,'verify_pgp_signature_signed: multipart (%s) <%s>',$met,$entity->mime_type);
foreach my $part ($entity->parts) {
debug_log(3,'verify_pgp_signature_signed: part (%s) <%s>',$met,$part->mime_type);
my $signed = verify_pgp_signature_signed($part,0);
return $signed if ($signed);
}
} else {
debug_log(3,'verify_pgp_signature: other mime type (%s) <%s>',$met,$entity->mime_type);
}
return 0;
}
# Get a key from database or server and parse it.
sub verify_pgp_signature_encode_data {
my $res = '';
for (my $i=0;$i<@_;$i++) {
my $x = $_[$i];
$x =~ s/([^-_ .,;@<>a-zA-Z0-9])/sprintf('#%02x',ord($1))/ges;
$res .= '/' if ($res);
$res .= $x;
}
return $res;
}
sub verify_pgp_signature_decode_data {
my ($str) = @_;
my @res = ();
foreach my $x (split(/\//,$str)) {
$x =~ s/\#([\da-fA-F][\da-fA-F])/chr(hex($1))/ges;
push @res, $x;
}
return @res;
}
sub verify_pgp_signature_ad_kl {
my ($xla,$xha,$xln,$xhn,$xv,$xa) = @_;
$xv =~ s/^[\s<]+//;
$xv =~ s/[\s>]+$//;
return unless ($xv);
return if ($xa && $xv !~ /^\S+\@\S+$/);
$xa = 1 if ($xv =~ /^\S+\@\S+$/);
my $xc = lc($xv);
if ($xa) {
return if ($xha->{$xc});
push @$xla, $xv;
$xha->{$xc} = 1;
return;
}
return if ($xhn->{$xc});
push @$xln, $xv;
$xhn->{$xc} = 1;
}
sub verify_pgp_signature_fetch_key {
my ($keyid,$gk) = @_;
return (0,'','unchecked','') unless (load_modules('LWP::UserAgent','HTTP::Request'));
debug_log(2,'verify_pgp_signature_fetch_key: %s',$keyid);
my $ua = LWP::UserAgent->new;
$ua->agent(sprintf('MDF/%s/%s (MIMEDefang with local filter at %s)',md_version(),$FilterVersion,$MyFilterHostName));
$ua->timeout(15);
my $url = sprintf('http://%s:11371/pks/lookup?op=get&search=0x%s',$pgp_keyserver,$keyid);
debug_log(2,'verify_pgp_signature_fetch_key: GET %s'.$url);
my $req = HTTP::Request->new(GET=>$url);
my $res = $ua->request($req);
my $key = $res->content;
return (1,'','temperror',sprintf('HTTP error: %s',$res->status_line)) unless ($key);
return (1,'','temperror',sprintf('HTTP error: %s',$res->status_line)) if ($key =~ /^500 Can't connect to/i);
if ($key =~ /(-----BEGIN PGP PUBLIC KEY BLOCK-----.*?-----END PGP PUBLIC KEY BLOCK-----)/s) {
$key = $1;
return (1,$key);
}
if ($key =~ /^<html>.*?<h1>(.*?)<\/h1>(.*?)<\/body>/s) {
my $h = $1;
my $b = $2;
$b = "$h: $b" unless ($b =~ /$h/i);
$b =~ s/[\t\r\n]+/ /gs;
$b =~ s/\s+/ /g;
unless ($gk) {
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO pgpring (pgp_stamp,pgp_id,pgp_key,pgp_person,pgp_mail,pgp_note) VALUES (?,?,?,?,?,?) '.
'ON DUPLICATE KEY UPDATE pgp_stamp=VALUES(pgp_stamp),pgp_key=VALUES(pgp_key),pgp_person=VALUES(pgp_person),pgp_mail=VALUES(pgp_mail),pgp_note=VALUES(pgp_note)',
time(),$keyid,'#','','',verify_pgp_signature_encode_data($b));
} else {
sql_execute('REPLACE INTO pgpring (pgp_stamp,pgp_id,pgp_key,pgp_person,pgp_mail,pgp_note) VALUES (?,?,?,?,?,?)',
time(),$keyid,'#','','',verify_pgp_signature_encode_data($b));
}
return (1,'','softfail',"Key not found [$b]");
}
return (1,'');
}
unless ($gk) {
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO pgpring (pgp_stamp,pgp_id,pgp_key,pgp_person,pgp_mail,pgp_note) VALUES (?,?,?,?,?,?) '.
'ON DUPLICATE KEY UPDATE pgp_stamp=VALUES(pgp_stamp),pgp_key=VALUES(pgp_key),pgp_person=VALUES(pgp_person),pgp_mail=VALUES(pgp_mail),pgp_note=VALUES(pgp_note)',
time(),$keyid,'#','','','');
} else {
sql_execute('REPLACE INTO pgpring (pgp_stamp,pgp_id,pgp_key,pgp_person,pgp_mail,pgp_note) VALUES (?,?,?,?,?,?)',
time(),$keyid,'#','','','');
}
return (1,'','softfail','Key not found');
}
return (1,'');
}
sub verify_pgp_signature_parse_uid {
my ($xla,$xha,$xln,$xhn,$uid) = @_;
my @al = ();
if (get_addresses_from_value($uid,\@al,'all')) {
foreach my $aa (@al) {
verify_pgp_signature_ad_kl($xla,$xha,$xln,$xhn,$aa->{address},1);
verify_pgp_signature_ad_kl($xla,$xha,$xln,$xhn,$aa->{name},0);
}
return;
}
if ($uid =~ /^\s*(.*?)\s*<(.*?)>\s*$/) {
my $kp = $1;
my $ma = $2;
verify_pgp_signature_ad_kl($xla,$xha,$xln,$xhn,$ma,1);
verify_pgp_signature_ad_kl($xla,$xha,$xln,$xhn,$kp,0);
}
}
sub verify_pgp_signature_fetch_info {
my ($keyid,$xla,$xha,$xln,$xhn) = @_;
return (0,'') unless (load_modules('HTML::Entities'));
debug_log(3,'verify_pgp_signature_fetch_info: %s',$keyid);
my $ua = LWP::UserAgent->new;
$ua->agent(sprintf('MDF/%s/%s (MIMEDefang with local filter at %s)',md_version(),$FilterVersion,$MyFilterHostName));
$ua->timeout(15);
my $url = sprintf('http://%s:11371/pks/lookup?op=index&search=0x%s',$pgp_keyserver,$keyid);
my $req = HTTP::Request->new(GET=>$url);
my $res = $ua->request($req);
if ($res->is_success) {
my $ki = $res->content;
if ($ki && $ki =~ /<pre>(.*?)<\/pre>/s) {
$ki = $1;
$ki =~ s/<[^>]*>//gs;
$ki = HTML::Entities::decode_entities($ki);
$ki =~ s/\r\n/\n/gs;
$ki =~ s/\r/\n/gs;
my @ki = split(/\n+/,$ki);
shift @ki if (@ki);
my $keynote = shift @ki if (@ki);
$keynote =~ s/\s+/ /;
if ($keynote !~ /REVOKED/ && $keynote =~ /(\S+\s+\S+\s+\S+)\s+(.*)$/) {
my $uid = $2;
$keynote = $1;
verify_pgp_signature_parse_uid($xla,$xha,$xln,$xhn,$uid);
}
while (my $x = shift @ki) {
verify_pgp_signature_parse_uid($xla,$xha,$xln,$xhn,$x);
}
return (1,$keynote);
}
}
return (0,'');
}
sub verify_pgp_signature_find_key {
my ($id) = @_;
my $keyid = unpack('H*',$id);
debug_log(4,'verify_pgp_signature_find_key: %s',$keyid);
my %keymail = ();
my %keyperson = ();
my @keymail = ();
my @keyperson = ();
my $keynote = '';
my $cert;
my $key;
my $keyvals = sql_select_one_row('SELECT pgp_stamp,pgp_key,pgp_person,pgp_mail,pgp_note FROM pgpring WHERE pgp_id=?',$keyid);
my $gk = ($keyvals && @$keyvals > 1 && $keyvals->[1]);
$gk = 0 if ($keyvals->[1] eq '#' && $keyvals->[0] > time() - $pgp_expire_bad);
unless ($gk && $keyvals->[0] > time() - $pgp_expire) {
my ($ok,$fkr,$fkes);
($ok,$key,$fkr,$fkes) = verify_pgp_signature_fetch_key($keyid,$gk);
return (0,$fkr,$fkes,$keyid,\@keymail,\@keyperson,$keynote,$cert) unless ($gk || ($ok && $key));
}
my $savethis = 0;
if ($key) {
debug_log(2,'verify_pgp_signature_find_key: %s downloaded',$keyid);
$savethis = 1;
} elsif ($gk) {
debug_log(2,'verify_pgp_signature_find_key: %s in ring',$keyid);
($key) = verify_pgp_signature_decode_data($keyvals->[1]);
@keyperson = verify_pgp_signature_decode_data($keyvals->[2]) if ($keyvals->[2]);
@keymail = verify_pgp_signature_decode_data($keyvals->[3]) if ($keyvals->[3]);
($keynote) = verify_pgp_signature_decode_data($keyvals->[4]) if ($keyvals->[4]);
} elsif ($keyvals && @$keyvals > 1 && $keyvals->[1] && $keyvals->[1] eq '#') {
if ($keyvals->[4]) {
my ($b) = verify_pgp_signature_decode_data($keyvals->[4]) if ($keyvals->[4]);
return (1,'softfail',"Key not found [$b]",$keyid,\@keymail,\@keyperson,$keynote,$cert) if ($b);
}
return (1,'softfail',"Key not found",$keyid,\@keymail,\@keyperson,$keynote,$cert);
} else {
debug_log(2,'verify_pgp_signature_find_key: %s not found',$keyid);
return (0,'temperror','Key not found',$keyid,\@keymail,\@keyperson,$keynote,$cert);
}
my $ring = Crypt::OpenPGP::KeyRing->new(Data=>$key);
return (0,'softfail',sprintf('Key error: %s',Crypt::OpenPGP::KeyRing->errstr),$keyid,\@keymail,\@keyperson,$keynote,$cert) unless ($ring);
$cert = $ring->find_keyblock_by_index(0);
if ($cert) {
my $uid = $cert->primary_uid;
verify_pgp_signature_parse_uid(\@keymail,\%keymail,\@keyperson,\%keyperson,$uid) if ($uid);
$cert = $cert->signing_key;
}
if ($savethis) {
my $ok;
($ok,$keynote) = verify_pgp_signature_fetch_info($keyid,\@keymail,\%keymail,\@keyperson,\%keyperson);
if ($sqldbd eq 'M') {
sql_execute('INSERT INTO pgpring (pgp_stamp,pgp_id,pgp_key,pgp_person,pgp_mail,pgp_note) VALUES (?,?,?,?,?,?) '.
'ON DUPLICATE KEY UPDATE pgp_stamp=VALUES(pgp_stamp),pgp_key=VALUES(pgp_key),pgp_person=VALUES(pgp_person),pgp_mail=VALUES(pgp_mail),pgp_note=VALUES(pgp_note)',
time(),$keyid,verify_pgp_signature_encode_data($key),
verify_pgp_signature_encode_data(@keyperson),
verify_pgp_signature_encode_data(@keymail),
verify_pgp_signature_encode_data($keynote)
);
} else {
sql_execute('REPLACE INTO pgpring (pgp_stamp,pgp_id,pgp_key,pgp_person,pgp_mail,pgp_note) VALUES (?,?,?,?,?,?)',
time(),$keyid,verify_pgp_signature_encode_data($key),
verify_pgp_signature_encode_data(@keyperson),
verify_pgp_signature_encode_data(@keymail),
verify_pgp_signature_encode_data($keynote),
);
}
}
return (0,'softfail','No key?',$keyid,\@keymail,\@keyperson,$keynote,$cert) unless ($cert);
return (0,'unchecked','',$keyid,\@keymail,\@keyperson,$keynote,$cert);
}
# Verify a PGP signature
my $openpgp;
sub verify_pgp_signature_verify {
my ($signature,$content) = @_;
debug_log(5,'verify_pgp_signature_verify');
$openpgp = Crypt::OpenPGP->new() unless ($openpgp);
return (0,'temperror','Error allocating OpenPGP object!') unless ($openpgp);
my ($data,$sig);
my $msg = Crypt::OpenPGP::Message->new(Data=>$signature);
return (0,'temperror',sprintf('Reading signature failed: %s',Crypt::OpenPGP::Message->errstr)) unless ($msg);
my @pieces = $msg->pieces;
if (ref($pieces[0]) eq 'Crypt::OpenPGP::Compressed') {
$data = $pieces[0]->decompress;
return (0,'temperror',sprintf('Decompression error: %s',$pieces[0]->errstr)) unless ($data);
$msg = Crypt::OpenPGP::Message->new(Data=>$data);
return (0,'temperror',sprintf('Reading decompressed data failed: %s',Crypt::OpenPGP::Message->errstr)) unless ($msg);
@pieces = $msg->pieces;
}
if (ref($pieces[0]) eq 'Crypt::OpenPGP::OnePassSig') {
($data,$sig) = @pieces[1,2];
} elsif (ref($pieces[0]) eq 'Crypt::OpenPGP::Signature') {
($sig,$data) = @pieces[0,1];
} else {
return (0,'temperror','SigFile contents are strange');
}
my ($fkd,$fkr,$fkes,$keyid,$keymail,$keyperson,$keynote,$cert) = verify_pgp_signature_find_key($sig->key_id);
return ($fkd,$fkr,$fkes,$keyid,$keymail,$keyperson,$keynote) unless ($cert);
my @modes = (0);
@modes = ('b','t') unless ($data);
for my $mode (@modes) {
if ($mode) {
$data = Crypt::OpenPGP::Plaintext->new(Mode=>$mode,Data=>$content);
return (1,'softfail','Bad message content?',$keyid,$keymail,$keyperson,$keynote) unless ($data);
}
my($dgst,$found);
for (1,0) {
my $hok;
eval {
local $Crypt::OpenPGP::Globals::Trim_trailing_ws = $_;
$dgst = $sig->hash_data($data);
$hok = 1;
};
return (1,'temperror','Hashing error',$keyid,$keymail,$keyperson,$keynote) unless ($hok);
return (1,'softfail',sprintf('Signature error: %s',$sig->errstr)) unless ($dgst);
if (substr($dgst, 0, 2) eq $sig->{chk}) {
$found++;
last;
}
}
if ($found) {
my ($valid,$vok);
eval {
$valid = $cert->key->public_key->verify($sig,$dgst);
$vok = 1;
};
return (1,'temperror','Verification error',$keyid,$keymail,$keyperson,$keynote) unless ($vok);
return (1,'fail','Bad signature',$keyid,$keymail,$keyperson,$keynote,$openpgp->errstr) unless ($valid);
return (1,'pass','Good signature',$keyid,$keymail,$keyperson,$keynote,$openpgp->errstr);
}
}
return (1,'fail','Message hash does not match signature checkbytes',$keyid,$keymail,$keyperson,$keynote);
}
# Decode a PGP signed message part
sub verify_pgp_signature_decode_part {
my ($partbody,$parthead) = @_;
debug_log(5,'verify_pgp_signature_decode_part');
my $head;
my $body = '';
if ($parthead) {
$head = new MIME::Head($parthead);
$body = $$partbody;
} else {
if ($$partbody =~ /^(.*?\n)\n(.*)$/s) {
$head = $1;
$body = $2;
} else {
$head = $$partbody;
}
my @head = split(/\n/,$head);
$head = new MIME::Head(\@head);
}
my $mt = lc($head->mime_type);
my $ct = lc($head->mime_encoding);
if ($ct eq 'base64') {
$body = decode_base64($body);
} elsif ($ct eq 'quoted-printable') {
$body = decode_qp($body);
}
return ($mt,$body);
}
# Verify PGP signed mail?
sub verify_pgp_signature {
#return 0;
my ($entity,$reslog) = @_;
my @src = ();
return ('unchecked','',\@src) unless (defined($pgpcheck) && $pgpcheck);
return ('unchecked','',\@src) unless (defined($entity) && defined($entity->head));
return ('unchecked','',\@src) if (-s './INPUTMSG' > $mailtoobig);
my $st = verify_pgp_signature_signed($entity,1);
return ('unchecked','',\@src) unless ($st);
return ('unchecked','',\@src) unless (load_modules('MIME::Head','MIME::QuotedPrint','MIME::Base64'));
return ('unchecked','',\@src) unless (load_modules('Crypt::OpenPGP','Crypt::OpenPGP::Message','Crypt::OpenPGP::KeyRing','Crypt::OpenPGP::Plaintext'));
debug_log(5,'verify_pgp_signature: %s',$st);
my $ex = get_verify_check_header_ex($entity);
unless (open(DFH,'<','./INPUTMSG')) {
debug_log(-1,'verify_pgp_signature: open error');
return ('temperror',$ex,\@src);
}
my @head = ();
my $msg = '';
while (my $l = <DFH>) {
$l =~ s/[\r\n]+//gs;
last if ($l eq '');
push @head, "$l\n";
}
while (my $l = <DFH>) {
$l =~ s/[\r\n]+//gs;
$msg .= "$l\n";
}
close(DFH);
my $head = new MIME::Head(\@head);
unless (@head && $msg && $head) {
debug_log(-1,'verify_pgp_signature: bad input message');
return ('temperror',$ex,\@src);
}
my ($dv,$vr,$rs,$kid,$kml,$kprs,$kxn,$es);
if ($st =~ /^m/) {
my $bnd = $head->mime_attr('content-type.boundary');
my $alg = $head->mime_attr('content-type.micalg');
$bnd =~ s/([^_a-zA-Z0-9])/\\$1/gs;
$alg =~ s/^pgp-//;
$msg =~ s/\n--$bnd--\n.*$/\n/s;
$msg =~ s/^(|.*?\n)--$bnd\n//s;
my @parts = split(/\n--$bnd\n/,$msg);
$msg = '';
unless (@parts) {
debug_log(-1,'verify_pgp_signature: no parts in input message');
return ('temperror',$ex,\@src);
}
while ($#parts > 1) { pop @parts; }
my ($smt,$sig) = verify_pgp_signature_decode_part(\$parts[1]);
unless ($smt =~ /^application\/pgp/) {
debug_log(-1,'verify_pgp_signature: not PGP signed (%s)',$smt);
return ('unchecked',$ex,\@src);
}
$parts[0] =~ s/\n/\r\n/gs;
($dv,$vr,$rs,$kid,$kml,$kprs,$kxn,$es) = verify_pgp_signature_verify($sig,$parts[0]);
} elsif ($st =~ /^t/) {
my $smt;
my ($smt,$msg) = verify_pgp_signature_decode_part(\$msg,\@head);
($dv,$vr,$rs,$kid,$kml,$kprs,$kxn,$es) = verify_pgp_signature_verify($msg);
} else {
debug_log(-1,'verify_pgp_signature: strange message type');
return ('unchecked',$ex,\@src);
}
$ex = set_verified_header_ex($ex,'ambiguous') if ($st =~ /\?/);
$ex = set_verified_header_ex($ex,'revoked') if ($kxn =~ /REVOKED/);
debug_log(0,'verify_pgp_signature: ex="%s"',$ex);
$rs =~ s/[\r\n]$/ /gs; $rs =~ s/\s+/ /g; $rs =~ s/\s+$//; $rs =~ s/^\s+//;
unless ($dv) {
debug_log(-1,'verify_pgp_signature: %s',$rs);
return ($vr,$ex,\@src);
}
debug_log(4,'verify_pgp_signature: %s',$rs) if ($rs);
if ($kml && @$kml) {
foreach my $ma (@$kml) {
push @src, {source=>'key.emailaddress',address=>$ma};
}
}
if ($kid && !@src) {
push @src, {source=>'signature.keyid',address=>$kid};
}
if ($kml && @$kprs) {
foreach my $ma (@$kprs) {
push @src, {source=>'key.person',display=>$ma};
}
}
$rs = '' unless ($rs);
$rs = " ($rs)" if ($rs);
if ($vr eq 'pass' || $vr eq 'ok') {
push @{$reslog}, set_verified_result($entity,'PGP%s verified%s',$ex,$rs);
$vr = 'accept' if ($kxn =~ /REVOKED/);
} elsif ($vr eq 'fail') {
push @{$reslog}, set_verified_result($entity,'PGP%s bad%s',$ex,$rs);
} elsif ($vr eq 'softfail') {
push @{$reslog}, set_verified_result($entity,'PGP%s unverified%s',$ex,$rs);
} else {
push @{$reslog}, set_verified_result($entity,'PGP%s unknown%s',$ex,$rs);
}
return ($vr,$ex,\@src,0,$rs);
}
my $spfserver;
sub verify_spf_identity {
#return 0;
my ($entity,$reslog,$scope,$source,$identity,$to) = @_;
my @src = ();
push @src, {source=>$source,address=>$identity};
return (wantarray ? ('unchecked','',\@src) : 0) unless ($spfcheck);
$identity = address_strip_nc($identity);
return (wantarray ? ('unchecked','',\@src) : 0) unless ($identity);
return (wantarray ? ('unchecked','',\@src) : 0) unless (load_modules('Mail::SPF'));
debug_log(7,'verify_spf_identity: %s=%s',$scope,$identity);
my $ex = get_verify_check_header_ex($entity);
$spfserver = Mail::SPF::Server->new(
hostname => $MyFilterHostName,
dns_resolver => get_resolver($to?$to:10),
default_authority_explanation => '',
) unless ($spfserver);
unless ($spfserver) {
debug_log(-1,'verify_spf_identity server errror');
return (wantarray ? ('temperror',$ex,\@src) : 0);
}
my $req = Mail::SPF::Request->new(
scope => $scope,
identity => $identity,
ip_address => $RelayAddr,
helo_identity => address_strip_nc($Helo),
);
unless ($req) {
debug_log(-1,'verify_spf_identity query errror');
return (wantarray ? ('temperror',$ex,\@src) : 0);
}
my $res = $spfserver->process($req);
unless ($req) {
debug_log(-1,'verify_spf_identity result errror');
return (wantarray ? ('temperror',$ex,\@src) : 0);
}
my $spfr = $res->code;
my $spfa = ($spfr eq 'fail' && $res->authority_explanation) ? $res->authority_explanation : '';
my $spfl = $res->local_explanation;
my $spft = $res->text;
if ($spfa) {
debug_log(0,,'verify_spf_identity: a %s=%s %s ae: %s',$scope,$identity,$spfr,$spfa) ;
debug_log(0,,'verify_spf_identity: l %s=%s %s ae: %s',$scope,$identity,$spfr,$spfl);
debug_log(0,,'verify_spf_identity: t %s=%s %s ae: %s',$scope,$identity,$spfr,$spft);
}
$spfl = $spfa if ($spfa || !$spfl);
#debug_log(0,'verify_spf_identity: %s=%s%s "%s" "%s" "%s" "%s"',$scope,$identity,$ex,$spfr,$spft,$spfl,$spfa);
#debug_log(0,'verify_spf_identity: 1 "%s" "%s"',$spft,$spfl);
$spfl =~ s/$spft//gsi;
#debug_log(0,'verify_spf_identity: 2 "%s" "%s"',$spft,$spfl);
$spfl =~ s/\s+/ /gs;
$spfl =~ s/\(\s*\)//g;
$spfl =~ s/\s+$//;
$spfl =~ s/^\s+//;
$spfl = '' if ($spfl =~ /^\S+:\s*$/);
#debug_log(0,'verify_spf_identity: 3 "%s" "%s"',$spft,$spfl);
#debug_log(0,'verify_spf_identity: %s=%s%s "%s" "%s" "%s" "%s"',$scope,$identity,$ex,$spfr,$spft,$spfl,$spfa);
if (lc($spfr) eq 'none') {
#debug_log(0,'verify_spf_identity: none %s %s %s',$scope,$source,$identity);
$spfr = ($scope eq 'mfrom') ? 'neutral' : 'nothing';
}
$spfr = 'temperror' unless ($spfr =~ /^(?:pass|(?:soft)?fail|neutral|nothing|(?:temp|perm)error)$/i);
debug_log(7,'verify_spf_identity: %s=%s%s "%s"',$scope,$identity,$ex,$spfr);
if ($entity) {
#debug_log(0,'verify_spf_identity: (...,...,"s%","%s","%s","%s")',$ex,$spfr,$spfc,$spft);
my $spfc = "$spfl; $spft";
$spfc =~ s/^\s*;\s*//;
$spfc =~ s/\s*;\s*$//;
$spfc = " ($spfc)" if ($spfc);
my $spfe = set_verified_header_ex($ex,$scope);
push @{$reslog}, set_verified_result($entity,'SPF%s %s%s',$spfe,$spfr,$spfc) unless ($spfr eq 'nothing');
if ($res->code ne 'none' && wants_extra_headers()) {
my $hdr = $res->received_spf_header;
if ($hdr =~ /^(Received-SPF): (.+)$/) { do_action_insert_header($entity,$1,$2); }
}
}
#debug_log(0,'verify_spf_identity: ("%s","%s",[...],0,"%s")',$spfr,$ex,$spft);
return (wantarray ? ($spfr,$ex,\@src,0,$scope,$spft) : ($spfr eq 'fail') ? -1 : ($spfr eq 'pass') ? 1 : 0);
}
sub verify_spf_mfrom {
my ($entity,$reslog,$to) = @_;
return verify_spf_identity($entity,$reslog,'mfrom','smtp.mail',$Sender,$to);
}
sub check_spf_mfrom {
my ($identity,$to) = @_;
return scalar verify_spf_identity(undef,undef,'mfrom','smtp.mail',$identity,$to);
}
sub verify_spf_helo {
my ($entity,$reslog,$to) = @_;
return verify_spf_identity($entity,$reslog,'helo','smtp.helo',$Helo,$to);
}
sub check_spf_helo {
my ($identity,$to) = @_;
return scalar verify_spf_identity(undef,undef,'helo','smtp.helo',$identity,$to);
}
sub verify_spf_pra { # RFC 4407, not implemented yet...
my ($entity,$reslog,$to) = @_;
my ($header,$identity) = find_out_pra($entity);
return verify_spf_identity($entity,$reslog,'pra',"mail.$header",$identity,$to);
}
sub verify_relay_network {
my ($entity,$reslog) = @_;
my @src = ();
return ('ignore','',\@src) if (check_any_relay_option($Helo,'outsider'));
#debug_log(0,'verify_relay_network %s',$AuthPassNets);
return ('ignore','',\@src) unless (check_auth_pass_nets($RelayAddr));
my $too = 0;
foreach my $rcpt (@Recipients) {
$too =1 if ($rcpt =~ /^.+\@$OurDomains>?$/i);
last if ($too);
my $hst = storing_server($rcpt);
$too = 1 if ($hst =~ /^$LocalNets$/i);
last if ($too);
$too = 1 if (check_black_nets($hst));
last if ($too);
}
return ('ignore','',\@src) unless ($too);
push @src, {source=>'smtp.relay',address=>$RelayAddr,display=>'AuthPass'};
push @{$reslog}, set_verified_result($entity,'Relay trusted');
return ('ok','',\@src);
}
sub verify_authenticated {
my ($entity,$reslog) = @_;
my @src = ();
my $ae = check_authenticated();
return ('ignore','',\@src) unless ($ae);
push @src, {source=>'smtp.auth',address=>$ae};
push @{$reslog}, set_verified_result($entity,'User authenticated');
return ('ok','',\@src);
}
# Seems to be S/MIME signed?
sub verify_smime_signature_signed {
my ($entity,$recurse) = @_;
my $met = $entity->effective_type;
if ($met eq 'multipart/signed') {
my $p = $entity->head->mime_attr('content-type.protocol');
if (defined($p) && $p =~ /^application\/(x-)?pkcs\d+/i) {
debug_log(1,'verify_smime_signature_signed: MIME signature',$p);
return 1;
} else {
debug_log(3,'verify_smime_signature_signed: no MIME signature (%s)',$p);
}
} elsif ($met =~ /^application\/(x-)?pkcs\d+(-mime)?$/i) {
debug_log(1,'verify_smime_signature_signed: MIME part',$p);
return 1;
} elsif ($met =~ /^application\/octet-stream$/i) {
foreach my $hn (('Content-Type.filename','Content-Type.name','Content-Disposition.filename','Content-Disposition.name')) {
my $hv = $entity->head->mime_attr;
return 1 if ($hv && $hv =~ /\.(p7m|p7s|aps|p7c|p10)$/i);
}
} elsif ($recurse && $met eq 'multipart/mixed') {
debug_log(3,'verify_smime_signature_signed: multipart (%s) <%s>',$met,$entity->mime_type);
foreach my $part ($entity->parts) {
debug_log(3,'verify_smime_signature_signed: part (%s) <%s>',$met,$part->mime_type);
my $signed = verify_smime_signature_signed($part,0);
return $signed if ($signed);
}
} else {
debug_log(3,'verify_smime_signature: other mime type (%s) <%s>',$met,$entity->mime_type);
}
return 0;
}
# Verify S/MIME signed mail?
my $openssl;
sub verify_smime_signature {
#return 0;
my ($entity,$reslog) = @_;
my @src = ();
return ('unchecked','',\@src) unless (defined($smimecheck) && $smimecheck);
return ('unchecked','',\@src) unless (defined($entity) && defined($entity->head));
return ('unchecked','',\@src) if (-s './INPUTMSG' > $mailtoobig);
my $st = verify_smime_signature_signed($entity,1);
return ('unchecked','',\@src) unless ($st);
return ('unchecked','',\@src) unless (load_modules('File::Which','IPC::Run3'));
debug_log(1,'verify_smime_signature: %s',$st);
my $ex = get_verify_check_header_ex($entity);
unless($openssl) {
$openssl = which('openssl');
unless ($openssl) {
debug_log(-1,'verify_smime_signature: openssl not found in path');
return ('temperror',$ex,\@src);
}
}
my (@verout,$verres,$vererr,$siginf);
my $verret = 'temperror';
run3([$openssl,'smime','-verify','-in','./INPUTMSG','-signer','./SMIME_SIGNER'],\undef,\undef,\@verout);
if (-f './SMIME_SIGNER') {
my $sigerr;
run3([$openssl,'x509','-in','./SMIME_SIGNER','-noout','-subject','-issuer'],\undef,\$siginf,\$sigerr);
$siginf = '' if ($sigerr);
unlink('./SMIME_SIGNER');
}
$verres = shift @verout;
$verres =~ s/[\r\n]+//s;
if ($verres eq 'Verification successful') {
push @{$reslog}, set_verified_result($entity,'S/MIME%s verified',$ex);
$verret = 'pass';
}
if (@verout) {
$vererr = pop @verout;
$vererr =~ s/[\r\n]+//s;
my $verset = 'unknown';
if ($vererr =~ /:((?:wrong|no|invalid) (?:content|mime) type):/) {
$vererr = $1;
$verret = 'unchecked';
$verset = '';
} elsif ($vererr =~ /:(certificate verify error):/) {
my $ee = $1;
if ($vererr =~ /(Verify error:)([ a-zA-Z]+)/) {
$vererr = "$1 $2";
$verret = 'softfail';
} else {
$vererr = $ee;
}
$verset = 'unverified';
} elsif ($vererr =~ /:((?:signature|digest) failure):/) {
$vererr = $1;
$verret = 'fail';
$verset = 'bad';
} elsif ($vererr =~ /^[^:]+:[^:]+:[^:]+:[^:]+:[^:]+:([^:]+):/) {
$vererr = $1;
}
$vererr =~ s/^[\s:]+//;
$vererr =~ s/[\s:]+$//;
if ($verset) {
my $vertxt = '';
if ($verres && $vererr) {
$vertxt = " ($verres ($vererr))";
} elsif ($verres) {
$vertxt = " ($verres)";
} elsif ($vererr) {
$vertxt = " ($vererr)";
}
push @{$reslog}, set_verified_result($entity,'S/MIME%s %s%s',$ex,$verset,$vertxt);
}
}
debug_log(1,'verify_smime_signature: %s %s (%s)',$verret,$verres,$vererr);
foreach my $sigx (split(/[\r\n]+/,$siginf)) {
if ($sigx =~ /^\s*([a-z]+)\s*=\s*\/(.*)$/) {
my $sigy = $1;
$sigx = $2;
$sigx =~ s/(=[a-zA-Z]{1,10}:)\/\//$1\\\\/g;
foreach my $ss (split(/\//,$sigx)) {
if ($ss =~ /^(.*?)=(.*)$/i) {
my $sigf = $1;
my $sigv = $2;
next if ($sigf =~ /^\s*$/ || $sigv =~ /^\s*$/);
$sigv =~ s/^([a-zA-Z]{1,10}:)\\\\/$1\/\//g;
debug_log(1,'verify_smime_signature: %s.%s=%s',$sigy,$sigf,$sigv);
$sigf = lc($sigf);
if ($sigf eq 'emailaddress') {
push @src, {source=>"key.$sigy.$sigf",address=>$sigv};
} elsif ($sigf eq 'cn') {
push @src, {source=>"key.$sigy.name",display=>$sigv};
}
}
}
}
}
return ($verret,$ex,\@src,0,$vererr);
}
sub check_verified_check {
my ($name,$failures,$results,$passed,$forged,$result,$tstex,$sources,$failex,@msgex) = @_;
return 1 unless ($result);
return 1 if ($result eq 'ignore');
if ($sources) {
foreach my $src (@$sources) {
$src->{address} =~ s/^<//;
$src->{address} =~ s/>$//;
$src->{display} = $src->{address} unless (defined($src->{display}));
debug_log(5,'check_verified_check: %s %s=%s (%s)',$name,$src->{source},$src->{address},$src->{display});
}
}
#debug_log(0,'check_verified_check: %s %s',$name,$result);
return 1 if ($result eq 'unchecked' || $result eq 'nothing');
debug_log(3,'check_verified_check: %s %s%s',$name,$result,$tstex);
if ($result eq 'fail') {
$$failures .= ', ' if ($$failures);
$$failures .= "$name$tstex";
unless ($tstex && !$failex) {
foreach my $src (@$sources) {
#debug_log(0,'check_verified_check: forged %s:%s (%s)',$name,$src->{display},$src->{address});
push @$forged, sprintf('%s:%s',$name,mqp($src->{display}));
}
}
} elsif (($result eq 'pass' || $result eq 'ok') && $sources) {
foreach my $src (@$sources) {
next if ($src->{source} =~ /(issuer|author)/i);
debug_log(5,'check_verified_check: passed %s:%s (%s)',$name,$src->{display},$src->{address});
push @$passed, sprintf('%s:%s',$name,mqp($src->{display}));
}
}
return 1 if ($result eq 'ok');
$result = 'pass' if ($result eq 'accept');
$name =~ s/[^-_a-zA-Z0-9]//;
$name = "X-$name" unless ($name =~ /^(auth|dkim|domainkeys|senderid|spf)$/i);
my $exex = add_verified_header_ex($tstex,$failex);
foreach my $msgex (@msgex) {
$exex = add_verified_header_ex($exex,$msgex);
}
my %ri = (
check => $name,
sources => $sources,
result => "$result$exex",
);
push @$results, \%ri;
return ($result ne 'fail' || ($tstex && !$failex));
}
sub will_verify {
return 1 if ($AuthPassNets || $CanAuthenticate);
return 0 if (check_internal_whitelist($RelayAddr));
return 1 if ($dkcheck || $dkimcheck || $pgpcheck || $spfcheck || $smimecheck);
return 0;
}
my $keptauthresult;
sub add_authentication_results {
#return;
my $ent = shift;
my $results = shift;
my $ah = '';
foreach my $ar (@$results) {
my $srs = '';
foreach my $src (@{$ar->{sources}}) {
next unless ($src);
next unless ($src->{address});
$srs .= sprintf(' %s=%s',$src->{source},mqp($src->{address}));
}
next unless ($srs);
$ah .= sprintf(";\n\t%s=%s%s",$ar->{check},$ar->{result},$srs);
}
$ah .= ";\n\t$keptauthresult" if ($keptauthresult);
do_action_insert_header($ent,'Authentication-Results',"$MyFilterHostName$ah") if ($ah);
}
sub list_authentication_failures {
my $results = shift;
my @ah = ();
foreach my $ar (@$results) {
next unless ($ar->{result} =~ /^fail/i);
my $srs = '';
foreach my $src (@{$ar->{sources}}) {
next unless ($src);
next unless ($src->{address});
$srs .= sprintf(' %s=%s',$src->{source},mqp($src->{address}));
}
next unless ($srs);
push @ah, sprintf('AuthFail: %s %s%s',$ar->{check},$ar->{result},$srs);
}
return @ah;
}
sub del_authentication_results {
my ($entity,$justkeep) = @_;
$keptauthresult = '';
return 0 unless (defined($entity) && defined($entity->head));
my $dc = 0;
foreach my $hh ($entity->head->tags()) {
next unless ($hh =~ /^(Authentication-Results|X-Auth-[A-Z]+)$/i);
my @ahl = $entity->head->get($hh);
next unless (@ahl);
my $arhn = check_auth_pass_nets($RelayAddr) ? -1 : 0;
for (my $i=$#ahl;$i>=0;$i--) {
debug_log(7,'del_authentication_results: chk %s',$ahl[$i]);
if ($ahl[$i] =~ /^\s*$MyFilterHostNames[;:\s]/i) {
if ($hh =~ /^Authentication-Results$/i) {
$arhn ++;
unless ($arhn) {
$keptauthresult = $ahl[$i];
$keptauthresult =~ s/^\s*$MyFilterHostNames[;:\s]*//;
$keptauthresult =~ s/^\s+//;
$keptauthresult =~ s/\s+$//;
next unless ($keptauthresult);
debug_log(3,'del_authentication_results: keep "%s" "%s"',$ahl[$i],$keptauthresult);
do_action_delete_header($entity,$hh,$i+1);
next;
}
}
next if ($justkeep);
debug_log(3,'del_authentication_results: del %s',$ahl[$i]);
do_action_delete_header($entity,$hh,$i+1);
$dc ++;
}
}
}
return $dc;
}
sub clean_auth_passed {
my $entity = shift;
my @cap = ();
my @doms = ();
my @adom = ();
my %adrs = ();
my @adrs = ();
my $wdom = 0;
my %hdrs = (address_strip_opt($Sender)=>1);
foreach my $ap (@_) {
if ($ap =~ /^([^:]*):(.*)$/) {
my $vp = $1;
my $d = address_strip_opt($2);
if ($vp =~ /^(Relay|Auth)$/i) {
push @cap, $ap;
debug_log(5,'clean_auth_passed: = %s',$ap);
next;
}
debug_log(5,'clean_auth_passed: cr %s',$ap);
if ($d =~ /^\S+\@\S+\.[a-z]+$/) {
$adrs{$d} = 1;
$d =~ s/^.*\@//;
push @adom, $d;
} elsif ($d =~ /^\S+\.[a-z]+$/ && $d !~ /\@/) {
push @adom, $d;
push @doms, $d;
}
} else {
debug_log(5,'clean_auth_passed: n %s',$ap);
return ();
}
}
@adrs = keys %adrs;
debug_log(3,'clean_auth_passed: d %s %s',join(',',@doms),join(',',@adrs));
my @al = ();
my $alc = get_addresses_from_header($entity,'From:Sender:Reply-To',\@al,'all');
if (@alc) {
my @ald;
my $alac = 0;
my $alao = 0;
foreach my $aa (@al) {
next unless ($aa->{address});
my $aa = address_strip_opt($aa->{address});
$hdrs{$aa} = 1;
$alac ++;
$alao ++ if ($adrs{$aa});
push @ald, $aa->{domain};
}
unless (($alao || !@adrs) && ($alac == $alao || is_sub_domains(\@ald,\@adom))) {
debug_log(5,'clean_auth_passed: nsd %s %s',join(',',@ald),join(',',@adom));
return @cap;
}
}
debug_log(3,'clean_auth_passed: a %s',join(',',keys %hdrs));
foreach my $ap (@_) {
if ($ap =~ /^([^:]*):(.*)$/) {
my $vp = $1;
my $a = $2;
debug_log(5,'clean_auth_passed: ? %s %s',$vp,$a);
next if ($vp =~ /^(Relay|Auth)$/i);
debug_log(10,'clean_auth_passed: 1 %s',$ap);
next unless ($a =~ /^.*\@\S+\.[a-zA-Z]+$/);
debug_log(10,'clean_auth_passed: 2 %s',$ap);
next unless ($hdrs{address_strip_opt($a)});
#next if (@dom && !is_sub_domains([$a],\@dom));
debug_log(5,'clean_auth_passed: = %s',$ap);
push @cap, $ap;
}
}
debug_log(3,'clean_auth_passed: e');
return @cap;
}
sub add_hashcashes {
#return 0;
my ($entity) = @_;
return 0 unless (defined($hashcash) && $hashcash);
return 0 unless (check_internal_whitelist($RelayAddr));
return 0 unless (defined($entity) && defined($entity->head));
return 0 unless ($Sender =~ /\@$OurDomains>?$/i);
return 0 unless (load_modules('Digest::Hashcash'));
if ($hc_maxload && get_load_average() > $hc_maxload) {
md_syslog('info', "Hashcash disabled due to load average >= $hc_maxload!");
return 0;
}
if ($hc_maxswap && get_swap_percentage() > $hc_maxswap) {
md_syslog('info', "Hashcash disabled due to swap percentage >= $hc_maxswap!");
return 0;
}
my $hst = time();
my %ah;
get_addresses_from_header($entity,'To',\%ah);
get_addresses_from_header($entity,'Cc',\%ah);
my %aa;
my @al = ();
foreach my $a (@Recipients) {
next if (address_is_local($a,1,1));
my $aj = address_strip_nc($a);
next unless ($aj);
my $la = lc($aj);
next if ($aa{$la});
push @al, $aj if ($ah{$la});
$aa{$la} = 1;
}
return 0 unless (@al);
return 0 if (@al > $hc_maxrecipients);
my $siz = $hc_size;
unless ($siz) {
eval { $siz = Digest::Hashcash::estimate_size($hc_worktime,5); };
$siz = 20 unless ($siz);
}
debug_log(3,'add_hashcashes: %u %u %u',$#al+1,$siz,$hc_worktime);
my $hc;
eval { $hc = new Digest::Hashcash(size=>$siz,extension=>"host=$MyFilterHostName",uid=>$QueueID); };
unless ($hc) {
debug_log(-1,'add_hashcashes: create error');
return 0;
}
my $c = 0;
my $tt = time();
foreach my $a (@al) {
my $h;
my $t = time();
eval { $h = $hc->hash($a); };
$t = time() - $t;
unless ($h) {
debug_log(-1,'add_hashcashes: hash error: %s',$a);
return 0;
}
debug_log(3,'add_hashcashes: %u %u %s',$siz,$t,$h);
do_action_insert_header($entity,'X-Hashcash',$h);
$c ++;
last if (time()-$hst>$hc_maxtime);
}
$tt = time() - $tt;
debug_log(1,'add_hashcashes: %u %u %u',$siz,$tt,$c);
return $c;
}
#***********************************************************************
# Return-path changing.
#***********************************************************************
sub gsnd_add {
my ($a,$r) = @_;
$a = address_strip($a);
return 0 unless ($a);
my $now = time();
$r = 0 unless ($r);
if ($sqldbd eq 'M') {
sql_execute('INSERT generatedsenders (gsnd_address,gsnd_stamp,gsnd_rcpts) VALUES (?,?,?) '.
'ON DUPLICATE KEY UPDATE gsnd_stamp=VALUES(gsnd_stamp),gsnd_rcpts=(gsnd_rcpts+?)',
$a,$now,$r,$r);
} else {
return sql_execute_multi(
['INSERT OR IGNORE INTO generatedsenders (gsnd_address,gsnd_stamp) VALUES (?,?)',$a,$now],
['UPDATE generatedsenders SET gsnd_stamp=?,gsnd_rcpts=(gsnd_rcpts+?) WHERE gsnd_address=?',$now,$r,$a],
);
}
}
sub gsnd_check {
my ($a,$b) = @_;
$a = address_strip($a);
return 0 unless ($a);
debug_log(0,'gsnd_check %s ? %s',$t,$a);
my $res = sql_select_one_row('SELECT gsnd_stamp,gsnd_rcpts,gsnd_bounces FROM generatedsenders WHERE gsnd_address=? AND gsnd_stamp>=?',$a,time()-$GSNDExpire);
return 0 unless ($res && @{$res});
debug_log(0,'gsnd_check %s ? %s',$t,$a);
sql_execute('UPDATE generatedsenders SET gsnd_bounces=(gsnd_bounces+1) WHERE gsnd_address=?',$a) if ($b);
return 0 unless ($res->[0]);
return 1 unless ($GSNDMaxReturns);
return 0 if ($res->[3] && ($res->[3]+($b?1:0)>$res->[2]*$GSNDMaxReturns));
debug_log(0,'gsnd_check %s ! %s',$t,$a);
return 1;
}
sub srs_domain {
my ($rcpt) = @_;
return 0 unless ($SRSDomain);
return 1 if ($rcpt =~ /\@$SRSDomain>?$/i);
return 0;
}
sub srs_sender {
return 0 unless ($RelayAddr =~ /^$LocalNets$/i || check_black_nets($RelayAddr));
return 0 unless ($SRSDomain && $SRSSecret);
return 0 if ($Sender =~ /\@$OurDomains>?$/i);
return 0 if ($Sender =~ /\@$SRSDomain>?$/i);
return 0 unless (load_modules('Mail::SRS'));
my $out = 0;
my $tot = 0;
foreach my $a (@Recipients) {
next if (address_is_local($a,0,1));
$out ++;
$tot ++;
last;
}
return 0 unless ($out);
my $srs; eval { $srs = new Mail::SRS({Secret=>split(/\s*;\s*/,$SRSSecret)}); }; #*
return 0 unless ($srs);
my $sender;
eval { $sender = $srs->forward(address_strip_nc($Sender),$SRSDomain); };
return 0 unless ($sender);
return 0 if (address_strip($sender) eq address_strip($Sender));
debug_log(0,'srs_sender %s %s',$Sender,$sender);
gsnd_add($sender,$tot);
#return 0;
do_action_insert_header($entity,"X-SRS-F",sprintf('%s -> %s',$Sender,$sender));
do_action_insert_header($entity,'Resent-Message-ID',sprintf('<srs.%s.%x.%x.%x@%s>',$SLVars{QI},time(),$$,rand(65535),$MyFilterHostName));
do_action_insert_header($entity,'Resent-Date',rfc2822_date());
do_action_insert_header($entity,'Resent-Sender',$sender);
do_action_insert_header($entity,'X-Return-Path',$Sender);
#do_action_insert_header($entity,'Resent-From',"mailer-daemon\@$MyFilterHostName");
change_sender($sender);
$Sender = $sender;
return $sender;
}
sub srs_recipient {
my ($rcpt,$b) = @_;
#debug_log(0,'srs_recipient ?? %s %s',$rcpt,$b);
return 0 unless ($SRSDomain && $SRSSecret);
return 0 unless ($rcpt =~ /\@$SRSDomain>?$/i);
return 0 unless (load_modules('Mail::SRS'));
debug_log(7,'srs_recipient g? %s',$rcpt);
return 0 unless (gsnd_check($rcpt,$b));
debug_log(5,'srs_recipient s? %s',$rcpt);
my $srs; eval { $srs = new Mail::SRS({MaxAge=>sprintf('%u',$GSNDExpire/(24*60*60)),Secret=>split(/\s*;\s*/,$SRSSecret)}); }; #*
return 0 unless ($srs);
debug_log(5,'srs_recipient r? %s',$rcpt);
my $rwrcpt = '';
eval { $rwrcpt = $srs->reverse(address_strip_nc($rcpt)); };
return 0 unless ($rwrcpt);
debug_log(5,'srs_recipient e? %s %s',$rcpt,$rwrcpt);
return 0 if (lc($rwrcpt) eq lc($rcpt));
debug_log(0,'srs_recipient !! %s %s',$rcpt,$rwrcpt);
return $rwrcpt;
}
sub srs_recipients {
my ($entity) = @_;
return 0 unless (load_modules('Mail::SRS'));
my @rwrcpts = ();
$many = -1;
foreach my $rcpt (list_recipients) {
$many ++;
my $rwrcpt = srs_recipient($rcpt,1);
next unless ($rwrcpt);
push @rwrcpts, {o=>$rcpt,n=>$rwrcpt};
}
return 0 unless (@rwrcpts);
foreach my $rcpt (@rwrcpts) {
do_action_insert_header($entity,"X-SRS-T",sprintf('%s -> %s',$rcpt->{o},$rcpt->{n})) unless ($many);
do_replace_recipients($rcpt->{o},$rcpt->{n});
}
do_action_insert_header($entity,"X-SRS-T",sprintf('%u',scalar @rwrcpts)) if ($many);
return scalar @rwrcpts unless ($SRSCopyBounce && $Sender =~ /^<?>?$/);
if ($SRSCopyBounce =~ /^\S+\@\S+$/) {
debug_log(0,'srs_recipients cb %s',$SRSCopyBounce);
do_add_recipients($SRSCopyBounce);
} else {
debug_log(0,'srs_recipients cb %s',$AdminAddress);
do_add_recipients($AdminAddress);
}
return scalar @rwrcpts;
}
sub srs_capture_dsn {
my ($entity) = @_;
return 0 unless ($entity && $entity->head);
return 0 unless ($SRSDSNCaptureNet || $SRSDSNCaptureHost || $SRSDSNCaptureRcpt || $SRSDSNCaptureSndr || $SRSDSNCaptureFrom || $SRSDSNCaptureTo || $SRSDSNCaptureSubj);
return 0 if ($mailtoobig);
debug_log(7,'srs_capture_dsn ?');
return 0 if ($SRSDSNCaptureNet && $RelayAddr !~ /^$SRSDSNCaptureNet$/);
return 0 if ($SRSDSNCaptureHost && $RelayHostName !~ /^$SRSDSNCaptureHost$/i);
return 0 if ($SRSDSNCaptureRcpt && ($#Recipients != 0 || $Recipients[0] !~ /^<?$SRSDSNCaptureRcpt>?$/i));
return 0 if ($Sender !~ /^<?$SRSDSNCaptureSndr>?$/i);
return 0 unless (lc($entity->mime_type) eq 'multipart/report');
return 0 unless (lc($entity->head->mime_attr('content-type.report-type')) eq 'delivery-status');
if ($SRSDSNCaptureFrom) {
my @al = ();
return 0 unless (get_addresses_from_header($entity,'From:Sender:Reply-To',\@al));
return 0 unless (address_match($$SRSDSNCaptureFrom,@al));
}
if ($SRSDSNCaptureTo) {
my @al = ();
return 0 unless (get_addresses_from_header($entity,'To',\@al));
return 0 unless (address_match($$SRSDSNCaptureFrom,@al));
}
if ($SRSDSNCaptureSubj) {
my $subj = $entity->head->get('Subject');
return 0 unless (defined($subj) && $subj ne '');
return 0 unless ($subj =~ /^$SRSDSNCaptureSubj$/i);
}
debug_log(0,'srs_capture_dsn r %s',join(',',@Recipients));
my $bounce = read_bounce_msg('./INPUTMSG');
return 0 unless ($bounce);
return 0 unless ($bounce->is_bounce);
debug_log(5,'srs_capture_dsn b');
my $bmsg = $bounce->orig_message;
return unless ($bmsg && $bmsg->head);
return 0 unless (lc($bmsg->mime_type) eq 'multipart/report');
return 0 unless (lc($bmsg->head->mime_attr('content-type.report-type')) eq 'delivery-status');
debug_log(5,'srs_capture_dsn m');
my $addr = '';
my $srsa = '';
foreach my $rep ($bounce->reports) {
my $ea = $rep->get('email');
next unless ($ea);
return 0 if ($srsa && lc($ea) ne lc($srsa));
$srsa = $ea unless ($srsa);
my $aa = srs_recipient($ea);
return 0 unless ($aa);
return 0 if ($addr && lc($aa) ne lc($addr));
$addr = $aa unless ($addr);
}
return 0 unless ($srsa && $addr);
debug_log(0,'srs_capture_dsn a %s %s',$srsa,$addr);
#$addr = $AdminAddress;
send_mail('','',$srsa,$bmsg->as_string);
return 1;
}
#***********************************************************************
# Mail sending stuff.
#***********************************************************************
# Like stream by domain, but only splits between our and not our
sub stream_by_our () {
return 0 if (!in_message_context("stream_by_our"));
my @our = ();
my @their = ();
foreach $rcpt (@Recipients) {
if ($rcpt =~ /\@$OurDomains>?$/) {
push @our, $rcpt;
} else {
push @their, $rcpt;
}
}
return 0 unless (@our && @their);
debug_log(2,'stream_by_our o %s',join(', ',@our));
debug_log(2,'stream_by_our t %s',join(', ',@their));
unless (resend_message(@our) && resend_message(@their)) {
md_syslog('crit', 'stream_by_our: COULD NOT RESEND MESSAGE - PLEASE INVESTIGATE');
action_bounce("Unable to stream message");
return 1;
}
$TerminateAndDiscard = 1;
return 1;
}
sub smtp_send_entity {
my ($msg,$address) = @_;
return 0 unless ($MailResultMailer && $msg && $address && load_modules('Net::SMTP'));
my $smtp = Net::SMTP->new($MailResultMailer);
return 0 unless ($smtp);
debug_log(0,'smtp_send_entity: %s',$address);
# my $sok = ($smtp->mail($DaemonAddress) && $smtp->recipient($address) && $smtp->data($msg->as_string));
# $smtp->quit;
# md_syslog('err',"Error sending entity to $address!") unless ($sok);
# return $sok;
}
@result_reports = ();
# Create and send a result report in answer to result query
sub clear_result_report {
@result_reports = ();
}
sub make_result_report {
my $entity = shift;
my $adress = shift;
my $subject = shift;
my $attent = shift;
my $attorg = shift;
push @result_reports, @_ if (@_);
$subject = 'Result Report' unless ($subject);
return undef unless (@result_reports && load_modules('MIME::Entity','Encode'));
my @resreps = ();
{
my $fc = get_fortune();
push @resreps, $fc if ($fc);
}
push @resreps, sprintf('Time: %u',time_since_stamp());
my $text = '';
foreach my $tp ((@result_reports,@resreps)) {
$tp =~ s/^\n*(.*?)\n*$/$1/s;
if ($tp) {
$text .= "\n---8<---\n\n" if ($text);
$text .= "$tp\n";
}
}
return undef unless ($text);
debug_log(2,'make_result_report: length=%u',length($text));
$subect .= ': '.$entity->head->get('Subject') if (defined($entity) && defined($entity->head));
$subject =~ s/:\s*$//;
my $msg = MIME::Entity->build(
Type => 'text/plain',
From => $DaemonAddress,
To => $address,
Subject => $subject,
Data => encode('iso-8859-1',$text),
Encoding => '-SUGGEST',
Charset => 'iso-8859-1',
'Message-ID:' => sprintf('<rr.%s.%x.%x.%x@%s>',$SLVars{QI},time(),$$,rand(65535),$MyFilterHostName),
);
unless ($msg) {
md_syslog('err','Error making result report!');
return undef;
}
if ($attent && defined($entity)) {
$msg->attach(
Data => $entity->as_string,
Type => 'message/rfc822',
Encoding => '-SUGGEST',
Dispostion => 'attachment',
Filename => 'DefangedMessage.eml',
);
}
if ($attorg && (-f './INPUTMSG')) {
$msg->attach(
Path => './INPUTMSG',
Type => 'message/rfc822',
Encoding => '-SUGGEST',
Dispostion => 'attachment',
Filename => 'OriginalMessage.eml',
);
}
return $msg;
}
sub report_spam_result {
my $entity = shift;
my $subject = shift;
my $msg = make_result_report($entity,$AdminAddress,$subject,0,1,@_);
return 0 unless ($msg);
debug_log(0,'report_spam_result: %s %s',$AdminAddress,$subject);
smtp_send_entity($msg,$AdminAddress);
}
sub do_result_report {
my $entity = shift;
my $attachmsg = shift;
if ($is_result_query) {
$msg = make_result_report($entity,$Sender,'Mail Filter Result Report',$attachmsg && $MailResulAttachDefanged,$attachmsg && $MailResulAttachOriginal,@_);
if ($msg) {
debug_log(0,'do_result_report: %s',$Sender);
smtp_send_entity($msg,$Sender);
}
}
clear_result_report();
}
sub do_xam_report {
my ($shs,$spool,$raddr,$matched) = @_;
if ($shs =~ /spam/i) {
$raddr = $SpamReportAddress unless ($raddr);
$spool = $SpamReportSpool unless ($spool);
} elsif ($shs =~ /ham/i) {
$raddr = $HamReportAddress unless ($raddr);
$spool = $HamReportSpool unless ($spool);
} elsif ($shs =~ /(eml|deliver)/i) {
$raddr = $spool unless ($raddr);
} else {
debug_log(-1,'do_xam_report unknown report type: %s',$shs);
return;
}
debug_log(3,'do_xam_report %s %s',$shs,$spool);
return unless ($spool);
return unless (-d $spool);
my $id = sprintf('iMDFa%Xp%Xt%Xq%s',inet_aton($RelayAddr),$$,time(),$SLVars{QI});
$id =~ s/\./_/g;
my $bn = sprintf('%s/%s',$spool,$id);
my $ext = lc($shs);
$ext =~ s/[^a-z0-9]+//gs;
$ext = ".$ext";
unless (open(RF,'>',"$bn.tmp")) {
debug_log(-1,'do_xam_report error creating msg in %s',$spool);
return;
}
print RF sprintf("X-Matched: %s\n",$matched) if ($matched);
print RF sprintf("Delivered-To: %s\n",$raddr);
print RF sprintf("Sent-To: %s\n",join(' ',@Recipients));
print RF sprintf("Received-From: %s %s\n",$RelayAddr,$RelayHostname);
print RF sprintf("Return-Path: %s\n",$Sender);
print RF synthesize_received_header() if ($shs =~ /(auto?|tra?p|deliver)/i);
unless (open(F,'<','./INPUTMSG')) {
debug_log(-1,'do_xam_report error opening input msg');
close(RF);
unlink("$bn.tmp");
}
while (my $l = <F>) {
$l =~ s/[\r\n]+//gs;
print RF "$l\n";
}
close(F);
close(RF);
unless (rename("$bn.tmp","$bn$ext")) {
debug_log(-1,'do_xam_report error inserting msg');
unlink("$bn.tmp") if (-e "$bn.tmp");
return;
}
debug_log(1,'do_xam_report %s %s',$shs,$id);
}
sub handle_xam_report {
my ($shs) = @_;
return 0 unless ($shs);
stats_log('deliver',$is_xam_report.'_report');
where_log('handle_xam_report');
do_xam_report($shs);
debug_log(2,'Discarding xam report message.');
return 1;
}
#***********************************************************************
# Filter callbacks.
#***********************************************************************
sub return_this {
my $what = shift;
my $code = shift;
my $dsn = shift;
my $msg = reject_answer(@_);
end_time_stamp();
return ($what,$msg,$code,$dsn);
}
sub reject_this_ex {
return return_this('REJECT',@_);
}
sub reject_this {
return reject_this_ex(undef,undef,@_);
}
sub tempfail_this_ex {
return return_this('TEMPFAIL',@_);
}
sub tempfail_this {
return tempfail_this_ex(undef,undef,@_);
}
sub clear_from_filter_end {
$bounceo = undef;
$bouncef = '';
$is_result_query = 0;
$is_xam_report = 0;
@removed_parts = ();
%spamassassin_extra_hits = ();
@countries = ();
@verified_results = ();
$dkimsignature = undef;
undef @new_recipients;
clear_result_report();
html_cleaning_clear(1);
end_time_stamp();
finish_log(20,'filter','R');
}
sub parse_headers {
return undef unless load_modules('MIME::Head');
return undef unless (open(HF,'<','./HEADERS'));
my $head = MIME::Head->read(\*HF);
close(HF);
return $head;
}
#***********************************************************************
# %PROCEDURE: filter_initialize
# %ARGUMENTS:
# %RETURNS:
# nothing
# %DESCRIPTION:
# Called just before a slave begins processing messages.
#***********************************************************************
sub filter_initialize {
InitSLVars();
$hirestime = load_modules('Time::HiRes');
here_log('filter_initialize begin');
sql_connect(1);
if ($SAPreInit || $SAPreCompile) {
my $sao = init_spamassassin_module();
if ($sao) {
debug_log(1,'filter_initialize SA init');
$sao->compile_now(1) if ($SAPreCompile);
} else {
debug_log(-1,'filter_initialize SA init error');
}
}
where_log('filter_initialize end');
}
#***********************************************************************
# %PROCEDURE: filter_cleanup
# %ARGUMENTS:
# %RETURNS:
# nothing
# %DESCRIPTION:
# Called when a slave is about to exit.
#***********************************************************************
sub filter_cleanup {
InitSLVars();
here_log('filter_cleanup begin');
sql_disconnect(1);
while (my ($mod,$pth) = each %INC) {
debug_log(2,'Module: %s',$mod,$pth);
}
where_log('filter_cleanup end');
return 0;
}
#***********************************************************************
# %PROCEDURE: filter_§
# %ARGUMENTS:
# type
# %RETURNS:
# nothing
# %DESCRIPTION:
# Called every now and then.
#***********************************************************************
sub filter_tick {
InitSLVars();
my ($ttype) = @_;
here_log('filter_tick begin');
debug_log(0,'filter_tick %u',$ttype);
sql_connect();
dc_clean();
trap_clean();
clean_time_stamps();
where_log('filter_tick end');
}
#***********************************************************************
# %PROCEDURE: filter_map
# %ARGUMENTS:
# mapname, key
# %RETURNS:
# code, value
# %DESCRIPTION:
# Called when for sendmail socket maps.
#***********************************************************************
sub filter_map {
InitSLVars();
my ($map,$key) = @_;
debug_log(0,'filter_map ??? %s %s',$map,$key);
return ('PERM',"Unknown map: $map");
}
#***********************************************************************
# %PROCEDURE: filter_relay
# %ARGUMENTS:
# ip, host
# %RETURNS:
# action
# %DESCRIPTION:
# Called just after contact
# Requires -r
#***********************************************************************
sub filter_relay {
InitSLVars('A');
my($ip, $hostname) = @_;
$hostname = get_rdns($hostname);
here_log('filter_relay begin');
stats_log('info','filter_relay',$ip,$hostname);
#read_commands_file() if (-f 'COMMANDS');
#macros_stats_log('filter_relay');
unless (check_black_nets($ip)) {
my @fcdns = get_full_circle_dnses($ip);
stats_log('relay_info',$ip,$hostname,'',\@fcdns,scalar get_domains_parts(@fcdns),scalar trim_hosts_parts(@fcdns));
}
# Check if the host is whitelisted
if (check_internal_whitelist($ip)) {
debug_log(2, "filter_relay: Internally whitelisted, $ip");
return ('CONTINUE', "Ok friend, go ahead.");
}
if (check_authenticated(1) || check_external_whitelist($ip,$hostname)) {
debug_log(2, "filter_relay: Whitelisted, $hostname [$ip]");
return ('CONTINUE', "Ok, I know you, go ahead.");
}
# Check if blacklisted
my ($bad,$hit,$log) = check_external_blacklist($ip,$hostname);
if ($bad) {
debug_log(2, "filter_relay: Blacklisted, $hostname [$ip], $log");
stats_log('reject',$log,$hit);
return reject_this("We do not want mail from $hit!");
}
where_log('filter_relay greylist');
my ($ghr,$ghe) = greylist_check_host($ip);
debug_log(3,'filter_relay: gch %i %s %s',$ghr,$ghe,$ip);
if ($gdb_host_black && $ghr > 0 && !greylist_exempt($ip,$hostname)) {
my $greys = time_string($ghr);
debug_log(3,"check_relay: $ghe host in Greylist, $hostname [$ip]");
stats_log('tempfail','grey_host',$ghr);
return tempfail_this("We might accept the connection in $greys.");
}
where_log('filter_relay host');
#if ($ghr && dict_check_host($ip)) {
if (dict_check_host($ip)) {
debug_log(2,"check_relay: Black in Dictionary list, $hostname [$ip]");
#return ('CONTINUE', "We currently do not want mail from $ip, but go head anyway.");
#md_syslog('info', "MDLOG,NOQUEUE,dict,$ip,?,?,?");
stats_log('tempfail','dict',$ip);
return tempfail_this("At the moment we do not want mail from $ip.");
}
where_log('filter_relay block');
if ($block_relay) {
my ($nobl,$rule,$match) = check_blockrelay($ip,$hostname);
unless ($nobl) {
debug_log(1,"filter_relay: Blocked, $hostname [$ip],$match");
#dict_add_?
stats_log('tempfail','block',[$ip,$match,$rule]);
return tempfail_this("Currently we do not want mail from $ip!");
}
}
# Reject if blacklisted with relaydb(p)
# TEMPFAIL is used because the relaydb(p) based blocking
# can change automatically?
#return check_relay('NOQUEUE',$ip, $hostname, 'TEMPFAIL', "", 0);
where_log('filter_relay relay');
return check_relay('NOQUEUE',$ip, $hostname, 'REJECT', "", 0);
}
#***********************************************************************
# %PROCEDURE: filter_helo
# %ARGUMENTS:
# ip, host, helo
# %RETURNS:
# action
# %DESCRIPTION:
# Called just after HELO
# Requires -H
#***********************************************************************
sub filter_helo {
InitSLVars('H');
my($ip, $hostname, $helo) = @_;
$hostname = get_rdns($hostname);
here_log('filter_helo begin');
stats_log('info','filter_helo',$ip,$hostname,$helo);
#read_commands_file() if (-f 'COMMANDS');
#macros_stats_log('filter_helo');
#unless (check_black_nets($ip)) {
# #my @fcdns = get_full_circle_dnses($ip);
# #my @dndns = get_domains_parts(@fcdns);
# #stats_log('relay_info',$ip,$hostname,$helo,\@fcdns,\@dndns);
#}
# Check if the host is in internal whitelist
if (check_internal_whitelist($ip)) {
debug_log(2, "filter_helo: Internally whitelisted, $ip");
return ('CONTINUE', "Ok friend, go ahead.");
}
# Check if the host is in external whitelist
if (check_external_whitelist($ip,$hostname)) {
debug_log(2, "filter_helo: Whitelisted, $sender at $hostname [$ip]");
return ('CONTINUE', "Ok, I now you, go ahead.");
}
# Reject if HELO pretends to be ours but isn't.
if (check_our_helo($helo)) {
dict_add_bad_helo($ip);
stats_log('reject','helo',$helo);
#return ('CONTINUE', "We do not like your HELO/EHLO, but go head anyway.");
#return ('REJECT', "Forged HELO/EHLO ($helo) is not appreciated!");
return reject_this("Forged HELO/EHLO ($helo) is not appreciated!");
}
# Check if the host is in external blacklist
my ($bad,$hit,$log) = check_external_blacklist($ip,$hostname,$helo);
if ($bad) {
dict_add_bad_helo($ip);
debug_log(2, "filter_helo: Blacklisted, $hostname [$ip] ($helo), $log");
stats_log('reject',$log,$hit);
return reject_this("We do not want mail from '$hit'!");
}
where_log('filter_helo end');
return ('CONTINUE', "Ok, go ahead.");
}
#***********************************************************************
# %PROCEDURE: filter_sender
# %ARGUMENTS:
# sender, ip, host, helo
# %RETURNS:
# action
# %DESCRIPTION:
# Called just after MAIL FROM
# Requires -s
#***********************************************************************
sub filter_sender {
InitSLVars('S');
# Reject if blacklisted sender/host in /etc/mail/mimedefang-blacklist
# This is the first called function with id, so we save the stamp here.
save_time_stamp();
my($sender, $ip, $hostname, $helo) = @_;
$hostname = get_rdns($hostname);
here_log('filter_sender begin');
stats_log('info','filter_sender',$ip,$hostname,$helo,$sender);
read_commands_file() if (-f 'COMMANDS');
macros_stats_log('filter_sender');
stats_log('notice','external_local',$ip,$hostname,address_strip($sender)) if ($sender =~ /\@$OurDomains>?$/i && !address_is_local($ip));
# If SRS sender, check if valid?
if (srs_domain($sender)) {
my $srsrcpt = srs_recipient($sender);
if (!$srsrcpt) {
debug_log(-1,'Faked SRS? %s %s %s',$sender,$ip,$hostname);
stats_log('reject','bad_sender',$sender);
return reject_this("Invalid SRS sender.");
} elsif (address_is_local($ip)) {
debug_log(-1,'Resent SRS? %s %s %s',$sender,$ip,$hostname);
return ('CONTINUE', "Ok, resend it.");
} else {
debug_log(-1,'External SRS? %s %s %s',$sender,$ip,$hostname);
return ('CONTINUE', "Ok, resend it.");
}
}
# If local sender, check if valid?
if ($sender =~ /\@$OurDomains>?$/i &&
!($NoCheckUserDomains && $sender =~ /\@(|.*\.)$NoCheckUserDomains$/i) &&
!check_sender_white('ouraddress',$sender)) {
my $srv = storing_server($sender);
if ($srv && $srv !~ /^$NoCheckUserServers$/i) {
my ($ok, $msg) = check_against_smtp_server_cached('<>',$sender,$srv);
if ($ok eq "REJECT") {
dict_add_unknown_user($ip);
stats_log('reject','unknown_local_user',[$sender,$srv]);
return reject_this("Sender $sender not ok. Server said: $msg");
}
}
}
# Check if the host is in internal whitelist
if (check_internal_whitelist($ip)) {
if ($Sender =~ /\@$NoUserDomains>?$/i) {
# This is not supposed to happen...
debug_log(1,"no_user_domain: $sender, $ip, $hostname, $helo");
}
debug_log(2, "filter_sender: Internally whitelisted, $ip");
return ('CONTINUE', "Ok friend, go ahead.") unless (check_any_relay_option($helo,'outsider'));
}
# Check if user is authenticated?
#if (check_authenticated(1)) {
# return ('CONTINUE', "You've got the key, go ahead.")
#}
# Check if blacklisted in /etc/mail/mimedefang-blacklist
my ($bad,$hit,$log) = check_external_blacklist($ip,$hostname,$helo,"",$sender);
if ($bad) {
debug_log(2, "filter_sender: Blacklisted, $sender at $hostname [$ip] ($helo), " . $log);
#return ('CONTINUE', "We do not want mail from $hit, but go head anyway.");
dict_add_abuse($ip);
stats_log('reject',$log,$hit);
return reject_this("We do not want mail from $hit!");
#return tempfail_this("We do not want mail from $hit.");
}
# Check if blacklisted by relaydb
unless (check_sender_white('relaydb',$sender)) {
($bad,$hit,$log) = check_sender_blacklist($sender);
if ($bad) {
debug_log(1, "filter_sender: Blacklisted, $sender at $hostname [$ip] ($helo), " . $log);
#return ('CONTINUE', "We do not want mail from $hit, but go head anyway.");
dict_add_abuse($ip);
stats_log('reject',$log,$hit);
return reject_this("Currently we do not want mail from $hit!");
#return tempfail_this("We do not want mail from $hit.");
}
}
where_log('filter_sender mx');
# Check if sender has valid MX
if ($mxcheck && !check_sender_white('mx',$sender)) {
my ($mxe,$mxr) = mail_address_mx_check($sender);
if ($mxe) {
dict_add_invalid_mx($ip);
if ($mx_tempfail && !check_any_relay_option($helo,'notempfail')) {
stats_log('tempfail','mx',[$sender,$mxr]);
return tempfail_this($mxr);
} else {
stats_log('reject','mx',[$sender,$mxr]);
return reject_this($mxr);
}
}
}
where_log('filter_sender block');
if ($block_sender && !check_sender_white('block',$sender)) {
my ($nobl,$rule,$match) = check_blocksender($ip,$hostname,$helo,$sender);
unless ($nobl) {
debug_log(0,"filter_sender: Blocked, $sender, $match");
stats_log('tempfail','block',[$sender,$match,$rule]);
return tempfail_this("Currently we do not want mail from $sender!");
}
}
where_log('filter_sender end');
return ('CONTINUE', "Ok, go ahead.");
}
#***********************************************************************
# %PROCEDURE: filter_recipient
# %ARGUMENTS:
# recipient, sender, ip, host, first, helo, rcpt_mailer, rcpt_host, rcpt_addr
# %RETURNS:
# action
# %DESCRIPTION:
# Called just after RCPT TO
# Requires -t
#***********************************************************************
sub filter_recipient {
InitSLVars('R');
my($recipient, $sender, $ip, $hostname, $first, $helo, $rcpt_mailer, $rcpt_host, $rcpt_addr) = @_;
$hostname = get_rdns($hostname);
here_log('filter_recipient begin');
stats_log('info','filter_recipient',$ip,$hostname,$helo,$sender,$recipient,$rcpt_mailer,$rcpt_host,$rcpt_addr);
read_commands_file() if (-f 'COMMANDS');
#macros_stats_log('filter_recipient');
#debug_log(0,'filter_recipient ph %s|%s|%s|%s|%u',$recipient,$rcpt_mailer,$rcpt_host,$rcpt_addr,$rloc);
if ($SpamTrapAddresses && !check_internal_whitelist($RelayAddr) && spam_trap_this($sender,$recipient)) {
dict_add_trap($ip) if ($SpamTrapReportRelay);
if ($trap_chance && rand(100) >= $trap_chance) {
stats_log('reject','no_trap',['chance',$trap_chance]);
return reject_this("I am not in the mood.");
}
if (trap_many()) {
stats_log('reject','no_trap',['amount',$trap_maxwindow,$trap_timewindow]);
return reject_this("I am currently fed up.");
}
if ($trap_maxload && get_load_average() > $trap_maxload) {
stats_log('reject','no_trap',['load',$trap_maxload]);
return reject_this("I have too much to do at the moment.");
}
if ($trap_maxswap && get_swap_percentage() > $trap_maxswap) {
stats_log('reject','no_trap',['swap',$trap_maxswap]);
return reject_this("I have too much to do at the moment.");
}
stats_log('trap',$sender,$recipient);
return ('CONTINUE', "Ok, spam ahead.");
}
for (my $ri=0;$ri<$#Recipients;$ri++) {
#debug_log(0,'filter_recipient ri %s|%u',$Recipients[$ri],$oloc);
if ($sender =~ /^<?>?$/) {
debug_log(0,"filter_recipient: bad <>, r=$recipient, f=$first");
if (check_internal_whitelist($ip)) {
stats_log('tempfail','bad_sender','<>');
return tempfail_this_ex('452','4.5.3',"Sender <> is not allowed to send to multiple recipients.");
} else {
dict_add_abuse($ip);
stats_log('reject','bad_sender','<>');
return reject_this("Sender <> is not allowed to send to multiple recipients.");
}
} elsif ($oloc) {
my $ria = address_strip($Recipients[$ri]);
if ($ria eq $MailResultAddress) {
stats_log('tempfail','bad_user',[$MailResultAddress,$recipient]);
return tempfail_this_ex('452','4.5.3',"Combining result query address with other addresses is not allowed!");
} elsif ($ria eq $SpamReportAddress) {
stats_log('tempfail','bad_user',[$SpamReportAddress,$recipient]);
return tempfail_this('452','4.5.3',"Combining spam report adress with other addresses is not allowed!");
} elsif ($ria eq $HamReportAddress) {
stats_log('tempfail','bad_user',[$HamReportAddress,$recipient]);
return tempfail_this('452','4.5.3',"Combining ham report adress with other addresses is not allowed!");
} elsif ($PassAbuse && $ria =~ /^abuse\@[^\@]+$/) {
stats_log('tempfail','bad_user',[$Recipients[$ri],$recipient]);
return tempfail_this_ex('452','4.5.3',"Abuse must be solo here.");
} elsif (srs_recipient($Recipients[$ri])) {
stats_log('tempfail','bad_user',[$Recipients[$ri],$recipient]);
return tempfail_this_ex('452','4.5.3',"SRS recipients must be solo here.");
}
}
}
# <>
if ($sender =~ /^<?>?$/ && $first && $first ne $recipient) {
debug_log(3,"filter_recipient: bad <>, r=$recipient, f=$first");
if (check_internal_whitelist($ip)) {
stats_log('tempfail','bad_sender','<>');
return tempfail_this_ex('452','4.5.3',"Sender <> is not allowed to send to multiple recipients.");
} else {
stats_log('reject','bad_sender','<>');
dict_add_abuse($ip);
return reject_this("Sender <> is not allowed to send to multiple recipients.");
}
}
# abuse...
if ($PassAbuse && $recipient =~ /^<?abuse\@[^\@]+>?$/i && $#Recipients) {
stats_log('tempfail','bad_user',$recipient);
return tempfail_this_ex('452','4.5.3',"Abuse must be solo here.");
}
# Result-tester address?
my $irq = 0;
if ($MailResultAddress && (address_strip($recipient) eq $MailResultAddress)) {
unless (check_sender_white('result',$sender)) {
dict_add_unknown_user($ip);
stats_log('reject','bad_user',$MailResultAddress);
return reject_this("Cannot deliver to $recipient!");
}
if ($#Recipients) {
#md_syslog('info', "MDLOG,bad_user,$MailResultAddress,$ip,$sender,$recipient,?");
stats_log('tempfail','bad_user',$MailResultAddress);
return tempfail_this_ex('452','4.5.3',"Combining result query address with other addresses is not allowed!");
}
$irq = 1;
}
# Spam/ham report address?
my $ixr = '';
my $ixa = '';
if ($SpamReportAddress && (address_strip($recipient) eq $SpamReportAddress)) {
$ixa = $SpamReportAddress;
$ixr = 'spam';
} elsif ($HamReportAddress && (address_strip($recipient) eq $HamReportAddress)) {
$ixa = $HamReportAddress;
$ixr = 'ham';
}
if ($ixr) {
unless (check_internal_whitelist($ip) || check_authenticated(1)) {
dict_add_unknown_user($ip);
stats_log('reject','bad_user',$ixa);
return reject_this("Cannot deliver to $recipient!");
}
if ($#Recipients) {
stats_log('tempfail','bad_user',$ixa);
return tempfail_this('452','4.5.3',"Combining $ixr report adress with other addresses is not allowed!");
}
$ixr = 1;
}
# Special cases.
my $dom = '';
my $usr = '';
if ($rcpt_mailer =~ /^e?smtp$/i) {
$usr = address_strip($rcpt_addr);
} else {
$usr = address_strip($recipient);
}
if ($usr =~ /^(.*)\@(.*)$/) {
$dom = $2;
$usr = $1;
}
debug_log(7,'filter_recipient ud "%s" "%s" "%s" "%s" "%s" "%s"',$usr,$dom,$recipient,$rcpt_mailer,$rcpt_host,$rcpt_addr);
if ($dom =~ /[^-_.a-zA-Z0-9].*\.$OurDomains$/ || $dom =~ /\%/) {
#md_syslog('info', "MDLOG,unknown_user,$rcpt_host,$ip,$sender,$recipient,?");
dict_add_unknown_user($ip);
stats_log('reject','bad_domain',$dom);
return reject_this("Invalid domain.");
}
unless (check_internal_whitelist($ip)) {
if ($dom =~ /^\[?\d+\.\d+\.\d+\.\d+\]?$/) {
dict_add_unknown_user($ip);
debug_log(0,'filter_recipient ip_domain %s %s %s',$rcpt_mailer,$rcpt_addr,$dom);
stats_log('reject','unknown_user',[$recipient,$rcpt_host]);
return reject_this("IP address domains not accepted.");
}
}
if ($dom =~ /^$NoUserDomains$/i ||
($dom =~ /^$MyFilterHostNames$/i && $ip ne '127.0.0.1') ||
!($dom || $usr eq 'postmaster') ||
$dom =~ /^[^\.]+$/) {
dict_add_unknown_user($ip);
#debug_log(0,'filter_recipient no_user_domain %s %s %s %s %s',$rcpt_mailer,$rcpt_addr,$dom,$NoUserDomains,$MyFilterHostNames);
stats_log('reject','unknown_user',[$recipient,$rcpt_host]);
return reject_this("No users at that domain.");
}
# Blacklist by recipient
if(!check_external_whitelist_by_recipient($ip,$hostname,"","",$sender,$recipient)) {
my($bad, $hit, $log) = check_external_blacklist_by_recipient($ip,$hostname,$helo,"",$sender,$recipient);
if ($bad) {
$log = "by_recipient_$log";
dict_add_unknown_user($ip);
stats_log('reject',$log,$hit);
return reject_this("Mail not accepted for $recipient.");
}
}
return ('CONTINUE', "Ok, go ahead with result query.") if ($irq);
return ('CONTINUE', "Ok, go ahead with $ixr report.") if ($ixr);
return ('CONTINUE', "Ok, attach away.") if (catch_replace_attachments($recipient,(check_internal_whitelist($ip)||check_authenticated(1))));
# Check SRS recipient
if (srs_domain($recipient)) {
my $srsrcpt = srs_recipient($recipient);
if (!$srsrcpt) {
stats_log('reject','bad_user',$recipient);
return reject_this("Invalid SRS recipient.");
} elsif ($#Recipients) {
stats_log('tempfail','bad_user',$recipient);
return tempfail_this_ex('452','4.5.3',"SRS recipients must be solo here.");
} else {
return ('CONTINUE', "Ok, react ahead.");
}
}
where_log('filter_recipient mx');
# Check special rcpt mx map
{
#my ($res,$ok) = check_mail_address_mx_map('/etc/mail/mimedefang-rcpt-map',$recipient);
my ($res,$txt) = check_mail_address_mx_map('rcpt-map',$recipient);
unless ($res) {
debug_log(3,'filter_recipient: bad recipient from map %s %s',$recipient,$txt);
dict_add_unknown_user($ip);
stats_log('reject','bad_recipient_map',$recipient);
return reject_this("Cannot deliver to $recipient. Server check result: $txt");
}
}
where_log('filter_recipient local/prog');
return ('CONTINUE', "Ok, pipe ahead.") if ($rcpt_mailer eq 'prog');
return ('CONTINUE', "Ok, save ahead.") if ($rcpt_mailer eq 'local');
#where_log('filter_recipient host');
#if (!(check_internal_whitelist($ip) || check_external_whitelist($ip,$hostname)) && dict_check_host($ip)) {
# debug_log(2,"check_recipient: Black in Dictionary list, $hostname [$ip]");
# #return ('CONTINUE', "We currently do not want mail from $ip, but go head anyway.");
# #md_syslog('info', "MDLOG,NOQUEUE,dict,$ip,?,?,?");
# stats_log('tempfail',$SLVars{QI},'dict',$ip);
# return tempfail_this("At the moment we do not want mail from $ip.");
#}
where_log('filter_recipient local');
my $ldal = read_delivery_file('local-delivery');
if ($ldal) {
for my $ai (@{$ldal}) {
debug_log(7,'filter recipient ld? %s %s %s %s:%s',$recipient,$ai->{a},$ai->{w},$ai->{f},$ai->{d});
next unless ($recipient =~ /^<?$ai->{a}?>$/);
next unless ($ai->{w} =~ /[->]/ && $ai->{w} !~ /[=+]/);
debug_log(2,'filter recipient ld! %s %s %s %s:%s',$recipient,$ai->{a},$ai->{w},$ai->{f},$ai->{d});
return ('CONTINUE',"Address $rcpt_addr local, go ahead.");
}
}
where_log('filter_recipient user');
# If mail will be delivered to one of our hosts, check the user.
unless ($NoCheckUserDomains && $rcpt_addr =~ /\@(|.*\.)$NoCheckUserDomains$/i) {
my ($df,$uf) = check_user_in_domain($rcpt_addr);
if ($df) {
debug_log(0,'filter_recipient user in domain %s %i',$rcpt_addr,$uf);
return ('CONTINUE',"Address $rcpt_addr ok, go ahead.") if ($uf);
dict_add_unknown_user($ip);
stats_log('reject','unknown_user',[$recipient]);
return reject_this("Cannot deliver to $rcpt_addr. User unknown.");
}
my $cassh;
if ($rcpt_mailer =~ /^e?smtp$/ && $rcpt_host =~ /^\[$LocalNets\]$/i) {
$cassh = $rcpt_host;
} elsif ($rcpt_addr =~ /\@$OurDomains>?$/i) {
$cassh = storing_server($rcpt_addr);
}
if ($cassh && $cassh !~ /^$NoCheckUserServers$/i) {
$cassh =~ s/^(\[)(.*)(\])$/$2/;
#debug_log(0,'filter_recipient cassc %s %s %s',$sender,$rcpt_addr,$cassh);
my ($ok, $msg) = check_against_smtp_server_cached($sender,$rcpt_addr,$cassh);
#debug_log(0,'filter_recipient cassc %s %s',$ok,$msg);
return ('CONTINUE',"Address $rcpt_addr ok, go ahead.") if ($ok eq "CONTINUE");
if ($ok eq "REJECT") {
dict_add_unknown_user($ip);
stats_log('reject','unknown_user',[$recipient,$rcpt_host]);
return reject_this("Cannot deliver to $rcpt_addr. Server said: $msg");
}
debug_log(-1,"filter_recipient: unhandled answer from storing host ('%s','%s')",$ok,$msg);
return ('CONTINUE',"Not sure wether the user is ok or not, so go ahead") if ($CheckUserErrorContinue);
stats_log('tempfail','unknown_user',[$recipient,$rcpt_host]);
return tempfail_this("Error checking $rcpt_addr: $msg");
}
}
where_log('filter_recipient end');
return ('CONTINUE', "Ok, go ahead.");
}
#***********************************************************************
# %PROCEDURE: filter_before
# %ARGUMENTS:
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Called just before e-mail is parsed
#***********************************************************************
$filter_before_called = 0;
sub filter_before {
InitSLVars('M');
here_log('filter_before begin');
$filter_before_called ++;
if ($RelayHostname eq $RealRelayHostname) {
$RelayHostname = get_rdns($RelayHostname);
$RealRelayHostname = $RelayHostname;
} else {
$RelayHostname = get_rdns($RelayHostname);
$RealRelayHostname = get_rdns($RealRelayHostname);
}
stats_log('info','filter_before',$RelayAddr,$RelayHostName,$Helo,$Sender,\@Recipients,$RealRelayHostname);
#macros_stats_log('filter_before');
#die('Missing modules!') unless (load_modules('Mail::Header'));
#debug_log(0,'filter_before %s %s %s',$RealRelayHostname,$Sender,join(',',@Recipients));
$ScanStartedAt = time();
$ModifiedHTML = 0;
%modhead = ();
%warnhead = ();
$FoundVirus = 0;
$FoundSuspected = 0;
$GreyListAction = '';
$forcespamcheck = 0;
$wantsspamcheck = 0;
%spamassassin_extra_hits = ();
@verified_results = ();
@removed_parts = ();
@warningtexts = ();
@countries = ();
$dkimsignature = undef;
undef @new_recipients;
$did_quarantine = 0;
$input_message_hash = undef;
$bounceo = undef;
$bouncef = '';
my $size = (stat('./INPUTMSG'))[7];
stats_log('size',$size);
@replaced_attachments = ();
$replace_attachments_path = '';
$replace_all_attachments = 0;
$do_replace_attachments = 0;
#debug_log(0,'filter_before attachment hard mail limit: %u %u',$attachments_hard_mail_limit,$size);
$do_replace_attachments = 'hard' if ($attachments_hard_mail_limit && $size > $attachments_hard_mail_limit);
$replace_all_attachments = 1 if ($attachments_max_mail_size && $size > $attachments_max_mail_size);
$is_result_query = 0;
$is_xam_report = 0;
@result_reports = ();
my $head; # Might get initialized from parse_header later...
my $hostn = '';
$hostn = $RelayHostname if (defined($RelayHostname));
#$warnhead{"Debug filter ($FilterVersion)."} ++ if ($FilterDebug);
#$warnhead{"Dummy warning."} ++ if ($FilterDebug);
if (pass_abuse()) {
debug_log(0,'filter_before abuse');
$warnhead{'Sent to Abuse address.'} ++;
}
# To a trap?
here_log('filter_before trap');
if ($SpamTrapAddresses && !check_internal_whitelist($RelayAddr)) {
my $trapped = 0;
foreach my $rcpt (@Recipients) {
next unless (spam_trap_this($Sender,$rcpt));
if ($SpamTrapReportRelay && defined($gdb_reset)) {
if ($gdb_reset_host) {
greylist_reset($RelayAddr,'','');
} else {
greylist_reset($RelayAddr,$Sender,$rcpt);
}
}
$trapped ++;
stats_log('trapped',$rcpt);
do_xam_report('spam-trap',$SpamTrapSpool,$rcpt);
do_del_recipients($rcpt);
trap_add($RelayAddr);
stats_log('deliver','spam_report');
}
if ($trapped) {
report_no_spam_spam($RelayAddr);
if ($SpamTrapReportRelay) {
report_address_relay_spam($RelayAddr);
greylist_reset_host($RelayAddr) if (defined($gdb_host_reset));
}
unless (list_recipients()) {
stats_log('discard','trapped',\@Recipients);
return action_discard();
}
}
}
where_log('filter_before spam hash');
if ($spamdb && !(check_internal_whitelist($RelayAddr) || pass_abuse())) {
my $mhash = make_spam_hash();
my ($spam,$stamp,$mid,$hits,$req) = check_spam_hashes($mhash);
if ($spam) {
my $when = load_modules('Date::Format') ? time2str('%Y-%m-%d %H:%M',$stamp) : sprintf('%u',$stamp);
dict_add_abuse($RelayAddr);
debug_log(0,'filter_before: remembered spam %s <%s> %03.1f/%i',$when,$mid,$hits,$req);
stats_log('reject','spam',[$hits,$req,$mid,$stamp]);
inc_spam_hash($mhash);
return do_action_bounce(sprintf("Message seems to be spam (%03.1f/%i) [%s] {%s}",$hits,$req,$when,$mid));
}
}
# Split locally generated mail by whatever?
where_log('filter_before stream');
if ($StreamBlack && check_black_nets($RelayAddr) && $#Recipients>0) {
if ($StreamBlack =~ /^r(?:ecipient|cpt)?$/i && stream_by_recipient()) {
stats_log('stream','black',['recipient',$StreamBlack,@Recipients]);
return;
}
if ($StreamBlack =~ /^d(?:om(?:ain)?)?$/i && stream_by_domain()) {
stats_log('stream','black',['domain',$StreamBlack,@Recipients]);
return;
}
if ($StreamBlack =~ /^o(?:ur)?(?:d(?:om(?:ain)?)?)?$/i && stream_by_our()) {
stats_log('stream','black',['our',$StreamBlack,@Recipients]);
return;
}
}
# Result-tester or report address?
here_log('filter_before query/report');
if ($MailResultAddress || $SpamReportAddress || $HamReportAddress) {
my %xamr = ('spam'=>$SpamReportAddress,'ham'=>$HamReportAddress);
my $spad = 0;
for (my $ri=0; $ri<@Recipients; $ri++) {
my $rea = address_strip($Recipients[$ri]);
if ($spad) {
stats_log('reject','bad_user',$rea);
return do_action_bounce("Combining spam/ham report or result query adress with other addresses is not allowed!");
}
if ($MailResultAddress && $rea eq $MailResultAddress) {
$spad ++;
$is_result_query = 1;
spamassassin_hit('RESULT_QUERY',0,'Mail is a filter result query');
}
while (my ($xamt,$xama) = each %xamr) {
if ($xama && $rea eq $xama) {
$spad ++;
$is_xam_report = $xamt;
spamassassin_hit(uc($xamt).'_REPORT',0,"Mail is a $xam report");
}
}
if ($spad > 1 || ($spad && $ri)) {
stats_log('reject','bad_user',$rea);
return do_action_bounce("Combining spam/ham report or result query adress with other addresses is not allowed!");
}
}
}
debug_log(1,"filter_before: result query from $Sender") if ($is_result_query);
debug_log(1,"filter_before: spam/ham report from $Sender") if ($is_xam_report);
# Spam/ham report?
return action_accept() if ($is_xam_report);
# Dictionary list...
#where_log('filter_before host');
#if (!(check_internal_whitelist($RelayAddr) || check_external_whitelist($RelayAddr,$RelayHostname)) && dict_check_host($RelayAddr)) {
# debug_log(0,"filter_before: Black in Dictionary list, $RelayHostname [$RelayAddr]");
# #return ('CONTINUE', "We currently do not want mail from $ip, but go head anyway.");
# #md_syslog('info', "MDLOG,NOQUEUE,dict,$ip,?,?,?");
# stats_log('tempfail','dict',$RelayAddr);
# return tempfail_this("At the moment we do not want mail from $RelayAddr.");
#}
# Check greylist here instead of in filter_recipient in order to handle
# stupid mailers...
where_log('filter_before greylist');
if ($greylist && !(check_internal_whitelist($RelayAddr))) {
$head = parse_headers() unless ($head);
msgl_add($head->get('Message-ID'),0,$Sender,@Recipients) if ($head);
if (greylist_exempt($RelayAddr,$hostn,$Helo,$Sender,\@Recipients,$head)) {
$GreyListAction = 'Exempted'
} else {
my $greylistwait = 0;
foreach my $crec (@Recipients) {
if (!(check_external_whitelist($RelayAddr,$hostn,$Sender) || check_recipient_white('grey',$crec))) {
#Check greylist
my $grey;
($grey,$GreyListAction) = greylist_check($RelayAddr,$Sender,$crec);
if ($grey > 0) {
my $greys = time_string($grey);
debug_log(2, "filter_before: Greylisted ($greys), $Sender at $RelayAddr to $crec");
$greylistwait = $grey if ($grey > $greylistwait);
} elsif ($grey < 0) {
md_syslog('warning', "filter_before: greylist_check returned error!");
return do_action_tempfail("Something is not working right here. Please try again.");
}
}
}
if ($greylistwait) {
my $greys = time_string($greylistwait);
stats_log('tempfail','grey',$greylistwait);
return do_action_tempfail("We might accept the mail in $greys.");
}
}
}
# Do a relay check on received lines as well. We do this because spammers
# often send through backup servers. I know, the headers could be forged, but if
# someone forges a received header so it looks like a mail is from a blacklisted
# host I don't really mind if it gets rejected.
# If the message gets here, we're not actually upset with the relay contacting us,
# so we give a permanent error instead of tempfailing.
where_log('filter_before received');
if ($check_received && !((check_internal_whitelist($RelayAddr) && !check_any_relay_option($Helo,'outsider')) || check_recipients_white('relay',\@Recipients))) {
$head = parse_headers() unless ($head);
if ($head) {
where_log('filter_before received.');
my ($hit,$msg,$rcs)=check_received_lines($Sender,$head);
where_log('filter_before received..');
#debug_log(0,"filter_before: This mail would have been blocked becase of received lines: $msg") if ($hit);
if ($hit) {
dict_add_abuse($RelayAddr);
return do_action_bounce($msg);
}
where_log('filter_before received...');
}
}
where_log('filter_before end');
#debug_log(0,'filter_before senders: %s',get_addresses_string_from_header($head,'From:Sender:Reply-To')) if ($head);
}
#***********************************************************************
# %PROCEDURE: filter_begin
# %ARGUMENTS:
# entity -- a Mime::Entity object (see MIME-tools documentation for details)
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Called just before e-mail parts are processed
#***********************************************************************
sub filter_begin {
my($entity) = @_;
unless ($filter_before_called) { # In case mimedefang.pl doesn't call filter_before...
filter_before();
return if ($TerminateAndDiscard || message_rejected());
}
return if message_rejected(); # Avoid unnecessary work
here_log('filter_begin begin');
#debug_log(0,'filter_begin senders: %s',get_addresses_string_from_header($entity,'From:Sender:Reply-To'));
#debug_log(0,'filter_begin %s %s %s',$RealRelayHostname,$Sender,join(',',@Recipients));
# Spam/ham report?
return action_accept() if ($is_xam_report);
$Features{"HTML::Parser"} = load_modules('HTML::Parser') unless ($Features{"HTML::Parser"});
$Features{"HTML::TokeParser"} = load_modules('HTML::TokeParser') unless ($Features{"HTML::TokeParser"});
$Features{"Archive::Zip"} = load_modules('Archive::Zip qw(:ERROR_CODES)') unless ($Features{"Archive::Zip"});
html_cleaning_clear(1);
$hc_main_entity = $entity;
my $hostn = '';
$hostn = $RelayHostname if (defined($RelayHostname));
where_log('filter_begin srsdsn');
return action_discard if (srs_capture_dsn($entity));
#srs_capture_dsn($entity);
if (pass_abuse() || check_recipients_white('security',\@Recipients)) {
md_syslog('info', "Security-checking FB1 of message bypassed: $RelayAddr; ".join(', ',@Recipients));
$warnhead{'Security-checking bypassed.'} ++;
} else {
# Always drop messages with suspicious chars in headers
where_log('filter_begin chars');
if ($SuspiciousCharsInHeaders) {
if ($SASuspiciousHeadScore) {
spamassassin_hit('SUSPECT_HEAD',$SASuspiciousHeadScore,'Suspicious characters in header.');
} else {
stats_log($SuspiciousHeadDiscard?'discard':'reject','suspicious_chars');
do_action_quarantine_entire_message('stopped',"Message quarantined because of suspicious characters in headers.");
return action_discard() if ($SuspiciousHeadDiscard);
return do_action_bounce('Bad data: suspicious chars in header');
}
}
if ($SuspiciousCharsInBody) {
if ($SASuspiciousBodyScore) {
spamassassin_hit('SUSPECT_BODY',$SASuspiciousBodyScore,'Suspicious characters in body.');
} else {
stats_log($SuspiciousBodyDiscard?'discard':'reject','suspicious_chars');
do_action_quarantine_entire_message('stopped',"Message quarantined because of suspicious characters in body.");
return action_discard() if ($SuspiciousBodyDiscard);;
return do_action_bounce('Bad data: suspicious chars in body');
#debug_log(0,'suspicious_chars in body');
}
}
}
# Check is spam
where_log('filter_begin spam');
if ($entity && $entity->head && !not_check_for_spam($entity,$verified)) {
my ($spam,$when) = msgl_spam($entity->head->get('Message-ID'),$Sender,@Recipients);
if ($spam) {
debug_log(0,'filter_begin: spam %u',abs($spam));
dict_add_abuse($RelayAddr);
if ($spam>0) {
$when = load_modules('Date::Format') ? time2str('%Y-%m-%d %H:%M:%S',$when) : sprintf('%u',$when);
debug_log(0,'filter_begin: spam %u %s',$spam,$when);
stats_log('reject','spam_repeat',[$entity->head->get('Message-ID'),$spam,$when]);
return do_action_bounce(sprintf("Message seemed to be spam (%u, %s)",$spam,time2str('%Y-%m-%d %H:%M:%S',$when)));
}
}
}
where_log('filter_begin virus');
if (check_virus_bypass('',$RelayAddr,$RelayHostname,$Sender,\@Recipients) && !check_any_relay_option($Helo,'outsider')) {
md_syslog('info', "Virus-checking bypassed for: $RelayAddr");
$warnhead{'Virus-checking bypassed.'} ++;
} elsif (check_virus_time_exceeded($RelayAddr,$hostn)) {
md_syslog('info', "Virus-checking bypassed because of time limit for: $RelayAddr");
$warnhead{'Virus-checking bypassed.'} ++;
} else {
# Copy original message into work directory as an "mbox" file for
# virus-scanning
#md_copy_orig_msg_to_work_dir();
md_copy_orig_msg_to_work_dir_as_mbox_file();
# Scan for viruses if any virus-scanners are installed
debug_log(2,"Virus Scan Start Mail");
my ($code,$ocategory,$oaction,$virname) = thingy_contains_virus();
debug_log(2,"Virus Scan End Mail");
my ($catact,$category,$action) = antivirus_map_catact('message',$code,$ocategory,$oaction,$virname);
$forcespamcheck ++ if ($action eq 'quarantine');
if (spamassassin_virus_hit('message',$code,$ocategory,$oaction,$virname) && !$catact) {
$category = 'ok';
$action = 'ok';
}
# Lower level of paranoia - only looks for actual viruses
$FoundVirus ++ if($category eq "virus");
$FoundSuspected ++ if ($action eq "quarantine");
# Higher level of paranoia - takes care of "suspicious" objects
#$FoundVirus = ($action eq "quarantine");
my $vscanner = get_antivirus_string();
do_action_insert_or_change_header($entity,"X-Virus-Scanned-By", "$MyFilterHostName, using $vscanner");
if ($action eq "tempfail") {
# Find out wich virus-scanner(s) we're using...
md_syslog('warning', "Problem running virus scanner: code=$code, category=$category, action=$action, scanners=$vscanner");
return do_action_tempfail("Problem running virus-scanner");
} elsif ($FoundVirus) {
$virname =~ s/, ?/ /g;
# Discard the entire message.
spamassassin_hit('VIRUS_MAIL',$SASuspiciousScore,'A virus-scanner found a virus.');
do_result_report($entity,0,"Message contained virus: $virname");
dict_add_virus($RelayAddr);
report_address_relay_virus($RelayAddr);
if (pass_abuse()) {
debug_log(-1,'filter_begin virus-scan: %s %s','virus',$virname);
} else {
#md_graphdefang_log('virus', $virname, $RelayAddr);
stats_log($VirusDiscard?'discard':'reject','virus',$virname);
return action_discard() if ($VirusDiscard);
return do_action_bounce("Message contained virus: $virname");
}
} else {
if ($FoundSuspected) {
debug_log(1,'filter_begin virus-scan: %s %s','suspected',$virname);
spamassassin_hit('SUSPECT_MAIL',$SASuspiciousScore,'A virus-scanner found this mail suspicious.');
} elsif ($category ne 'ok') {
debug_log(-1,'filter_begin virus-scan: %s %s %s',$category,$action,$code);
}
}
}
where_log('filter_begin check replace attachments');
check_replace_attachments($entity,(check_internal_whitelist($RelayAddr)||check_authenticated()));
where_log('filter_begin end');
}
#***********************************************************************
# %PROCEDURE: filter
# %ARGUMENTS:
# entity -- a Mime::Entity object (see MIME-tools documentation for details)
# fname -- the suggested filename, taken from the MIME Content-Disposition:
# header. If no filename was suggested, then fname is ""
# ext -- the file extension (everything from the last period in the name
# to the end of the name, including the period.)
# type -- the MIME type, taken from the Content-Type: header.
#
# NOTE: There are two likely and one unlikely place for a filename to
# appear in a MIME message: In Content-Disposition: filename, in
# Content-Type: name, and in Content-Description. If you are paranoid,
# you will use the re_match and re_match_ext functions, which return true
# if ANY of these possibilities match. re_match checks the whole name;
# re_match_ext checks the extension. See the sample filter below for usage.
# %RETURNS:
# Nothing
# %DESCRIPTION:
# This function is called once for each part of a MIME message.
# There are many action_*() routines which can decide the fate
# of each part; see the mimedefang-filter man page.
#***********************************************************************
sub filter {
my($entity, $fname, $ext, $type) = @_;
#die('Missing modules!') unless (load_modules('Mail::Header'));
return if message_rejected(); # Avoid unnecessary work
where_log('filter begin');
#debug_log(0,"filter fn:'$fname' fe:'$ext' mt:'$type'") if ($fname || $ext);# || ($type && $type !~ /^text\/(plain|html)$/));
# Spam/ham report?
return action_accept() if ($is_xam_report);
# Fix headers?
if (fix_entity_headers($entity)) {
action_rebuild();
}
# Security checks 1
if (pass_abuse() || check_recipients_white('security',\@Recipients)) {
md_syslog('info', "Security-checking F1 of entity bypassed: $RelayAddr; ".join(', ',@Recipients));
$warnhead{'Security-checking bypassed.'} ++;
} else {
# Block message/partial parts
if (lc($type) eq "message/partial") {
#md_graphdefang_log('message/partial');
stats_log('reject','partial');
return do_action_bounce("MIME type message/partial not accepted here");
return action_discard();
}
}
# Virus scan
if (check_virus_bypass('',$RelayAddr,$RelayHostname,$Sender,\@Recipients)) {
md_syslog('info', "Virus-checking of entity bypassed for: $RelayAddr");
$warnhead{'Virus-checking bypassed.'} ++;
} else {
my $hostn = '';
$hostn = $RelayHostname if (defined($RelayHostname));
where_log('filter virus');
if (check_virus_time_exceeded($RelayAddr,$hostn)) {
md_syslog('info', "Virus-checking for entity bypassed because of time limit for: $RelayAddr");
$warnhead{'Virus-checking bypassed.'} ++;
} elsif (check_virus_entity_no_scan($entity)) {
md_syslog('info', "Virus-checking bypassed because of entity size: $RelayAddr");
$warnhead{'Virus-checking bypassed.'} ++;
} else {
debug_log(2,"Virus Scan Start Entity");
my ($code,$ocategory,$oaction,$virname) = thingy_contains_virus($entity);
debug_log(2,"Virus Scan End Entity");
my ($catact,$category,$action) = antivirus_map_catact('entity',$code,$ocategory,$oaction,$virname);
$forcespamcheck ++ if ($action eq 'quarantine');
if (spamassassin_virus_hit('entity',$code,$ocategory,$oaction,$virname) && !$catact) {
$category = 'ok';
$action = 'ok';
}
# If you are more paranoid, change to: if ($action eq "quarantine") {
if ($category eq "virus") {
$FoundVirus ++;
$virname =~ s/, ?/ /g;
#md_graphdefang_log('virus', $virname, $RelayAddr);
stats_log('discard','virus',$virname);
#action_add_header("X-Virus-Scan", "Found and deleted $virname");
# Discard the entire message.
spamassassin_hit('VIRUS_ENTITY',$SASuspiciousScore,'A virus-scanner found a virus.');
do_result_report(0,0,"Message contained virus: $virname");
dict_add_virus($RelayAddr);
report_address_relay_virus($RelayAddr);
if (pass_abuse()) {
debug_log(-1,'filter virus-scan: %s %s','virus',$virname);
} else {
stats_log($VirusDiscard?'discard':'reject','virus',$virname);
return action_discard() if ($VirusDiscard);
return do_action_bounce("Entity contained virus: $virname");
}
} elsif ($action eq "quarantine") {
$FoundSuspected ++;
# But quarantine the part for examination later. Comment
# the next line out if you don't want to bother.
if (pass_abuse()) {
debug_log(-1,'filter_begin: %s %s','suspected',$virname);
} else {
debug_log(1,'filter_begin: %s %s','suspected',$virname);
$modhead{'Quarantined suspicious entity.'} ++;
#md_graphdefang_log('suspect_entity', $fname, $type);
stats_log('modified','suspect_entity',$fname);
removed_part_note("An attachment named \"$fname\"",'was suspected of being a virus');
spamassassin_hit('SUSPECT_ENTITY',$SASuspiciousScore,'A virus-scanner found suspicious content.');
return do_action_quarantine('removed',$entity,"Suspected virus: \"$fname\"");
}
} elsif ($action eq "tempfail") {
return do_action_tempfail("Problem running virus-scanner");
md_syslog('warning', "Problem running virus scanner: code=$code, category=$category, action=$action");
} elsif ($category ne 'ok') {
debug_log(-1,'filter virus-scan: %s %s %s',$category,$action,$code);
}
}
}
# Security checks 2
if (pass_abuse() || check_recipients_white('security',\@Recipients)) {
md_syslog('info', "Security-checking F2 of entity bypassed: $RelayAddr; ".join(', ',@Recipients));
$warnhead{'Security-checking bypassed.'} ++;
} else {
where_log('filter filename');
if (check_bad_filename($entity) && !(check_recipients_white('filename',\@Recipients) && check_sender_white('filename',$Sender))) {
$modhead{'Quarantined file with bad name.'} ++;
#md_graphdefang_log('bad_filename', $fname, $type);
stats_log('modified','bad_filename',[$fname,$type]);
removed_part_note("An attachment named \"$fname\"",'constituted a security hazard');
return do_action_quarantine('removed',$entity,"Bad file name: \"$fname\"");
}
# eml is bad if it's not multipart
#if (re_match($entity, '\.eml')) {
# $modhead{'Quarantined bad eml attachment.'} ++;
# #md_graphdefang_log('non_multipart');
# stats_log('modified','non_multipart',$fname);
# return action_quarantine($entity,
# removed_part_note("A non-multipart attachment named \"$fname\"",'constituted a security hazard').
# note_footer('QDir:'.get_quarantine_dir())
# );
#}
# Check that office files aren't executables (thanks again M$)
where_log('filter office');
my $re = '\.' . $office_exts;
if ((re_match_ext($entity, $re) || $type =~ /\/(ms|microsoft)-?(word|access|powerpoint|excel)$/i) &&
(defined($entity->bodyhandle) && defined($entity->bodyhandle->path))) {
my $ft = check_file_type($entity->bodyhandle->path);
if ($ft && $ft =~ /executable/i) {
dict_add_virus($RelayAddr);
$modhead{'Quarantined hidden executable.'} ++;
#debug_log(0,"filter: This attach would have been quarantined because it is executable: $fname");
#md_graphdefang_log('hidden_executable');
stats_log('modified','hidden_executable',$fname);
removed_part_note("A probable MS Office attachment named \"$fname\"",'seemed to be an executable file');
return do_action_quarantine('removed',$entity,"Hidden executable: \"$fname\"");
}
}
#Cleaning HTML code
where_log('filter clean');
if ($type eq "text/html" && $disable_bad_html && load_modules('HTML::Parser','HTML::Entities','CSS::Tiny')) {
# Clean up HTML if Anomy::HTMLCleaner is installed.
# $Features{"HTMLCleaner"} = load_modules('Anomy::HTMLCleaner');
#if ($Features{"HTMLCleaner"}) {
# if ($type eq "text/html") {
# $ModifiedHTML = 1;
# return anomy_clean_html($entity);
# }
#}
my($currentline, $output, $badtag, $delimiter_backup);
$badtag = 0;
$output = "";
if (defined($entity->bodyhandle) && defined($entity->bodyhandle->path) &&
(-s $entity->bodyhandle->path <= $dbh_sizelimit) &&
(-s $entity->bodyhandle->path <= $mailtoobig)) {
if ($io = $entity->open("r")) {
{
local $/;
$output = $io->getline;
$io->close;
}
# Test the experimental stuff and report
debug_log(4,"filter: HTML Check");
my ($ch,$nh) = html_cleaning_thingy($output);
if ($ch) {
debug_log(1,"filter: HTML Changed");
my ($octeh,$ncteh) = ('','');
if ($entity->head) {
$octeh = $entity->head->mime_attr('Content-transfer-encoding');
$octeh = '' unless (defined($octeh));
if ($octeh !~ /^(base64|quoted-printable)$/i) {
debug_log(1,"filter: HTML Transfer Encoding Changed");
$ncteh = 'quoted-printable';
$entity->head->mime_attr('Content-transfer-encoding',$ncteh);
}
}
html_cleaning_report($output,$nh,$octeh,$ncteh) if (defined($dbh_report) && $dbh_report);
if ($io = $entity->open("w")) {
$io->print($nh);
$io->close;
$ModifiedHTML = 1;
#md_graphdefang_log('modified_entity', 'html');
#md_graphdefang_log('modified_entity', 'encoding') if ($ncteh);
stats_log('modified','modified_entity','html');
stats_log('modified','modified_entity','encoding') if ($ncteh);
action_rebuild();
}
}
# KAM stuff currently disabled...
# Based on work by Columbia University / Joseph Brennan
# Thanks KAM (Kevin A. McGrail)
#$badtag = $output =~ s/<(iframe|script|object)\b/<no-$1 /igs;
#if ($badtag) {
# if ($io = $entity->open("w")) {
# $io->print($output);
# $io->close;
# }
# $ModifiedHTML = 1;
# #md_graphdefang_log('badhtml',$badtag);
# stats_log('modified','badhtml',$badtag);
# #action_change_header("X-Warning", "$badtag Iframe/Object/Script tag(s) deactivated by MIMEDefang");
# action_rebuild();
#}
}
}
}
}
unless (pass_abuse() || check_recipients_white('attachments',\@Recipients)) {
where_log('filter attach');
if (maybe_replace_attachment($entity,$fname,$type)) {
stats_log('modified','replaced_attachment',$fname);
return 1;
}
}
where_log('filter end');
return action_accept();
}
#***********************************************************************
# %PROCEDURE: filter_multipart
# %ARGUMENTS:
# entity -- a Mime::Entity object (see MIME-tools documentation for details)
# fname -- the suggested filename, taken from the MIME Content-Disposition:
# header. If no filename was suggested, then fname is ""
# ext -- the file extension (everything from the last period in the name
# to the end of the name, including the period.)
# type -- the MIME type, taken from the Content-Type: header.
# %RETURNS:
# Nothing
# %DESCRIPTION:
# This is called for multipart "container" parts such as message/rfc822.
# You cannot replace the body (because multipart parts have no body),
# but you should check for bad filenames.
#***********************************************************************
sub filter_multipart {
my($entity, $fname, $ext, $type) = @_;
#die('Missing modules!') unless (load_modules('Mail::Header'));
return if message_rejected(); # Avoid unnecessary work
where_log('filter_multipart begin');
# Spam/ham report?
return action_accept() if ($is_xam_report);
# Fix headers?
if (fix_entity_headers($entity)) {
action_rebuild();
}
# Check recipient white list
return action_accept() if (pass_abuse() || check_recipients_white('security',\@Recipients));
where_log('filter_multipart filename');
if (check_bad_filename($entity) && !(check_recipients_white('filename',\@Recipients) && check_sender_white('filename',$Sender))) {
$modhead{'Quarantined file with bad name.'} ++;
#md_graphdefang_log('bad_filename', $fname, $type);
stats_log('modified','bad_filename',[$fname,$type]);
#action_notify_administrator("A MULTIPART attachment of type \"$type\", named \"$fname\" was dropped.\n");
removed_part_note("An attachment of type \"$type\", named \"$fname\"",'constituted a security hazard');
return do_action_quarantine('removed',$entity,"Bad file name: \"$fname\" (\"$type\")");
}
# eml is bad if it's not message/rfc822
if (re_match($entity, '\.eml') and ($type ne "message/rfc822" && $type ne "text/plain")) {
$modhead{'Quarantined bad eml attachment.'} ++;
#md_graphdefang_log('non_rfc822', $fname);
stats_log('modified','non_rfc822',$fname);
removed_part_note("A non-message/rfc822 attachment named \"$fname\"",'constituted a security hazard');
return do_action_quarantine('removed',$entity,"Non RFC822 eml: \"$fname\"");
}
# Block message/partial parts
if (lc($type) eq "message/partial") {
#md_graphdefang_log('message/partial');
stats_log('reject','partial');
do_result_report(0,0,"Message contained part of type message/partial.");
do_action_bounce("MIME type message/partial not accepted here");
return;
}
where_log('filter_multipart end');
return action_accept();
}
#***********************************************************************
# %PROCEDURE: defang_warning
# %ARGUMENTS:
# oldfname -- the old file name of an attachment
# fname -- the new "defanged" name
# %RETURNS:
# A warning message
# %DESCRIPTION:
# This function customizes the warning message when an attachment
# is defanged.
#***********************************************************************
sub defang_warning ($$) {
my($oldfname, $fname) = @_;
return "An attachment named \"$oldfname\" was converted to \"$fname\".\n" .
"To recover the file, right-click on the attachment and Save As\n" .
"\"$oldfname\"\n";
}
#***********************************************************************
# %PROCEDURE: filter_end
# %DESCRIPTION:
# The last of the filter functions.
# is defanged.
#
# If SpamAssassin found SPAM, append report. We do it as a separate
# attachment of type text/plain
#***********************************************************************
sub filter_end {
my($entity) = @_;
#die('Missing modules!') unless (load_modules('Mail::Header'));
# No sense doing any extra work
if (message_rejected()) {
clear_from_filter_end();
return;
}
where_log('filter_end begin');
# Spam report?
if (handle_xam_report($is_xam_report)) {
clear_from_filter_end();
return action_discard();
}
my $versions = 'MIMEDefang '.md_version()." with local filter $FilterVersion";
where_log('filter_end verify');
my @AuthPassed = ();
my $AuthFail = 0;
my @AuthResults = ();
my @warninginfos = ();
if (will_verify()) {
my @AuthForged = ();
my @results = ();
my $failures = '';
my $isint = (check_internal_whitelist($RelayAddr) || check_black_nets($RelayAddr));
$AuthFail ++ unless (check_verified_check('Relay',\$failures,\@results,\@AuthPassed,\@AuthForged,verify_relay_network($entity,\@AuthResults)));
$AuthFail ++ unless (check_verified_check('Auth',\$failures,\@results,\@AuthPassed,\@AuthForged,verify_authenticated($entity,\@AuthResults)));
$AuthFail ++ unless (check_verified_check('PGP',\$failures,\@results,\@AuthPassed,\@AuthForged,verify_pgp_signature($entity,\@AuthResults)));
$AuthFail ++ unless (check_verified_check('S/MIME',\$failures,\@results,\@AuthPassed,\@AuthForged,verify_smime_signature($entity,\@AuthResults)));
del_authentication_results($entity,$isint);
unless ($isint) {
$AuthFail ++ unless (check_verified_check('DomainKeys',\$failures,\@results,\@AuthPassed,\@AuthForged,verify_dk_signature($entity,\@AuthResults)));
$AuthFail ++ unless (check_verified_check('DKIM',\$failures,\@results,\@AuthPassed,\@AuthForged,verify_dkim_signature($entity,\@AuthResults)));
$AuthFail ++ unless (check_verified_check('SPF',\$failures,\@results,\@AuthPassed,\@AuthForged,verify_spf_mfrom($entity,\@AuthResults)));
$AuthFail ++ unless (check_verified_check('SPF',\$failures,\@results,\@AuthPassed,\@AuthForged,verify_spf_helo($entity,\@AuthResults)));
$AuthFail ++ unless (check_verified_check('SPF',\$failures,\@results,\@AuthPassed,\@AuthForged,verify_spf_pra($entity,\@AuthResults)));
}
add_verified_results();
if ($failures) {
debug_log(3,'filter_end: %s auth failures: <%u> %s',$AuthFail,$failures);
do_action_insert_header($entity,'X-Auth-Failed',sprintf('%s:%s %s',$MyFilterHostName,$SLVars{QI},$failures));
}
unless ($failures || @AuthForged || $AuthFail) {
my @cap = clean_auth_passed($entity,@AuthPassed);
do_action_insert_header($entity,'X-Auth-Passed',sprintf('%s:%s %s',$MyFilterHostName,$SLVars{QI},join(' ',@cap))) if (@cap);
}
do_action_insert_header($entity,'X-Auth-Forged',sprintf('%s:%s %s',$MyFilterHostName,$SLVars{QI},join(' ',@AuthForged))) if (@AuthForged);
add_authentication_results($entity,\@results);
push @warninginfos, list_authentication_failures(\@results);
if ($is_result_query && $MailResultVerify && !$isint) {
my $rqok = 0;
foreach $vfy (@AuthPassed) {
my ($vt,$snd) = split(/:/,$vfy,2);
next unless ($vt =~ /^(SPF|DKIM|DK|DomainKey)$/i);
debug_log(1,"filter_end: verify result %s",$snd);
if (check_sender_white('result',$snd)) {
$rqok = 1;
last;
}
}
unless ($rqok) {
debug_log(1,"filter_end: bounce unverified result query");
stats_log('reject','unverified_query');
clear_from_filter_end();
return do_action_bounce("Result queries must be from verified sender!");
}
}
}
where_log('filter_end bouncecoll');
collect_bouncing_addresses();
where_log('filter_end spam');
my ($ipos,$iposver,$iposhead) = get_ip_os();
my $country = get_ip_country($RelayAddr);
my ($nospamcheck,$gdbhostreset) = check_for_spam($entity,\@AuthPassed,$ipos,$iposver,$iposhead,$country,\@AuthResults);
$iposhead = '' if ($ipos =~ /^\s*unknown\s*$/is);
if (message_rejected()) {
clear_from_filter_end();
return;
}
# Whitelist host in greylist...
greylist_white_host($RelayAddr) unless ($gdbhostreset || check_internal_whitelist($RelayAddr));
# Local bypassing delivery?
my $ldal = read_delivery_file('local-delivery');
if ($ldal) {
my $trapped = 0;
for my $ai (@{$ldal}) {
foreach my $rcpt (@Recipients) {
next unless ($rcpt =~ /^<?$ai->{a}?>$/);
$trapped ++;
stats_log('trapped',$rcpt);
do_xam_report('local-delivery',$ai->{d},$rcpt,$ai->{a});
do_del_recipients($rcpt) if ($ai->{w} =~ /[->]/ && $ai->{w} !~ /[=+]/);
trap_add($RelayAddr);
stats_log('deliver','local');
}
}
if ($trapped && !list_recipients()) {
stats_log('discard','trapped',\@Recipients);
clear_from_filter_end();
return action_discard();
}
}
# Fix headers?
where_log('filter_end headers');
fix_entity_headers($entity,1);
# Exclaim?
where_log('filter_end exclaim');
do_action_insert_or_change_header($entity,"X-Exclamation",$silly_exclaim,-1);
do_action_insert_or_change_header($entity,'X-Fortune',get_oneliner(),-1);
# Add hashcashes
where_log('filter_end hashcash');
add_hashcashes($entity);
# Add an easy to read envelope header and write a log.
where_log('filter_end envelope header');
if ($is_result_query) {
$logas = 'result_query';
} elsif ($nospamcheck) {
$logas = 'passed';
} else {
$logas = 'accepted';
}
my $rsmtpfrom = "Mail From: $Sender\n";
my $xsmtpfrom = "$logas $Sender";
if ($RelayHostname) {
$xsmtpfrom .= " $RelayHostname";
$rsmtpfrom .= "Relay Name: $RelayHostname\n";
}
$xsmtpfrom .= " [$RelayAddr] ($Helo)";
$rsmtpfrom .= "Relay Addr: $RelayAddr\n";
$rsmtpfrom .= "Relay Helo: $Helo\n";
get_received_countries($entity);
my $location = get_ip_location($RelayAddr);
add_a_country($country) if ($country);
if ($location) {
$xsmtpfrom .= " {$location}";
$rsmtpfrom .= "Relay Location: $location\n";
} elsif ($country) {
$xsmtpfrom .= " {$country}";
$rsmtpfrom .= "Relay Country: $country\n";
}
if ($iposhead) {
$xsmtpfrom .= " [$iposhead]";
$rsmtpfrom .= "Relay OS: $iposhead\n";
}
do_action_insert_header($entity,"X-SMTP-From", $xsmtpfrom,0);
if (@countries) {
add_a_country($MyFilterHostCountry) if ($MyFilterHostCountry);
#debug_log(0,'Countries: %s',join(', ',@countries));
do_action_insert_header($entity,"X-Countries", mqpma(1,@countries),0);
}
unshift @result_reports, $rsmtpfrom if ($is_result_query);
#if (defined($RelayHostname) && $RelayHostname ne "") {
# md_graphdefang_log($logas, $RelayHostname, $RelayAddr);
#} else {
# md_graphdefang_log($logas, $Helo, $RelayAddr);
#}
stats_log('deliver',$logas);
# If you don't mind HTML mail, comment out the next lines.
# Remove redundant HTML if mail to *.frukt.org.
where_log('filter_end remove redundant');
if ($RemoveRedundantHTMLFor && !(pass_abuse() || check_recipients_white('html',\@Recipients))) {
foreach my $currecipient (@Recipients) {
#md_syslog('info',"RRHP: R=$currecipient");
if ($currecipient =~ /^<?$RemoveRedundantHTMLFor>?$/i) {
debug_log(5,'remove redundant "%s" "%s"',$currecipient,$RemoveRedundantHTMLFor);
#md_syslog('info',"RRHP: R!");
if (remove_redundant_html_parts($entity)) {
stats_log('modified','removed_redundant','html');
debug_log(2,"filter_end: Removing redundant HTML");
$modhead{'Removed redundant HTML part(s).'} ++;
append_text_boilerplate($entity, "---------------------------------------------------------\nGateway notice:\nRedundant HTML parts have been removed from this message.", 0);
$ModifiedHTML = 0;
}
last;
}
}
}
where_log('filter_end warnings 1');
if (@removed_parts) {
$modhead{'Removed parts.'} ++;
push @warningtexts, join("\n",@removed_parts,'',"If you require the removed content, please contact the sender or $AdminName <$AdminContactAddress> and arrange an alternate means of receiving it.",'');
debug_log(3,"filter_end, added part removal warning.");
}
if ($FoundVirus || $FoundSuspected) {
my $warntxt;
$modhead{'Added warning about bad content.'} ++;
if ($FoundVirus) {
$warntxt = "WARNING: A virus was found in this message, but for some unfathomable reason it was allowed to pass the gate.";
} else {
$warntxt = "Warning: This message was considered suspicious by at least one virus-scanner.";
}
push @warningtexts, "$warntxt\nBe careful of what you do with it!\n";
debug_log(2,"filter_end, added content modification warning.");
}
if ($AuthFail && $authfailwarning) {
$modhead{'Added warning about failed authenticity check(s).'} ++;
push @warningtexts, "WARNING: This message failed $AuthFail authenticity check(s). It might be a forgery.\n";
debug_log(1,"filter_end, added authenticity modification warning.");
}
if ($ModifiedHTML) {
$modhead{'Cleansed HTML code.'} ++;
#action_add_part($entity, "text/plain", "-suggest",
# "The HTML code in this mail was modified for security reasons.\n" . note_footer(),
# '', #"Modified.txt",
# "inline",0);
do_action_quarantine_entire_message('modified','Modified HTML code in message.');
action_rebuild();
move_html_cleaning_reports(get_quarantine_dir());
push @warningtexts, "HTML in this message code was modified for security reasons.\n" if (@warningtexts);
debug_log(1,"filter_end, added HTML modification warning.");
}
where_log('filter_end attachments');
if (add_attachment_replacement_note($entity,1,1,0)) {
debug_log(0,'added attachment replacement note');
$modhead{'Added attachment replacement note.'} ++;
push @warningtexts, "Attachment(s) in this message was replaced because of size.\n" if (@warningtexts);
}
where_log('filter_end warnings 2');
if (@warningtexts) {
$modhead{'Added warning.'} ++;
action_add_part($entity,"text/plain","-suggest",join("\n",@warningtexts,note_footer(@warninginfos)),"Important.txt","inline",0);
action_rebuild();
debug_log(1,"filter_end, added warnings.");
}
if (replace_overlong_headers($entity)) {
$modhead{'Replaced overlong header(s).'} ++;
}
do_action_insert_header($entity,"X-Scanned-By", "$MyFilterHostName, using $versions");
do_action_insert_header($entity,"X-Hash", $input_message_hash) if ($input_message_hash);
# Handle boilerplates... Hopefully there aren't any...
my $abpbp = handle_boilerplates($entity);
# Handle recipient forwards
unless ($is_result_query) {
srs_recipients();
forward_recipients();
expand_recipients();
}
do_action_insert_header($entity,'X-Warnings',join("\n\t",keys %warnhead)) if (%warnhead);
if (%modhead) {
if ($did_quarantine) {
my $qdirn = get_quarantine_dir();
$qdirn =~ s/^.*\///;
$modhead{"QDir: $qdirn"} ++;
}
foreach my $mht (keys %modhead) {
delete($modhead{$mht}) unless ($modhead{$mht});
}
do_action_insert_header($entity,"X-Modified",join("\n\t",keys %modhead),0) if (%modhead);
}
html_cleaning_clear(1);
if ($GreyListAction && wants_extra_headers()) {
my $msgi = msgl_info_str($entity->head->get('Message-ID'),$Sender,@Recipients) if ($entity && $entity->head);
$msgi = " ($msgi)" if ($msgi);
do_action_insert_header($entity,'X-Greylist',"$GreyListAction$msgi");
}
# Whatever...
do_action_insert_header($entity,"X-Sendmail-Macros",macros_text('H')) if (wants_extra_headers());
# Almost all mods done, so flag waving is possible here
wave_flags($entity);
# Now we're finished, so we can read the stamp...
my $time = time_string(time_since_stamp());
do_action_insert_header($entity,"X-Filter-Time",sprintf('%us (%03.1fL %u%%)',$time,get_load_average(),get_swap_percentage()),0) if (wants_extra_headers());
where_log('filter_end result query');
if ($is_result_query) {
my $rqr = "Scanner: $MyFilterHostName, using $versions\n".
"Scan Time: $time\n";
$rqr .= join("\n",'Warnings:',keys %warnhead,'') if (%warnhead);
$rqr .= join("\n",'Actions:',keys %modhead,'') if (%modhead);
unshift @result_reports, $rqr;
}
do_result_report($entity,$modhead ne '');
if ($is_result_query) {
$is_result_query = 0;
debug_log(2,'Discarding result query message.');
clear_from_filter_end();
return action_discard();
}
do_action_delete_header($entity,'Bcc');
# apply pending recipient list changes
unless (sync_recipients($entity)) {
stats_log('reject','no_recipients');
clear_from_filter_end();
return action_discard();
}
# save to sentoutdb?
# Sender Rewriting?
out_add($entity,$Sender,@Recipients);
if (srs_sender()) {
out_add($entity,$Sender,@Recipients);
}
clear_from_filter_end();
where_log('filter_end end');
}
# DO NOT delete the next line, or Perl will complain.
1;
(2008-01-11)