#!perl
#***********************************************************************
#
# mimedefang-filter
#
# Spamassassin, antivirus, HELO checks, etc, etc, etc
#
# $Id: mimedefang-filter,v 1.214 2009/06/29 16:23:02 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.214 $';
$FilterDebug = 'se23';
#***********************************************************************
# 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 $SASuspiciousScore $SASuspiciousBodyScore $SASuspiciousHeadScore $SARemember);
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');
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 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();
# Maybe log to syslog
sub debug_log {
my $level = shift;
return if ($level>$debug_loglevel);
my $msg = shift;
my $mid = $MsgIDs;
$mid = '-' if (!$mid || $mid eq 'NOQUEUE');
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('%.3f',$e);
$h = sprintf('%.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,@_);
}
# Log for event analyzing
$logcsv = Text::CSV_XS->new({sep_char=>',',quote_char=>"'",binary=>1});
$logssv = Text::CSV_XS->new({sep_char=>';',quote_char=>'"',binary=>1});
sub stats_log {
if (@_ == 5 && $_[4] eq '*') {
my @add = ($RelayAddr,$RelayHostname,$Helo,$Sender,\@Recipients,$Subject);
splice @_, 4, 1, @add;
}
my $mid = splice(@_,1,1);
my @lst = ();
foreach my $fld (@_) {
if (ref($fld) eq 'ARRAY') {
push @lst, $logcsv->string() if ($logcsv->combine(@{$fld}));
} elsif (ref($fld) eq 'HASH') {
my @sl = ();
while (my ($k,$v) = each %{$fld}) {
push @sl, "$k=$v";
}
push @lst, $logcsv->string() if ($logcsv->combine(@sl));
} elsif (ref($fld) eq 'SCALAR') {
push @lst, $$fld;
} elsif (ref($fld) eq '') {
push @lst, $fld;
}
}
return unless (@lst);
$lst[0] = '-' unless ($lst[0]);
$lst[0] = lc($lst[0]);
unshift @lst, 'mdstats';
return unless ($logssv->combine(@lst));
my $ls = $logssv->string();
$ls =~ s/([%\x00-\x1F\x7F-\xFF])/sprintf('%%%02x',ord($1))/gse;
$mid = '?' if ($mid =~ /^(|NOQUEUE)$/i);
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',$MsgIDs,$nl,@_);
} else {
stats_log('spaminfo',$MsgIDs,$h,@_);
}
}
# Maybe log for greylist analyzing
sub greylist_log {
my $e = shift @_;
stats_log('greylist',$MsgIDs,$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;
}
# 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 = "<$MsgIDs> $msg" if ($MsgIDs);
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: $MsgIDs";
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',$MsgIDs,'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',$MsgIDs,'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)',
$MsgIDs,time());
} else {
sql_execute('REPLACE INTO times (ts_id,ts_stamp) VALUES (?,?)',$MsgIDs,time());
}
}
sub time_since_stamp() {
my $time = sql_select_one('SELECT ts_stamp FROM times WHERE ts_id=?',$MsgIDs);
return time()-$time if ($time);
return -1;
}
sub end_time_stamp() {
return unless ($MsgIDs);
my $start = sql_select_one('SELECT ts_stamp FROM times WHERE ts_id=?',$MsgIDs);
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,$MsgIDs);
stats_log('time',$MsgIDs,$time) 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,@_);
}
#***********************************************************************
# 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;
}
# 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 {
my($format,$ip,$hostname,$helo,$from,$sender,$recipients,$entity,$list,$reverse,$comment) = @_;
# 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,"","") if (!($list && @{$list}));
$ip = address_strip($ip);
$hostname = address_strip($hostname);
$helo = address_strip($helo);
$from = address_strip($from);
$sender = address_strip($sender);
my $prefix = '';
if ($format =~ /^L:(.*)$/i) {
$prefix = $1;
$prefix =~ s/^(.)(.*?)_*$/$1($2)?_?/;
}
#my $addr = inet_aton($ip);
address_list_log('check_address_list %s %s "%s" "%s" "%s" "%s" "%s" "%s" %s',$comment?$comment:'-',$format,$ip,$hostname,$helo,$from,$sender,$recipients?join(',',@{$recipients}):'',$entity?'entity':'-');
my $hit = "";
my $log = "";
my $mp = '.+@';
my $plain = ($format =~ /^[PR]/i);
foreach $l (@{$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 ($format =~ /^P/i) {
$et = "HOST";
$addr = $line;
} elsif ($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 ($format =~ /^L/i) {
($et,$addr) = split(/\s+/,$line,2);
}
if (defined($et) && $et ne "" && defined($addr) && $addr ne "") {
#address_list_log('check_address_list ? "%s"=~"%s..." "%s"',$et,$prefix,$addr);
if ($et =~ /^${prefix}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 (($sender =~ /^$addr1$/i) && ($ip =~ /^$addr2$/i)) {
$hit = "$sender!$ip";
$log = "sender_host";
}
} elsif ($et =~ /^${prefix}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 ($sender =~ /^$addr1$/i) {
if ($hostname =~ /^$addr2$/i) {
$hit = "$sender!$hostname";
$log = "sender_host";
} elsif ($helo =~ /^$addr2$/i) {
$hit = "$sender!$helo";
$log = "sender_helo";
} elsif ($ip =~ /^$addr2$/i) {
$hit = "$sender!$ip";
$log = "sender_host";
}
}
} elsif ($et =~ /^${prefix}S(?:ender)?/i) {
#address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'S(ender)?');
if ($sender =~ /^$addr$/i) {
$hit = $sender;
$log = "mail_from";
}
} elsif ($et =~ /^${prefix}H(?:ost)?/i) {
#address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'H(ost)?');
if (($plain && $hostname eq $addr) || (!$plain && $hostname =~ /^$addr$/i)) {
$hit = $hostname;
$log = "host";
} elsif (($plain && $helo eq $addr) || (!$plain && $helo =~ /^$addr$/i)) {
$hit = $helo;
$log = "helo";
} elsif (($plain && $from eq $addr) || (!$plain && $from =~ /^$addr$/i)) {
$hit = $from;
$log = "from";
} elsif (($plain && $ip eq $addr) || (!$plain && $ip =~ /^$addr$/i)) {
$hit = $ip;
$log = "host";
} elsif (($plain && $sender eq $addr) || (!$plain && $sender =~ /^$mp$addr$/i)) {
$hit = $sender;
$log = "mail_from";
}
} elsif ($et =~ /^${prefix}R(?:elay)?/i) {
#address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'R(elay)?');
if (($plain && $ip eq $addr) || (!$plain && $ip =~ /^$addr$/i)) {
$hit = $ip;
$log = "host";
}
} elsif ($et =~ /^${prefix}He(?:ll?o)?/i) {
#address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'He(ll?o)?');
if (($plain && $helo eq $addr) || (!$plain && $helo =~ /^$addr$/i)) {
$hit = $helo;
$log = "helo";
}
} elsif ($et =~ /^${prefix}(?:To?|R(?:[ce]|cpt|ecipient))$/i) {
#address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'R(cpt|ecipient)?');
if ($recipients) {
foreach my $val (@{$recipients}) {
next unless (address_strip($val) =~ /^$addr$/i);
$hit = $val;
$log = 'rcpt';
last;
}
}
} elsif ($et =~ /^${prefix}B(?:ounce|nc)?/i) {
#debug_log(0,'CAL Bounce ?');
if ((defined($sender) && $sender eq '') &&
($recipients && (@{$recipients} == 1)) &&
(address_strip($recipients->[0]) =~ /^$addr$/i) &&
out_check_for_bounce($ip,$recipients->[0])) {
debug_log(0,'CAL Bounce ! <> <%s> ~ %s',$recipients->[0],$addr);
$hit = $recipients->[0];
$log = 'bounce';
}
} elsif ($et =~ /^${prefix}M(?:ulti)?/i) {
address_list_log('check_address_list + "%s"=~"%s%s"',$et,$prefix,'M(ulti)?');
my @hits = ();
my $miss = 0;
foreach my $mon (split(/\s+/,$addr)) {
my ($var,$val,$tst);
if ($mon =~ /^(\S+):(.*)$/) {
$var = $1;
$tst = $2;
$val = ($entity && $entity->head) ? $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 =~ /^(\S+)=(.*)$/) {
$var = $1;
$tst = $2;
address_list_log('check_address_list + multi v %s "%s"',$var,$tst);
if ($var =~ /^R(?:elay)?$/i) {
$val = $ip;
$var = 'relay';
} elsif ($var =~ /^S(?:ender)?$/i) {
$val = $sender;
$var = 'sender';
} elsif ($var =~ /^H(?:ost)?n?(?:ame)?$/i) {
$val = $hostname;
$var = 'host';
} elsif ($var =~ /^He(?:ll?o)?$/i) {
$val = $helo;
$var = 'helo';
} elsif ($var =~ /^(?:To?|R(?:[ce]|cpt|ecipient))$/i) {
$val = $recipients;
$var = 'rcpt';
} else {
$miss ++;
last;
}
$var .= '=';
address_list_log('check_address_list + multi V %s "%s" /^%s$/',$var,$val,$tst);
}
if ((ref($val) eq '') && ((!defined($val) && $tst eq '') || ($val =~ /^$tst$/i))) {
push @hits, "$var$val";
address_list_log('check_address_list + multi * %s "%s" /^%s$/',$var,$val,$tst);
next;
}
if (ref($val) eq 'ARRAY') {
if (!@{$val} && $tst eq '') {
push @hits, "$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 (address_strip($vali) =~ /^$tst$/i);
address_list_log('check_address_list + multi * %s "%s" /^%s$/',$var,$vali,$tst);
push @hits, "$var$vali";
$ahit ++;
last;
}
next if ($ahit);
}
$miss ++;
last;
}
if (@hits && !$miss) {
$hit = join(' & ',@hits);
$log = 'multi';
}
}
if ($hit ne "") {
address_list_log('check_address_list %s @ %s %s',$comment?$comment:'-',$log,$hit);
$retval = ($retval ? 0 : 1) if ($reverse);
return ($retval,$hit,$log);
}
}
}
}
return (0,$hit,$log);
}
# Checks against a list of addresses.
sub check_address_list_filtered {
my($filter,$format,$ip,$hostname,$helo,$from,$sender,$recipients,$entity,$list,$reverse,$comment) = @_;
# 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 (!($list && @{$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' = '$filter' ?");
if ($filter =~ /^$x$/i) {
debug_log(3,"FLineA: '$l'");
push @flst, $l;
}
}
}
}
return (0,"","") unless (@flst);
return check_address_list($format,$ip,$hostname,$helo,$from,$sender,$recipients,$entity,\@flst,$reverse,$comment);
}
# 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("L",$ip,$hostname,"","","",0,0,$cfdata,0,'backups');
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("L",$ip,$hostname,"","",$sender,0,0,$cfdata,0,'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("L",$ip,$hostname,$helo,$from,$sender,0,0,$cfdata,0,'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-by-recipient');
my ($found,$hit,$log) = check_address_list_filtered(address_strip($recipient),"L",$ip,$hostname,$helo,$from,$sender,[$recipient],0,$cfdata,0,'whitelist-by-recipient');
return 1 if ($found);
return check_external_whitelist($ip,$hostname,$sender);
}
# Check if blacklisted in blacklist-by-recipient file
sub check_external_blacklist_by_recipient($$$$$$) {
my ($ip,$hostname,$helo,$from,$sender,$recipient) = @_;
debug_log(4,"cebbr1");
#my $cfdata = read_list_file('/etc/mail/mimedefang-blacklist-by-recipient');
my $cfdata = read_list_file('blacklist-by-recipient');
debug_log(4,"cebbr1 $#$cfdata");
my($found,$hit,$log) = check_address_list_filtered(address_strip($recipient),"L",$ip,$hostname,$helo,$from,$sender,[$recipient],0,$cfdata,0,'blacklist-by-recipient');
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) = @_;
debug_log(7,'check_something_bypass: %s:%s p %s %s %s',$file,$prefix,$ip,$hostname,$sender);
my $cfdata = read_list_file($file);
my ($found,$hit,$log) = check_address_list($prefix?"L:$prefix":'L',$ip,$hostname,"","",$sender,$recipients,$entity,$cfdata,0,$file);
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,$sender) = split(/:/,$snd,2);
debug_log(7,'check_something_bypass: %s:%s v %s %s',$file,$prefix,$vt,$sender);
if ($sender =~ /\@/) {
($found,$hit,$log) = check_address_list("$prefix$vt",$ip,$hostname,"","",$sender,$recipients,$entity,$cfdata,0,$file);
($found,$hit,$log) = check_address_list($prefix.'verified',$ip,$hostname,"","",$sender,$recipients,$entity,$cfdata,0,$file) unless ($found);
} else {
($found,$hit,$log) = check_address_list("$prefix$vt",$ip,$hostname,$sender,"","",$recipients,$entity,$cfdata,0,$file);
($found,$hit,$log) = check_address_list($prefix.'verified',$ip,$hostname,$sender,"","",$recipients,$entity,$cfdata,0,$file) unless ($found);
}
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) = @_;
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 ($found,$hit,$log) = check_address_list($prefix?"L:$prefix":'L',$ip,$hostname,"","",$sender,$recipients,$entity,$cfdata,1,$file);
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);
($found,$hit,$log) = check_address_list($prefix?"L:$prefix":'L',$ip,$hostname,"","",$snd,$recipients,$entity,$cfdata,1,$file);
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) = @_;
$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: %f %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($failcode,$MsgIDs,"$log_prepend$log",$hit,'*');
} else {
stats_log($failcode,$msgid,"$log_prepend$log",$hit,$ip,$hostname);
}
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: %f %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);
debug_log(0,'remember_spam_hash: <%s> %s %s %s %i %i',$MsgIDs,$hash,$Sender,$rcpts,$report->{hits},$report->{req});
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),$MsgIDs);
} 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),
$MsgIDs,$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");
#md_syslog('info', "MDLOG,$MsgIDs,received_helo,$helo,$ip,?,?,?");
stats_log('reject',$MsgIDs,'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($MsgIDs,$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);
#md_syslog('info', "MDLOG,$MsgIDs,received_$log,$ip,$sender,?,?");
stats_log('reject',$MsgIDs,"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($MsgIDs.'_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',$MsgIDs,'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',$MsgIDs,'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',$MsgIDs,'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*\/$tag\s*>$/i);
return hc_output($text) if ($text =~ /^<\/$tag>$/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(),$$,$MsgIDs,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 (